moutputtabletoexcel.bas

公司订单管理系统,这对于方便公司管理床单

Attribute VB_Name = "mOutputTableToExcel"
Option Explicit

'****************************************************************************************************
'*
'*                                   將數據庫表中的數據導齣到Excel中
'*
'****************************************************************************************************
'Excel对象模型包括了128个不同的对象，从矩形、文本框等简单的对象到透视表，图表等复杂的对象。
'下面简单介绍一下其中最重要，也是用得最多的五个对象。
'1）Application对象:Application对象处于Excel对象层次结构的顶层，表示 Excel自身的运行环境。
'2）Workbook对象:Workbook对象直接地处于Application对象的下层，表示一个Excel工作薄文件。
'3）Worksheet对象:Worksheet对象包含于Workbook对象，表示一个Excel工作表。
'4）Range对象:Range对象包含于Worksheet对象，表示 Excel工作表中的一个或多个单元格。
'5）Cells对象:Cells对象包含于Worksheet对象，表示Excel工作表中的一个单元格
Private xlsApp As Excel.Application
Private xlsBook As Excel.Workbook
Private xlsSheet As Excel.Worksheet

Public Function OutPutTableRecordsToExcel(ByVal CurrentUser As String, _
                                          ByRef dgOutPutHeader As DataGrid, _
                                          ByRef rsRecord As ADODB.Recordset) As Boolean
On Error GoTo ErrorHandler
Dim i As Integer
    '創建一個新的包含一個工作表的工作薄
    Set xlsApp = New Excel.Application
    xlsApp.Visible = False  '讓Excel處于不可見的狀態
    xlsApp.SheetsInNewWorkbook = 1
    Set xlsBook = xlsApp.Workbooks.Add
    Set xlsSheet = xlsBook.Worksheets(1)
    
    xlsApp.ActiveSheet.Rows(1).HorizontalAlignment = xlVAlignCenter   '垂直居中
    xlsApp.ActiveSheet.Rows(3).HorizontalAlignment = xlHAlignLeft     '水平居左
    xlsApp.ActiveSheet.Rows(4).HorizontalAlignment = xlHAlignLeft
    xlsApp.ActiveSheet.Rows(6).HorizontalAlignment = xlHAlignLeft
    xlsApp.ActiveSheet.Rows(8).HorizontalAlignment = xlVAlignCenter   '垂直居中
    xlsApp.ActiveSheet.Rows(9).HorizontalAlignment = xlVAlignCenter
    '设置一张工作表中每个单元格的值，可以使用Worksheet对象的Range属性或Cells属性。
    'With xlsApp.ActiveSheet 或
    With xlsSheet
        .Range("G1:G1").Value = "訂  料  表"
        .Range("B3:B3").Value = "銷貨單號："
        .Range("E3:E3").Value = "製品款號："
        .Range("H3:H3").Value = "訂單日期："
        .Range("K3:K3").Value = "製品名稱："
        .Range("B4:B4").Value = "製品數量："
        .Range("E4:E4").Value = "交貨日期："
        .Range("H4:H4").Value = "脩訂次數："
        .Range("K4:K4").Value = "脩訂日期："
        .Range("B6:B6").Value = "訂單編號："
        .Range("E6:E6").Value = "製  表  人："
       
        .Range("A8:A8").Value = "海關編號"
        .Range("B8:B8").Value = "物料名稱"
        .Range("D8:D8").Value = "物料損耗"
        .Range("E8:E8").Value = "物料用量":
        .Range("F8:F8").Value = "所需數量":
        .Range("G8:G8").Value = "單位":
        .Range("H8:H8").Value = "訂貨日期":
        .Range("I8:I8").Value = "採購單號":
        .Range("J8:J8").Value = "單價":
        .Range("K8:K8").Value = "總額":
        .Range("L8:L8").Value = "收貨日期":
        .Range("M8:M8").Value = "物料來源":
        .Range("N8:N8").Value = "備註":
        
        .Range("A9:A9").Value = "Mat'l Code"
        .Range("B9:B9").Value = "Material Description"
        .Range("D9:D9").Value = "Scrap"
        .Range("E9:E9").Value = "Yield"
        .Range("F9:F9").Value = "Quantity"
        .Range("G9:G9").Value = "Unit"
        .Range("H9:H9").Value = "Order Date"
        .Range("I9:I9").Value = "PO No"
        .Range("J9:J9").Value = "U/P"
        .Range("K9:K9").Value = "Amount"
        .Range("L9:L9").Value = "Rec'd Date"
        .Range("M9:M9").Value = "Source"
        .Range("N9:N9").Value = "Content"
        
        .Range("A8:A9").BorderAround xlEdgeLeft, xlThin
        .Range("D8:D9").BorderAround xlEdgeLeft, xlThin
        .Range("E8:E9").BorderAround xlEdgeLeft, xlThin
        .Range("F8:F9").BorderAround xlEdgeLeft, xlThin
        .Range("G8:G9").BorderAround xlEdgeLeft, xlThin
        .Range("H8:H9").BorderAround xlEdgeLeft, xlThin
        .Range("I8:I9").BorderAround xlEdgeLeft, xlThin
        .Range("J8:J9").BorderAround xlEdgeLeft, xlThin
        .Range("K8:K9").BorderAround xlEdgeLeft, xlThin
        .Range("L8:L9").BorderAround xlEdgeLeft, xlThin
        .Range("N8:N9").BorderAround xlEdgeLeft, xlThin
        .Range("M8:M9").BorderAround xlEdgeLeft, xlThin
       
        .Range("B8:C8").Merge   '閤並單元格
        .Range("B9:C9").Merge
        .Range("B8:C9").BorderAround xlEdgeLeft, xlThin   ' xlInsideHorizontal
    End With
    
    '顯示記錄信息
    With xlsSheet
        .Range("C3:C3").Value = dgOutPutHeader.Columns(0).Text '銷貨單號
        .Range("F3:F3").Value = dgOutPutHeader.Columns(1).Text '製品款號
        .Range("C6:C6").Value = dgOutPutHeader.Columns(2).Text '訂單編號
        .Range("L3:L3").Value = dgOutPutHeader.Columns(4).Text '製品名稱
        .Range("I3:I3").Value = dgOutPutHeader.Columns(5).Text '訂單日期
        .Range("C4:C4").Value = dgOutPutHeader.Columns(3).Text '製品數量
        .Range("F4:F4").Value = dgOutPutHeader.Columns(6).Text '交貨日期
        .Range("I4:I4").Value = dgOutPutHeader.Columns(7).Text '脩訂次數
        .Range("L4:L4").Value = dgOutPutHeader.Columns(8).Text '脩訂日期
        .Range("F6:F6").Value = CurrentUser                    '製 表 人
    End With
    With xlsSheet
    i = 10
    Do While Not rsRecord.EOF
        .Range("A" & i).Value = rsRecord("海關編號").Value                     '海關編號
        .Range("B" & i).Value = rsRecord("物料名稱").Value                     '物料名稱
        .Range("D" & i).Value = FormatPercent(rsRecord("物料損耗").Value, 3)   '物料損耗%
        .Range("E" & i).Value = Str(Round(rsRecord("物料用量").Value, 5))      '物料用量
        .Range("F" & i).Value = Str(Round(rsRecord("所需數量").Value))         '所需數量
        .Range("G" & i).Value = rsRecord("單位").Value                         '單位
        .Range("H" & i).Value = rsRecord("訂貨日期").Value                     '訂貨日期
        .Range("I" & i).Value = rsRecord("採購單號").Value                     '採購單號
        .Range("J" & i).Value = rsRecord("物料單價").Value                     '單價
        .Range("K" & i).Value = rsRecord("總計價格").Value                     '總額
        .Range("L" & i).Value = rsRecord("收貨日期").Value                     '收貨日期
        .Range("M" & i).Value = rsRecord("物料來源").Value                     '物料來源
        .Range("N" & i).Value = Trim$(rsRecord("備註").Value)                  '備註
        
        .Range("A" & i).Borders.LineStyle = xlEdgeLeft
        .Range("B" & i).Borders.LineStyle = xlEdgeLeft
        .Range("C" & i).Borders.LineStyle = xlEdgeLeft
        .Range("D" & i).Borders.LineStyle = xlEdgeLeft
        .Range("E" & i).Borders.LineStyle = xlEdgeLeft
        .Range("F" & i).Borders.LineStyle = xlEdgeLeft
        .Range("G" & i).Borders.LineStyle = xlEdgeLeft
        .Range("H" & i).Borders.LineStyle = xlEdgeLeft
        .Range("I" & i).Borders.LineStyle = xlEdgeLeft
        .Range("J" & i).Borders.LineStyle = xlEdgeLeft
        .Range("K" & i).Borders.LineStyle = xlEdgeLeft
        .Range("L" & i).Borders.LineStyle = xlEdgeLeft
        .Range("M" & i).Borders.LineStyle = xlEdgeLeft
        .Range("N" & i).Borders.LineStyle = xlEdgeLeft
        .Range("B" & i & ":" & "C" & i).Merge
        
        i = i + 1
        rsRecord.MoveNext
    Loop
    .Range("M" & i).Value = FormatDateTime(Now, vbLongDate) & "  " & FormatDateTime(Now, vbShortTime)
    '.Range("M" & i).Borders.LineStyle = xlEdgeLeft
    End With
     '设置单元格或区域的字体、边框，可以利用Range对象或Cells对象的Borders属性和Font属性：
    With xlsApp.ActiveSheet.Cells.Font '字体设置
        .Name = "Times New Roman"
        .Size = 9
    End With
    With xlsApp.ActiveSheet.Range("G1:H1")
        '边框设置
        '.Borders.Weight =xlThin    ' xlHairline ' xlThin 'xlThick 'xlMedium
        '.Borders.ColorIndex = 1
        '.Borders.LineStyle = xlEdgeLeft
        '字体设置
        .Font.Size = 14
        .Font.Bold = True
        '.Font.ColorIndex = 3
        '閤並單元格
        .Merge
    End With

    '预览及打印
    '生成所需要的工作表后，就可以对EXCEL发出预览、打印指令了。
    xlsApp.ActiveSheet.PageSetup.Orientation = xlLandscape     '设置打印方向  'xlPortrait
    xlsApp.ActiveSheet.PageSetup.PaperSize = xlPaperA4         '设置打印纸的打下
    xlsApp.Caption = "訂料表列印"                               '设置预览窗口的标题
    xlsApp.Visible = True                                      '显示当前工作表
    'xlsApp.ActiveSheet.PrintPreview                           '打印预览
    'xlsApp.ActiveSheet.PrintOut                               '打印输出
    '通过打印方向、打印纸张大小的设置，不断进行预览，直到满意为止，最终进行打印输出。
    '为了在退出应用程序后EXCEL不提示用户是否保存已修改的文件,需使用如下语句：
    'xlsApp.DisplayAlerts = False
    'xlsApp.Quit       '退出EXCEL
    'xlsApp.DisplayAlerts = True
    
    rsRecord.Close
    Set rsRecord = Nothing
    Set xlsSheet = Nothing
    Set xlsBook = Nothing
    Set xlsApp = Nothing
    OutPutTableRecordsToExcel = True
Exit Function
ErrorHandler:
    rsRecord.Close
    Set rsRecord = Nothing
    Set xlsSheet = Nothing
    Set xlsBook = Nothing
    Set xlsApp = Nothing
    OutPutTableRecordsToExcel = False
End Function