新增文章

文章标题分类内容

Private WithEvents m_ListInterface  As ListEvents  '定义 ListEvents 接口. 必须具有的声明, 以此来获得事件
 
Public Sub Show(ByVal oListInterface As Object)
   
    Set m_ListInterface = oListInterface  'ListEvents 接口实现  '注意: 此方法必须存在, 请勿修改
End Sub

Private Sub Class_Terminate()

Set m_ListInterface = Nothing  '释放接口对象  '注意: 此方法必须存在, 请勿修改
End Sub

Private Sub m_ListInterface_MenuBarInitialize(ByVal oMenuBar As K3ClassEvents.MenuBar)  '添加菜单

Dim oBand As K3ClassEvents.BOSBand: Set oBand = oMenuBar.BOSBands("mnuEdit")
    Dim oTool As K3ClassEvents.BOSTool
    
  '----------------------------------------------------------------------------------
    Set oTool = oMenuBar.BOSTools.Add("mnuToExcel")
    With oTool
        .Caption = "导出 未发货明细"
        .Description = "导出 未发货明细"
        .ShortcutKey = 0
        .Visible = True
        .Enabled = True
        .BeginGroup = False
    End With

oMenuBar.BOSBands("mnuFile").BOSTools.InsertAfter "mnuExportData", oTool  '【引出内部数据】之后
    
  '----------------------------------------------------------------------------------
    Set oTool = Nothing
    Set oBand = Nothing

End Sub

Private Sub m_ListInterface_MenuBarClick(ByVal BOSTool As K3ClassEvents.BOSTool, Cancel As Boolean)  '菜单事件
    
  '------------------------------------------------------------------------------------------------------------
  ' 按钮名称
  
    Select Case BOSTool.ToolName
        
      Case "mnuToExcel":   ToExcel    '导出 Excel
      
      Case Else
    End Select
    
  '------------------------------------------------------------------------------------------------------------
  ' 清空对象
    
    Set aSelect = Nothing
End Sub

Private Sub ToExcel()
On Error Resume Next

Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet

Set xlApp = CreateObject("Excel.application") '创建 Excel 对象
    
    If Err Then
        MsgBox "导出失败！没有安装 Microsoft Excel ", vbExclamation, "一星提示": Exit Sub
    End If
    
    xlApp.Visible = True  '设置EXCEL对象 可见（或不可见）  xlApp.Visible = True

'-------------------------------------------------------------------------------------------------------------------------------------------------------------
 '打开 Excel
 
  ' Set xlBook = xlApp.Workbooks.Add    '新建 EXCEL 工件簿  Set xlbook = xlapp.Application.Workbooks.Add
  
  ' xlBook.RunAutoMacros (xlAutoOpen)   '运行EXCEL 启动宏
  ' xlBook.RunAutoMacros (xlAutoClose)  '运行EXCEL 关闭宏

Set xlBook = xlApp.Workbooks.Open(App.Path & "\excel\模板 销售订单 未出库.xltx") '打开工作簿  App.Path & "\模板 销售订单 未出库.xlsx"
    
    Set xlSheet = xlBook.Worksheets("配置")  '设置 活动工作表：Set xlSheet = xlBook.Worksheets(1)  当前工作簿的 第 1 个表，也可以换成 表名 "Sheet1"
    
    Dim aHeight As String    '行高
    Dim aFit As String       '自动换行
    Dim aSort As String      '排序

For i = 1 To 100
        aValue = xlSheet.Cells(i, 1).Value  '【当前工作表】单元格 【第 i 行】【第 1 列】
        
        If aValue = "自动换行" Then
            aFit = xlSheet.Cells(i, 2).Value
        ElseIf aValue = "行高" Then
            aHeight = xlSheet.Cells(i, 2).Value
        ElseIf aValue = "排序" Then
            aSort = xlSheet.Cells(i, 2).Value
        ElseIf aValue = "" Then
            i = 100
        End If
    Next i

'-------------------------------------------------------------------------------------------------------------------------------------------------------------
 ' 读取 sql 数据
 
    If Len(Replace(aSort, " ", "")) > 0 Then
    
        aSort = " order by " & aSort   '排序
    End If
    
    Set aRecordset = m_ListInterface.K3Lib.GetData("select * from a_SeOrder_QtyRemainReport" & aSort)
    If aRecordset.RecordCount > 0 Then
    
 '-------------------------------------------------------------------------------------------------------------------------------------------------------------
 '读取 Excel 数据
 
        Set xlSheet = xlApp.Application.Worksheets(1)  '设置 活动工作表
        
        xlSheet.Name = Format(Now(), "YYYY-MM-DD")  '当前日期
        
        Dim aGroup1 As String, aGroupName1 As String
        Dim aGroup21 As String, aGroupName21 As String
        Dim aGroup22 As String, aGroupName22 As String
        
        aGroup1 = xlSheet.Cells(3, 1)   '★ 【客户名称】
        aGroup21 = xlSheet.Cells(5, 1)  '★ 【合同号】
        aGroup22 = xlSheet.Cells(5, 7)  '★ 【订单日期订单编号】
        
        Dim aField As New KFO.Vector
        For i = 1 To 100
            aValue = xlSheet.Cells(1, i)  '【当前工作表】单元格 【第 1 行】【第 i 列】
            
            If aValue = "" Then
                i = 100
            Else
                aField.Add xlSheet.Cells(1, i).Value   '数据 字段名称
            End If
        Next i
 '-------------------------------------------------------------------------------------------------------------------------------------------------------------
 '导出数据

aStart = 5  '★ 【数据行】前一行号
        aRowCur = 6    '【数据行】当前行号
        
        aCount = 0     '【数据行】当前组 行数
        aCountAll = 0  '【数据行】所有组 行数
        
        For i = 1 To aRecordset.RecordCount
            
'            If i = 88 Then
'                aaa = 1
'            End If
            
            If i = 1 Then
                aGroupName1 = aRecordset.Fields(aGroup1)
                aGroupName21 = aRecordset.Fields(aGroup21)
                aGroupName22 = aRecordset.Fields(aGroup22)
                
                xlSheet.Cells(3, 1) = aGroupName1   '★ 【客户名称】
                xlSheet.Cells(5, 1) = aGroupName21  '★ 【合同号】
                xlSheet.Cells(5, 7) = aGroupName22  '★ 【订单日期订单编号】
            Else
                If aGroupName1 <> aRecordset.Fields(aGroup1) Then
                    
'                    aRowLine = aStart + 1 & ":" & aStart + aCount
'
'                    If aFit = "是" Then
'                        xlSheet.Rows(aRowLine).EntireRow.AutoFit  '【自动换行】
'                    End If
                    
                    aGroupName1 = aRecordset.Fields(aGroup1)
                    aGroupName21 = aRecordset.Fields(aGroup21)
                    aGroupName22 = aRecordset.Fields(aGroup22)
                    
                    xlSheet.Rows("2:5").Copy  '★ 复制【客户】【合同号】
                    
                    aRowCur = aStart + i - aCountAll
                    xlSheet.Rows(aRowCur).Insert Shift:=xlDown  '插入复制行
                    
                    xlSheet.Cells(aRowCur + 1, 1) = aGroupName1
                    xlSheet.Cells(aRowCur + 3, 1) = aGroupName21  '★
                    xlSheet.Cells(aRowCur + 3, 7) = aGroupName22  '★
                    
                    aStart = aStart + 4 + aCount: aCountAll = aCountAll + aCount: aCount = 0 '★
                    
                ElseIf aGroupName21 <> aRecordset.Fields(aGroup21) Or aGroupName22 <> aRecordset.Fields(aGroup22) Then
                
'                    aRowLine = aStart + 1 & ":" & aStart + aCount
'
'                    If aFit = "是" Then
'                        xlSheet.Rows(aRowLine).EntireRow.AutoFit  '【自动换行】
'                    End If
'
                    aGroupName21 = aRecordset.Fields(aGroup21)
                    aGroupName22 = aRecordset.Fields(aGroup22)
                    
                    xlSheet.Rows("4:5").Copy  '★ 复制【合同号】
                    
                    aRowCur = aStart + i - aCountAll
                    xlSheet.Rows(aRowCur).Insert Shift:=xlDown
                    
                    xlSheet.Cells(aRowCur + 1, 1) = aGroupName21
                    xlSheet.Cells(aRowCur + 1, 7) = aGroupName22
                    
                    aStart = aStart + 2 + aCount: aCountAll = aCountAll + aCount: aCount = 0  '★
                    
                End If
            
                xlSheet.Rows("6:6").Copy  '★ 复制【数据行】
                
                aRowCur = aStart + i - aCountAll
                xlSheet.Rows(aRowCur).Insert Shift:=xlDown  '插入复制行
                
            End If
            
            For a1 = 1 To aField.Size
                xlSheet.Cells(aRowCur, a1) = aRecordset.Fields(aField(a1))  '【填写数值】
                bbb = aRecordset.Fields(aField(a1))
            Next a1
            
            If aFit = "是" Then
                xlSheet.Rows(aRowCur).EntireRow.AutoFit  '【自动换行】
            End If
            
            If xlSheet.Rows(aRowCur).RowHeight < aHeight Then
               xlSheet.Rows(aRowCur).RowHeight = aHeight      '【设置行高】 1磅 = 0.035cm
            End If
            
            aCount = aCount + 1

aRecordset.MoveNext
        Next i
        
        xlApp.CutCopyMode = False    '取消复制

xlSheet.Cells(1, 9).Select   '选中单元格
        
    '---------------------------------------------------------------------------------------------------------------------------------
    '显示【保存文件】对话框
 
        Dim aFilePath As Object:  Set aFilePath = xlApp.FileDialog(2):
        Dim aFilter As Object:    Set aFilter = aFilePath.Filters
        
        For a2 = 1 To aFilter.Count
            If aFilter(a2).Extensions = "*.xlsx" Then  '设置 默认格式
                aFilePath.FilterIndex = a2
                Exit For
            End If
        Next
        
        aFilePath.Show   '显示【保存文件】对话框

xlSheet.SaveAs aFilePath.SelectedItems(1)   '保存到【选择的位置】    xlSheet.SaveAs App.Path & "\test.xls"
        
    '---------------------------------------------------------------------------------------------------------------------------------
    '关闭 Excel
    
'        xlBook.Saved = True
'        xlBook.Close
'        xlApp.Quit
    
        Set xlApp = Nothing
    Else
        MsgBox "没有可导出的数据！", vbExclamation, "一星提示"
    End If
    
    Set aRecordset = Nothing
    
End Sub