[b]
Option Explicit
Dim oconn As New ADODB.Connection
Dim strconn As String
Dim ors As ADODB.Recordset
Dim strsql As String
Dim fso As New Scripting.FileSystemObject
Dim strdb As String
Dim ocat As New ADOX.Catalog
Dim otbl As ADOX.Table
Dim ofld As ADOX.Column
Dim savePath As String
Private Sub cmbTbl_Click()
Set otbl = ocat.Tables(cmbTbl.Text)
For Each ofld In otbl.Columns
LVW.ListItems.Add , , ofld.Name
Next
End Sub
Private Sub cmdExit_Click()
End
End Sub
Private Sub cmdStart1_Click()
Dim pg As Long
Dim pgCount As Long
Dim rec As Long
Dim recCount As Long
Dim xsl As New Excel.Application
Dim wbk As Excel.Workbook
Dim wsh As Excel.Worksheet
Dim lastPage As Boolean
Dim i As Integer
Dim fldCount as Integer
Set wbk = xsl.Workbooks.Add
xsl.Visible = True
strsql = "Select * from [" & cmbTbl.Text & "];"
Set ors = oconn.Execute(strsql)
recCount = 0
Do While Not ors.EOF
If ors.EOF Then Exit Do
recCount = recCount + 1
ors.MoveNext
Loop
pgCount = Fix(recCount / 65536) + 1
If pgCount > 3 Then
For i = 1 To pgCount - 3
wbk.Worksheets.Add after:=wbk.Worksheets(Worksheets.Count)
Next
End If
ors.MoveFirst
For pg = 1 To pgCount
If pg > pgCount Then Exit For
Set wsh = wbk.Worksheets(pg)
wsh.Activate
For fldCount = 0 to ors.Fields.Count - 1
wsh.Cells(1,fldCount+1) = ors.Fields(fldCount).Name
Next
wsh.Range("A2").[red]CopyFromRecordset ors[/red]
Set wsh = Nothing
Next
ors.Close
Set ors = Nothing
wbk.Close True, "C:\Test.xls"
Set wbk = Nothing
xsl.Quit
Set xsl = Nothing
MsgBox "Done." & vbCrLf & "Records inserted: " & recCount, vbExclamation, "Finished processing..."
End Sub
Private Sub Form_Load()
On Error GoTo err_handle
CDL.CancelError = True
CDL.Filter = "Access Files (*.mdb)|*.mdb"
CDL.ShowOpen
strdb = CDL.FileName
CDL.Filter = "Excel Files (*.xls)|*.xls"
CDL.DialogTitle = "Select name for the file..."
CDL.ShowSave
savePath = CDL.FileName
strconn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strdb & ";Persist Security Info=False"
oconn.Open strconn
Set ocat.ActiveConnection = oconn
For Each otbl In ocat.Tables
If InStr(1, otbl.Name, "msys", vbTextCompare) = 0 Then
cmbTbl.AddItem otbl.Name
End If
Next
err_handle:
If Err.Number <> 0 Then
If Err.Number = cdlCancel Then
Err.Clear
MsgBox "Program will terminate.", vbOKOnly, "Exit program"
Unload Me
'Resume
Else
MsgBox Err.Description
Resume
End If
End If
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If oconn.State = 1 Then
oconn.Close
Set oconn = Nothing
End If
Set otbl = Nothing
Set ocat = Nothing
End Sub
[/b]
