form_toexcel.frm

运用VB和SQL Server实现

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Begin VB.Form Form_ToExcel 
   Caption         =   "Form1"
   ClientHeight    =   4770
   ClientLeft      =   60
   ClientTop       =   435
   ClientWidth     =   7215
   LinkTopic       =   "Form1"
   ScaleHeight     =   4770
   ScaleWidth      =   7215
   StartUpPosition =   3  '窗口缺省
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   4920
      Top             =   600
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
      DialogTitle     =   "Select Database File"
      FileName        =   ".mdb"
      Filter          =   "Access Files (*.mdb)"
      FilterIndex     =   1
   End
   Begin VB.Frame Frame1 
      Caption         =   "Frame1"
      Height          =   4455
      Left            =   120
      TabIndex        =   0
      Top             =   240
      Width           =   6975
      Begin VB.CommandButton cmdexit 
         Caption         =   "退出"
         Height          =   495
         Left            =   5760
         TabIndex        =   6
         Top             =   3840
         Width           =   1095
      End
      Begin VB.CommandButton cmdCopyToHtml 
         Caption         =   "将数据导出为Html格式"
         Height          =   495
         Left            =   3720
         TabIndex        =   5
         Top             =   3840
         Width           =   2055
      End
      Begin VB.CommandButton cmdCopyToExcel 
         Caption         =   "将数据导出为Excel表格"
         Height          =   495
         Left            =   1680
         TabIndex        =   4
         Top             =   3840
         Width           =   2055
      End
      Begin VB.CommandButton Command1 
         Caption         =   "重新选择数据库"
         Height          =   495
         Left            =   120
         TabIndex        =   3
         Top             =   3840
         Width           =   1575
      End
      Begin VB.PictureBox Picture1 
         Height          =   495
         Left            =   120
         ScaleHeight     =   435
         ScaleWidth      =   6675
         TabIndex        =   2
         Top             =   3120
         Width           =   6735
      End
      Begin VB.ListBox List1 
         Height          =   2760
         Left            =   120
         TabIndex        =   1
         Top             =   240
         Width           =   6735
      End
   End
End
Attribute VB_Name = "Form_ToExcel"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim adoConn    As adodb.Connection
Dim RS         As adodb.Recordset
Dim strCaption As String
Dim SN         As String
Dim I          As Single
Dim Recs       As Integer
Dim Counter    As Integer
Dim BarString  As String
Dim MdbFile    As String
Dim Junk       As String
Dim strAdoConn As String

Private Type ExlCell
    Row As Long
    Col As Long
End Type

'"将数据导出为Excel表格"按钮单击事件响应代码
Private Sub cmdCopyToExcel_Click()
    On Error GoTo Err_List1_Click
    
    Screen.MousePointer = vbHourglass
    Junk = List1.Text
    Set RS = New adodb.Recordset
    RS.Open Junk, adoConn, adOpenStatic, adLockReadOnly, adCmdTable
    ToExcel RS, App.Path & "\wk.xls"
    
Exit_List1_Click:
    Screen.MousePointer = vbDefault
    On Error GoTo 0
    Exit Sub
    
Err_List1_Click:
    Select Case Err
        Case 0
            Resume Next
        Case Else
            MsgBox "错误: " & Err.Number & vbNewLine & Err.Description, vbInformation, "错误"
            Resume Exit_List1_Click
    End Select
End Sub

'"将数据导出为Html文件"按钮单击事件响应代码
Private Sub cmdCopyToHtml_Click()
    '用户指定Html文件名
    CommonDialog1.InitDir = App.Path
    CommonDialog1.Filter = "Html文件(*.htm)|*.htm"
    CommonDialog1.ShowSave
    If CommonDialog1.FileName = "" Then Exit Sub
    
    Junk = List1.Text
    Set RS = New adodb.Recordset
    RS.Open Junk, adoConn, adOpenStatic, adLockReadOnly, adCmdTable
    
    ToHTML RS, "将ADO数据导出到Html文件实例", CommonDialog1.FileName
End Sub

Private Sub cmdexit_Click()
Unload Me
End Sub

Private Sub Form_Load()
    LoadForm
Exit_Form_Load:
    On Error GoTo 0
    Exit Sub
Err_Form_Load:
    Select Case Err
        Case 0
            Resume Next
        Case Else
            MsgBox "错误: " & Err.Number & vbNewLine & Err.Description, vbInformation, "错误"
            Resume Exit_Form_Load
    End Select
    
End Sub
Private Sub Form_Unload(Cancel As Integer)
    
    On Error GoTo Err_Form_Unload
    If Not (adoConn Is Nothing) Then
        adoConn.Close
        Set adoConn = Nothing
    End If
    
Exit_Form_Unload:
    On Error GoTo 0
    Exit Sub
    
Err_Form_Unload:
    Select Case Err
        Case 0, 91, 3704
            Resume Next
        Case Else
            MsgBox "错误: " & Err.Number & vbNewLine & Err.Description, vbInformation, "错误"
            Resume Exit_Form_Unload
    End Select

End Sub

'"重新选择数据库"按钮单击事件响应代码
Private Sub Command1_Click()
            
    On Error GoTo Err_Command1_Click
    UpdateProgress Picture1, 0
    '隐藏Frame1
    Frame1.Visible = False
    '清空List1
    List1.Clear
    '从新运行填充List1的程序
    LoadForm

Exit_Command1_Click:
    On Error GoTo 0
    Exit Sub
    
Err_Command1_Click:
    Select Case Err
        Case 0
            Resume Next
        Case Else
            Frame1.Visible = True
            MsgBox "错误: " & Err.Number & vbNewLine & Err.Description, vbInformation, "错误"
            Resume Exit_Command1_Click
    End Select

End Sub

'更新进度条的子程序
Sub UpdateProgress(PB As Control, ByVal Percent)
    '本实例使用一个PictureBox控件模拟滚动条效果
    '百分比
    Dim Num As String
    
    On Error GoTo Err_UpdateProgress
    
    If Not PB.AutoRedraw Then  '没有自动重绘输出
        PB.AutoRedraw = -1
    End If
    '清空PictureBox
    PB.Cls
    PB.ScaleWidth = 100
    'xor画刷模式
    PB.DrawMode = 10
    Num = BarString & Format$(Percent, "###") + "%"
    PB.CurrentX = 50 - PB.TextWidth(Num) / 2
    PB.CurrentY = (PB.ScaleHeight - PB.TextHeight(Num)) / 2
    '显示百分比
    PB.Print Num
    PB.Line (0, 0)-(Percent, PB.ScaleHeight), , BF
    '刷新
    PB.Refresh

Exit_UpdateProgress:

    On Error GoTo 0
    Exit Sub
    
Err_UpdateProgress:

    Select Case Err
        Case 0
            Resume Next
        Case Else
            MsgBox "Error: " & Err.Number & vbNewLine & Err.Description, vbInformation, "错误"
            Resume Exit_UpdateProgress
    End Select

End Sub
'复制Recordset中数据到Excel表格Worksheet
Private Sub CopyRecords(RST As adodb.Recordset, WS As Worksheet, StartingCell As ExlCell)
    
    Dim SomeArray() As Variant
    Dim Row         As Long
    Dim Col         As Long
    Dim Fd          As adodb.Field
    
    On Error GoTo Err_CopyRecords
    
    '检测Recordset中是否没有数据
    If RST.EOF And RST.BOF Then Exit Sub
    RST.MoveLast
    ReDim SomeArray(RST.RecordCount + 1, RST.Fields.Count)
    
    '拷贝表头到数组
    Col = 0
    For Each Fd In RST.Fields
        SomeArray(0, Col) = Fd.name
        Col = Col + 1
    Next
    
    '拷贝Recordset到数组
    RST.MoveFirst
    Recs = RST.RecordCount
    Counter = 0
    For Row = 1 To RST.RecordCount - 1
        Counter = Counter + 1
        If Counter <= Recs Then I = (Counter / Recs) * 100
        UpdateProgress Picture1, I
        For Col = 0 To RST.Fields.Count - 1
            SomeArray(Row, Col) = RST.Fields(Col).Value
            If IsNull(SomeArray(Row, Col)) Then _
            SomeArray(Row, Col) = ""
        Next
        RST.MoveNext