'*********************************************************
'* 名稱(chēng)：ExporToExcel
'* 功能：導(dǎo)出數(shù)據(jù)到EXCEL
'* 用法：ExporToExcel(sql查詢(xún)字符串)
'*********************************************************
Dim Rs_Data As New ADODB.Recordset
Dim Irowcount As Integer
Dim Icolcount As Integer
Dim cn As New ADODB.Connection
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 = "provider=msdasql;DRIVER=Microsoft Visual FoxPro Driver;UID=;Deleted=yes;Null=no;Collate=Machine;BackgroundFetch=no;Exclusive=No;SourceType=DBF;SourceDB=D:\DBF;"
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.Source = strOpen
.Open
End With
With Rs_Data
If .RecordCount < 1 Then
MsgBox ("沒(méi)有記錄!")
Exit Function
End If
'記錄總數(shù)
Irowcount = .RecordCount
'字段總數(shù)
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
'添加查詢(xún)語(yǔ)句，導(dǎo)入EXCEL數(shù)據(jù)
Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))
xlQuery.FieldNames = True '顯示字段名
xlQuery.Refresh
xlApp.Application.Visible = True
Set xlApp = Nothing '"交還控制給Excel
Set xlBook = Nothing
Set xlSheet = Nothing
End Function
-------------------------------------------------------------------------------
'*************************************************************************
'**
'** VB將數(shù)據(jù)導(dǎo)出到EXCEL,沒(méi)有安裝EXCEL的一樣也可以導(dǎo)出.
'**
'** 調(diào)用方式: s_Export2Excel(Ado.Recordset) 或 s_Export2Excel(Rds.RecordSet)
'** 支持 Rds 與 Ado 的記錄導(dǎo)出
'**
'*************************************************************************
'導(dǎo)出ADO記錄集到EXCEL
Public Function f_Export2Excel(ByVal sRecordSet As ADODB.Recordset, ByVal sExcelFileName$ _
, Optional ByVal sTableName$, Optional ByVal sOverExist As Boolean = False) As Boolean
'On Error GoTo lbErr
Dim iConcStr, iSql$, iFdlist$, iDb As ADODB.Connection
Dim iI&, iFdType$, j, TmpField, FileName
Dim iRe As Boolean
'檢查文件名
If Dir(sExcelFileName) <> "" Then
If sOverExist Then
Kill sExcelFileName
Else
iRe = False
GoTo lbExit
End If
End If
'生成創(chuàng)建表的SQL語(yǔ)句
With sRecordSet
For iI = 0 To .Fields.Count - 1
iFdType = f_FieldType(.Fields(iI).Type)
Select Case iFdType
Case "char", "varchar", "nchar", "nvarchar", "varbinary"
If .Fields(iI).DefinedSize > 255 Then
iSql = iSql & ",[" & .Fields(iI).Name & "] text"
Else
iSql = iSql & ",[" & .Fields(iI).Name & "] " & iFdType & _
"(" & .Fields(iI).DefinedSize & ")"
End If
Case "image"
Case Else
iSql = iSql & ",[" & .Fields(iI).Name & "] " & iFdType
End Select
Next
If sTableName = "" Then sTableName = .Source
iSql = "create table [" & sTableName & "](" & Mid(iSql, 2) & ")"
End With
'數(shù)據(jù)庫(kù)連接字符串
iConcStr = "DRIVER={Microsoft Excel Driver (*.xls)};DSN='';FIRSTROWHASNAMES=1;READONLY=FALSE;" & _
"CREATE_DB=""" & sExcelFileName & """;DBQ=" & sExcelFileName
'創(chuàng)建Excel文件,并創(chuàng)建表
Set iDb = New ADODB.Connection
iDb.Open iConcStr
iDb.Execute iSql
'插入數(shù)據(jù)
With sRecordSet
.MoveFirst
While .EOF = False
iSql = ""
iFdlist = ""
For iI = 0 To .Fields.Count - 1
iFdType = f_FieldType(.Fields(iI).Type)
If iFdType <> "image" And IsNull(.Fields(iI).Value) = False Then
iFdlist = iFdlist & ",[" & .Fields(iI).Name & "]"
Select Case iFdType
Case "char", "varchar", "nchar", "nvarchar", "text"
iSql = iSql & ",'" & .Fields(iI).Value & "'"
Case "datetime"
iSql = iSql & ",#" & .Fields(iI).Value & "#"
Case "image"
Case Else
iSql = iSql & "," & .Fields(iI).Value
End Select
End If
Next
iSql = "insert into [" & sTableName & "](" & _
Mid(iFdlist, 2) & ") values(" & Mid(iSql, 2) & ")"
iDb.Execute iSql
.MoveNext
Wend
End With
'處理完畢,關(guān)閉數(shù)據(jù)庫(kù)
iDb.Close
Set iDb = Nothing
MsgBox "已經(jīng)將數(shù)據(jù)保存到 [ " & sExcelFileName & " ]", 64
iRe = True
GoTo lbExit
lbErr:
MsgBox "發(fā)生錯(cuò)誤:" & Err.Description & vbCrLf & _
"錯(cuò)誤代碼:" & Err.Number, 64, "錯(cuò)誤"
lbExit:
f_Export2Excel = iRe
End Function
'得到所有數(shù)據(jù)類(lèi)型,有些數(shù)據(jù)類(lèi)型EXCEL不支持,已經(jīng)替換掉
Public Function f_FieldType$(ByVal sType&)
Dim iRe$
Select Case sType
Case 2, 3, 20
iRe = "int"
Case 5
iRe = "float"
Case 6
iRe = "money"
Case 131
iRe = "numeric"
Case 4
iRe = "real"
Case 128
iRe = "binary"
Case 204
iRe = "varbinary"
Case 11
iRe = "bit"
Case 129, 130
iRe = "char"
Case 17, 72, 131, 200, 202, 204
iRe = "varchar"
Case 201, 203
iRe = "text"
Case 7, 135
iRe = "datetime"
Case 205
iRe = "image"
Case 128
iRe = "timestamp"
End Select
f_FieldType = iRe
End Function
'調(diào)用測(cè)試
Sub test()
Dim iRe As ADODB.Recordset
Dim iConc As String
iConc = "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False" & _
";Data Source=F:\My Documents\客戶(hù)資料.mdb"
Set iRe = New ADODB.Recordset
iRe.Open "維護(hù)員", iConc, adOpenKeyset, adLockOptimistic
f_Export2Excel iRe, "c:\b.xls", , True
iRe.Close
End Sub
Top
Option Explicit
'Private xlApp As Excel.Application
'Private xlBook As Excel.Workbook
'Private xlSheet As Excel.Worksheet
Private xlApp As Object
Private xlBook As Object
Private xlSheet As Object
Private cellValue As String
Public strError As String
Public ExportOK As Boolean
Private Sub Class_Initialize()
ExportOK = False
On Error GoTo errHandle:
' Set xlApp = CreateObject("Excel.Applaction")
Set xlApp = New Excel.Application
xlApp.Visible = False
On Error GoTo errHandle:
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
If Val(xlApp.Application.Version) >= 8 Then
Set xlSheet = xlApp.ActiveSheet
Else
Set xlSheet = xlApp
End If
Exit Sub
errHandle:
Err.Raise 100001, , "建立Excel對(duì)象時(shí)發(fā)生錯(cuò)誤:" & Err.Description & vbCr & _
"請(qǐng)確保您正確了安裝了Excel軟件!"
End Sub
Public Property Get TextMatrix(Row As Integer, Col As Integer) As Variant
TextMatrix = xlSheet.Cells(Row, Col)
End Property
Public Property Let TextMatrix(Row As Integer, Col As Integer, Value As Variant)
xlSheet.Cells(Row, Col) = Value
End Property
'合并單元格
Public Sub MergeCell(bRow As Integer, bCol As Integer, eRow As Integer, eCol As Integer)
xlSheet.Range(GetExcelCell(bRow, bCol) & ":" & GetExcelCell(eRow, eCol)).Select
With xlApp.Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = True
End With
End Sub
'打印預(yù)覽
Public Function PrintPreview() As Boolean
On Error GoTo errHandle:
xlApp.Visible = True
xlBook.PrintPreview True
Exit Function
errHandle:
If Err.Number = 1004 Then
MsgBox "尚未安裝打印機(jī),不能預(yù)覽!", vbOKOnly + vbCritical, "錯(cuò)誤"
End If
End Function
'導(dǎo)出
Public Function ExportExcel() As Boolean
xlApp.Visible = True
End Function
'畫(huà)線(xiàn)
Public Sub DrawLine(bRow As Integer, bCol As Integer, eRow As Integer, eCol As Integer)
On Error Resume Next
xlSheet.Range(GetExcelCell(bRow, bCol) & ":" & GetExcelCell(eRow, eCol)).Select
xlApp.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
xlApp.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With xlApp.Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With xlApp.Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With xlApp.Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With xlApp.Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With xlApp.Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With xlApp.Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End Sub
'導(dǎo)出記錄集到Excel
Public Sub RstExport(Rst As ADODB.Recordset, bRow As Integer, bCol As Integer, GridHead() As String)
Dim i As Integer, j As Integer
For i = bCol To UBound(GridHead) + bCol
With Me
.TextMatrix(bRow, i) = GridHead(i - bCol)
End With
Next
i = 1 + bRow
Do While Not Rst.EOF
For j = 1 To Rst.Fields.Count
If Rst.Fields(j - 1).Type = adChar Or Rst.Fields(j - 1).Type = adVarChar Then
xlSheet.Range(GetExcelCell(i, j) & ":" & GetExcelCell(i, j)).Select
xlApp.Selection.NumberFormatLocal = "@" '已文本方式格式化
End If
Me.TextMatrix(i, j) = checkNull(Rst.Fields(j - 1).Value)
Next
i = i + 1
Rst.MoveNext
Loop
End Sub
'或者指定行,列號(hào)的Excel編碼
Private Function GetExcelCell(Row As Integer, Col As Integer) As String
Dim nTmp1 As Integer
Dim nTmp2 As Integer
Dim sTmp As String
If Col <= 26 Then
sTmp = Chr(Asc("A") + Col - 1)
Else
nTmp1 = Col \ 26
If nTmp1 > 26 Then
Err.Raise 100000, , "列數(shù)過(guò)大,發(fā)生錯(cuò)誤"
Exit Function
Else
sTmp = Chr(Asc("A") + nTmp1 - 1)
nTmp1 = Col Mod 26
sTmp = sTmp & Chr(Asc("A") + nTmp1 - 1)
End If
End If
GetExcelCell = sTmp & Row
End Function
'將Null返回為空串
Private Function checkNull(s As Variant) As String
checkNull = IIf(IsNull(s), "", s)
End Function
Private Sub Class_Terminate()
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
End Sub
聯(lián)系客服
