📄 form_toexcel.frm
字号:
Next
'将数组填充到Excel WorkSheet
'Range应该和数组拥有同样的行数和列数
WS.Range(WS.Cells(StartingCell.Row, StartingCell.Col), _
WS.Cells(StartingCell.Row + RST.RecordCount + 1, _
StartingCell.Col + RST.Fields.Count)).Value = SomeArray
Exit_CopyRecords:
On Error GoTo 0
Exit Sub
Err_CopyRecords:
Select Case Err
Case 0
Resume Next
Case Else
MsgBox "错误: " & Err.Number & vbNewLine & Err.Description, vbInformation, "错误"
Resume Exit_CopyRecords
End Select
End Sub
'将Recordset数据转换到Excel中
Private Sub ToExcel(SN As adodb.Recordset, strCaption As String)
Dim oExcel As Object
'OLE自动化对象
Dim objExlSht As Object
Dim stCell As ExlCell
On Error GoTo Err_ToExcel
DoEvents
On Error Resume Next
Set oExcel = GetObject(, "Excel.Application")
'若Excel没有启动
If Err = 429 Then
Err = 0
Set oExcel = CreateObject("Excel.Application")
'无法创建Excel对象
If Err = 429 Then
MsgBox Err & ": " & Error, vbExclamation + vbOKOnly
Exit Sub
End If
End If
oExcel.Workbooks.Add
oExcel.Worksheets("sheet1").name = strCaption
Set objExlSht = oExcel.ActiveWorkbook.Sheets(1)
stCell.Row = 1
stCell.Col = 1
'填充Excel表格
CopyRecords SN, objExlSht, stCell
'将控制权交给用户
oExcel.Visible = True
oExcel.Interactive = True
'测试对象是否活动并释放对象
If Not (objExlSht Is Nothing) Then
Set objExlSht = Nothing
End If
If Not (oExcel Is Nothing) Then
Set oExcel = Nothing
End If
If Not (SN Is Nothing) Then
Set SN = Nothing
End If
UpdateProgress Picture1, 100
Exit_ToExcel:
On Error GoTo 0
Exit Sub
Err_ToExcel:
Select Case Err
Case 0
Resume Next
Case Else
MsgBox "错误: " & Err.Number & vbNewLine & Err.Description, vbInformation, "错误"
Resume Exit_ToExcel
End Select
End Sub
'将Recordset中的数据以Html格式写入文件
Private Sub ToHTML(SN As adodb.Recordset, strCaption As String, FileName As String)
SN.MoveLast
SN.MoveFirst
Dim lwidth As Long, I, j
Open FileName For Output As #1
'Html的文件头和页面信息
Print #1, "<HTML>"
Print #1, "<HEAD>"
Print #1, "<meta http-equiv=""Content-Type"" content=""text/html; charset=gb2312"">"
Print #1, "<meta http-equiv=""Content-Language"" content="" zh - cn "" > "
Print #1, "<meta name=""GENERATOR"" content = "" Visual Basic Access to Html "" > "
'Html标题
Print #1, "<TITLE>" & strCaption & "</TITLE>"
Print #1, "<STYLE>"
Print #1, "<!--"
Print #1, "BODY,td {"
Print #1, "font-family:""宋体,Arial Black"";"
Print #1, "font-size:9pt;"
Print #1, "line-height:16px;"
Print #1, "}"
Print #1, "-->"
Print #1, "</STYLE>"
Print #1, "</Head>"
'数据开始
Print #1, "<Body>"
Print #1, "<Table border="" 1"">"
'自动根据字段数量确定列宽
If SN.Fields.Count > 1 Then
lwidth = 100 / SN.Fields.Count - 1
Else
lwidth = 100 / SN.Fields.Count
End If
'保证列宽大小
If lwidth < 10 Then
lwidth = 10
End If
'若要设置固定列宽，将下面一行的注释符号去除即可
'lwidth = 1000
'先输出表头
Print #1, "<TR>"
For I = 0 To SN.Fields.Count - 1
Print #1, "<td width=""" & str(lwidth) & """ bgcolor = ""#B1CACF"" > "
Print #1, SN.Fields(I).name
Print #1, "</td>"
Next I
Print #1, "</TR>"
'开始输出数据
Do Until SN.EOF
'实现黑白交替效果
If j Mod 2 = 1 Then
Print #1, "<TR bgcolor = ""#EFEFEF"">"
Else
Print #1, "<TR bgcolor = ""#FFFFFF"">"
End If
'输出每个字段数据
For I = 0 To SN.Fields.Count - 1
Print #1, "<td width=""" & str(lwidth) & """> "
Print #1, SN.Fields(I).Value
Print #1, "</td>"
Next I
Print #1, "</TR>"
SN.MoveNext
UpdateProgress Picture1, j / SN.RecordCount * 100
j = j + 1
Loop
'Html文件结束
Print #1, "</Table>"
Print #1, "</Body>"
Print #1, "</HTML>"
Close #1
End Sub
Private Sub LoadForm()
On Error GoTo Err_LoadForm
Picture1.Visible = True
Frame1.Caption = "单击需要导出到Excel表格的数据表"
GoTo TECHNIQUE_2
'对于ODBC数据源使用Technique 2
TECHNIQUE_2:
strAdoConn = BuildAdoConnection("")
'设置数据库连接属性
Set adoConn = New adodb.Connection
adoConn.ConnectionString = strAdoConn
OPENTHEDATABASE:
adoConn.Open
'获取数据库中所有表格的名字
Set RS = adoConn.OpenSchema(adSchemaTables)
Do Until RS.EOF
' 确定获取的表不是系统表或者视图
If RS.Fields("TABLE_TYPE") = "TABLE" Then
If LCase$(Left$(RS.Fields("TABLE_NAME"), 4)) = "usys" Then
'系统表,排除
DoEvents
Else
List1.AddItem RS.Fields("TABLE_NAME")
End If
End If
RS.MoveNext
Loop
'关闭对象
If Not (RS Is Nothing) Then
RS.Close
Set RS = Nothing
End If
Frame1.Visible = True
Exit_LoadForm:
On Error GoTo 0
Exit Sub
Err_LoadForm:
Select Case Err
Case 0, 91
Resume Next
Case 32755, -2147467259, 3704
Frame1.Visible = True
Picture1.Visible = False
Frame1.Caption = "没有选择数据库"
Resume Exit_LoadForm
Case Else
MsgBox "错误: " & Err.Number & vbNewLine & Err.Description, vbInformation, "错误"
Resume Exit_LoadForm
End Select
End Sub
Private Function BuildAdoConnection(ByVal ConnectionString As String) As String
'显示数据链接属性对话框(ADO DB Designer)
Dim dlViewConnection As MSDASC.DataLinks
On Error GoTo Err_BuildAdoConnection
Set adoConn = New adodb.Connection
If Not (Trim$(ConnectionString) = "") Then
Set adoConn = New adodb.Connection
adoConn.ConnectionString = ConnectionString
Set dlViewConnection = New MSDASC.DataLinks
dlViewConnection.hWnd = Me.hWnd
If dlViewConnection.PromptEdit(adoConn) Then
BuildAdoConnection = adoConn.ConnectionString
Else
BuildAdoConnection = ConnectionString
End If
Set dlViewConnection = Nothing
Set adoConn = Nothing
Else
Set dlViewConnection = New MSDASC.DataLinks
dlViewConnection.hWnd = Me.hWnd
Set adoConn = dlViewConnection.PromptNew
BuildAdoConnection = adoConn.ConnectionString
Set dlViewConnection = Nothing
Set adoConn = Nothing
End If
Exit_BuildAdoConnection:
On Error Resume Next
If Not (adoConn Is Nothing) Then
Set adoConn = Nothing
End If
If Not (dlViewConnection Is Nothing) Then
Set dlViewConnection = Nothing
End If
On Error GoTo 0
Exit Function
Err_BuildAdoConnection:
Select Case Err
Case 0
Resume Next
Case -2147217805
adoConn.ConnectionString = ""
Resume
Case 91
Resume Exit_BuildAdoConnection
Case Else
MsgBox "错误: " & Err.Number & vbNewLine & Err.Description, vbInformation, "错误"
Resume Exit_BuildAdoConnection
End Select
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -