copytoexcel.frm

好的控件.绝对好用.献给爱VB的朋友 做数据连接ADO 数据库

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Begin VB.Form CopyToExcel 
   Caption         =   "   Copy Database Tables to Excel"
   ClientHeight    =   6795
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   5400
   BeginProperty Font 
      Name            =   "Arial"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "CopyToExcel.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   6795
   ScaleWidth      =   5400
   StartUpPosition =   2  'CenterScreen
   Begin VB.Frame Frame1 
      Caption         =   "  Click on a Table to Copy to Excel  "
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   -1  'True
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00C00000&
      Height          =   6615
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Visible         =   0   'False
      Width           =   5175
      Begin VB.CommandButton Command1 
         Caption         =   "Reselect Database"
         Height          =   495
         Left            =   1800
         TabIndex        =   3
         Top             =   6000
         Width           =   1575
      End
      Begin VB.PictureBox Picture1 
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   255
         Left            =   120
         ScaleHeight     =   195
         ScaleWidth      =   4875
         TabIndex        =   2
         Top             =   5640
         Width           =   4935
      End
      Begin VB.ListBox List1 
         BeginProperty Font 
            Name            =   "Tahoma"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   5325
         Left            =   120
         TabIndex        =   1
         Top             =   240
         Width           =   4935
      End
   End
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   0
      Top             =   -15
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
      CancelError     =   -1  'True
      DialogTitle     =   "Select Database File"
      FileName        =   "*.mdb"
      Filter          =   "Access Files (*.mdb)"
      FilterIndex     =   1
      FontName        =   "Arial"
      InitDir         =   "."
   End
End
Attribute VB_Name = "CopyToExcel"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

' original code/project posted on PSC by Ian Mitchell
'
' (Ian -- Great job on the part that does all the HARD work with Excel!)
'
' Modified Aug 7, 2001, 7 PM by Brian Battles WS1O  [e-mail]
'
' I decided I wanted to make this more flexible by using ADO instead of DAO;
' that way we can use this on databases other than MS Access...
'
'  just be sure to set the necessary references:
'    Microsoft ADO 2.x library
'    OLE DB Service Component 1.0 Type Library
'  etc

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
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 "Error: " & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, App.Title & "  -  Advisory"
            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 "Error: " & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, App.Title & "  -  Advisory"
            Resume Exit_Form_Unload
    End Select

End Sub
Private Sub Command1_Click()
            
    On Error GoTo Err_Command1_Click
    
    ' clear the progress bar
    UpdateProgress Picture1, 0
    ' hide the frame
    Frame1.Visible = False
    ' clear the listbox
    List1.Clear
    ' rerun the routine that initially populates the listbox
    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 "Error: " & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, App.Title & "  -  Advisory"
            Resume Exit_Command1_Click
    End Select

End Sub
Private Sub List1_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 "Error: " & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, App.Title & "  -  Advisory"
            Resume Exit_List1_Click
    End Select
        
End Sub
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
    
    ' check if recordset is not empty
    If RST.EOF And RST.BOF Then Exit Sub
    RST.MoveLast
    ReDim SomeArray(RST.RecordCount + 1, RST.Fields.Count)
    ' copy column headers to array
    Col = 0
    For Each Fd In RST.Fields
        SomeArray(0, Col) = Fd.Name
        Col = Col + 1
    Next
    ' copy recordset to some array
    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 _