VB6 中將數據導出到 Excel 提速之法(轉)

--------------------------------------------------------------------------------

Excel 是一個非常優秀的報表製作軟件，用VBA可以控制其生成優秀的報表，本文通過添加查詢語句的方法，即用Excel中的獲取外部數據的功能將數據很快地從一個查詢語句中捕獲到EXCEL中，比起往每個CELL裏寫數據的方法提高許多倍。
在程序中引用Microsoft Excel 9.0 Object Library，將下文加入到一個模塊中,窗體中調用如下ExporToExcel("select * from table")。則實現快速將數據導出到EXCEL中。

Public Function ExporToExcel(strOpen As String)
'*********************************************************
'* 名稱：ExporToExcel
'* 功能：導出數據到EXCEL
'* 用法：ExporToExcel(sql查詢字符串)
'*********************************************************
Dim Rs_Data As New ADODB.Recordset
Dim Irowcount As Integer
Dim Icolcount As Integer
   
    Dim xlApp As New Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim xlQuery As Excel.QueryTable
   
    With Rs_Data
        If .State = adStateOpen Then
            .Close
        End If
        .ActiveConnection = Cn
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        .Source = strOpen
        .Open
    End With
    With Rs_Data
        If .RecordCount < 1 Then
            MsgBox ("沒有記錄!")
            Exit Function
        End If
        '記錄總數
        Irowcount = .RecordCount
        '字段總數
        Icolcount = .Fields.Count
    End With
   
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Set xlBook = xlApp.Workbooks().Add
    Set xlSheet = xlBook.Worksheets("sheet1")
    xlApp.Visible = True
   
    '添加查詢語句，導入EXCEL數據
    Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))
   
    With xlQuery
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
    End With
   
    xlQuery.FieldNames = True '顯示字段名
    xlQuery.Refresh
   
    With xlSheet
        .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "黑體"
        '設標題爲黑體字
        .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
        '標題字體加粗
        .Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous
        '設表格邊框樣式
    End With
   
    With xlSheet.PageSetup
        .LeftHeader = "" & Chr(10) & "&""楷體_GB2312,常規""&10公司名稱："   ' & Gsmc
        .CenterHeader = "&""楷體_GB2312,常規""公司人員情況表&""宋體,常規""" & Chr(10) & "&""楷體_GB2312,常規""&10日 期："
        .RightHeader = "" & Chr(10) & "&""楷體_GB2312,常規""&10單位："
        .LeftFooter = "&""楷體_GB2312,常規""&10製表人："
        .CenterFooter = "&""楷體_GB2312,常規""&10製表日期："
        .RightFooter = "&""楷體_GB2312,常規""&10第&P頁 共&N頁"
    End With
   
    xlApp.Application.Visible = True
    Set xlApp = Nothing  '"交還控制給Excel
    Set xlBook = Nothing
    Set xlSheet = Nothing
End Function

注:：在程序中引用'Microsoft Excel 9.0 Object Library'和ADO對象,機器必裝Excel 2000
本程序在Windows 98/2000,VB 6 下運行通過。