Article ID: 113899
Article Last Modified on 2/23/2007
Sub Form_Load ()
Label1.AutoSize = True
Label1.Caption = "Ready"
Label1.Refresh
End Sub
Sub Command1_Click ()
Dim i As Integer ' Loop counters
Dim j As Integer
Dim rCount As Long ' Record count
Dim xl As object ' OLE automation object
Dim db As database ' Database object
Dim Sn As Snapshot ' Snapshot to hold records
Screen.MousePointer = 11 ' Change mousepointer
Label1.Caption = "Creating Excel Object"
Label1.Refresh
Set xl = CreateObject("Excel.Sheet.5")
' Open the database:
Label1.Caption = "Opening the database"
Label1.Refresh
Set db = OpenDatabase("C:\VB\BIBLIO.MDB")
' Set up Field names as Column names:
Label1.Caption = "Creating SnapShot"
Label1.Refresh
Set Sn = db.CreateSnapshot("Titles")
If Sn.RecordCount > 0 Then
' Place the fields across the top of the spreadsheet:
Label1.Caption = "Adding field names to Spreadsheet"
Label1.Refresh
For i = 0 To Sn.Fields.Count - 1
xl.cells(1, i + 1).value = Sn(i).Name
Next
' Update record count, and return to the first record:
Sn.MoveLast
Sn.MoveFirst
rCount = Sn.RecordCount
' Loop through each record:
i = 0
Do While Not Sn.EOF
Label1.Caption = "Record:" & Str(i + 1) & " of" & _
Str(rCount)
Label1.Refresh
For j = 0 To Sn.Fields.Count - 1
' Add each field to the spreadsheet:
If Sn(j).Type < 11 Then
xl.cells(i + 2, j + 1).value = Sn(j)
Else
' Separate out Memo and LongBinary fields.
' They aren't guaranteed to be text.
xl.cells(i + 2, j + 1).value = "Memo or Binary Data"
End If
Next j
Sn.MoveNext
i = i + 1
Loop
' Save the spreadsheet:
Label1.Caption = "Saving Spreadsheet"
Label1.Refresh
xl.SaveAs "C:\TMP\TITLES.XLS"
' Quit the excel object - removes Excel from memory!
Label1.Caption = "Quitting Excel"
Label1.Refresh
xl.Application.Quit
Else
' No records.
End If
' Clean up:
Label1.Caption = "Cleaning up"
Label1.Refresh
Set xl = Nothing ' Remove object variable.
Set Sn = Nothing ' Remove snapshot object.
Set db = Nothing ' Remove database object.
Screen.MousePointer = 0 ' Restore mouse pointer.
Label1.Caption = "Ready"
Label1.Refresh
End Sub
Keywords: kbhowto kbprogramming KB113899