VB6 从数据库中导出数据到Excel(项目中用到的)

最新推荐文章于 2022-02-07 15:41:08 发布

永远爱好写程序

最新推荐文章于 2022-02-07 15:41:08 发布

阅读量7k

点赞数 2

分类专栏： VB VB_Excel

本文链接：https://blog.csdn.net/limlimlim/article/details/8350148

版权

VB 同时被 2 个专栏收录

17 篇文章 0 订阅

订阅专栏

VB_Excel

2 篇文章 0 订阅

订阅专栏

Public Enum ExportType
    DiffrentData = 0
    FirstData = 1
    SecondData = 2
End Enum

Public Function BuildSheet(ByRef xlSheet As Excel.Worksheet, ByVal strSQL As String, ByVal oType As ExportType)
    Dim Rs_Data                 As ADODB.Recordset
    Dim xlQuery                 As Excel.QueryTable
    Dim Irowcount               As Long
    Dim Icolcount               As Long

    On Error GoTo ErrHandle

    Select Case oType
        Case ExportType.DiffrentData
            xlSheet.Name = "sheet1"
        Case ExportType.FirstData
            xlSheet.Name = "sheet2"
        Case ExportType.SecondData
            xlSheet.Name = "sheet3"
    End Select

    Set Rs_Data = New ADODB.Recordset
    With Rs_Data
        If .State = adStateOpen Then
            .Close
        End If
        .ActiveConnection = gConnection
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        .Source = strSQL
        .Open
    End With

    With Rs_Data
        If .RecordCount < 1 Then
            MsgBox ("没有记录!")
            Exit Function
        End If

        '记录总数
        Irowcount = .RecordCount
        '字段总数
        Icolcount = .Fields.Count
    End With

    '添加查询语句，导入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)).Interior.Color = vbYellow
        '设标题为黑体字
        .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

    Rs_Data.Close
    Set Rs_Data = Nothing

    On Error GoTo 0
    Exit Function
ErrHandle:
    Call gErrList("frmDoubleKeyRpt.BuildSheet", Err.Description, Err.Number, True)

End Function

Public Function ExporToExcelBySQL(strSQL As String, strFirstDataSQL As String, strSecondDataSQL As String)
    '*********************************************************
    '* 名称：ExporToExcel
    '* 功能：导出数据到EXCEL
    '* 用法：ExporToExcel(sql查询字符串)
    '*********************************************************
    Dim Irowcount As Long
    Dim Icolcount As Long
    Dim xlApp As New Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim xlQuery As Excel.QueryTable
    Dim strDate As String
    Dim StrFileName As String
    Dim i As Integer

    On Error GoTo ErrHandle

    strDate = Format(Date, "YYYYMMDD")
    'strFileName = App.Path & "\录入清单_Test_" & strDate & ".xls"

    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Set xlBook = xlApp.Workbooks().Add
    '添加两个Sheet，保证有三个Sheet
    Set xlSheet = xlBook.Sheets.Add
    Set xlSheet = xlBook.Sheets.Add

    '添加Sheet数据1
    Set xlSheet = xlBook.Worksheets(1)
    Call BuildSheet(xlSheet, strSQL, ExportType.DiffrentData)
    '添加Sheet数据2
    Set xlSheet = xlBook.Worksheets(2)
    Call BuildSheet(xlSheet, strFirstDataSQL, ExportType.FirstData)
    '添加Sheet数据3
    Set xlSheet = xlBook.Worksheets(3)
    Call BuildSheet(xlSheet, strSecondDataSQL, ExportType.SecondData)

    xlApp.Application.Visible = True
    xlBook.Saved = True
    xlBook.SaveCopyAs StrFileName
    Set xlApp = Nothing '"交还控制给Excel
    Set xlBook = Nothing
    Set xlSheet = Nothing

    MsgBox "导出到Excel完毕!"

    On Error GoTo 0
    Exit Function
ErrHandle:
    Call gErrList("frmDoubleKeyRpt.ExporToExcelBySQL", Err.Description, Err.Number, True)

End Function