Na událost Click tlačítka Command1 napište následující kód:
Sub Command1_Click ()
Dim i As Integer ' Počítadlo cyklů
Dim j As Integer
Dim rCount As Long ' Počítadlo záznamů
Dim xl As object ' OLE objekt
Dim db As database ' Database objekt
Dim Sn As Snapshot ' Snapshot pro věty
Screen.MousePointer = 11 ' Myš jako hodiny
Label1.Caption = "Tvorba objektu MS Excel ..."
Label1.Refresh
Set xl = CreateObject("Excel.Sheet.5")
' Otevření databáze:
Label1.Caption = "Otevírání databáze ..."
Label1.Refresh
Set db = OpenDatabase("C:\VB\BIBLIO.MDB")
' Nastavení polí databáze jako sloupců:
Label1.Caption = "Tvorba SnapShotu ..."
Label1.Refresh
Set Sn = db.CreateSnapshot("Titles")
If Sn.RecordCount > 0 Then
' Přenos názvu polí do nadpisu sloupců:
Label1.Caption = "Přenos názvu polí do tabulky ..."
Label1.Refresh
For i = 0 To Sn.Fields.Count - 1
xl.cells(1, i + 1).value = Sn(i).Name
Next
' Načtení počtu vět a skok na první záznam:
Sn.MoveLast
Sn.MoveFirst
rCount = Sn.RecordCount
' Cyklus pro každou větu:
i = 0
Do While Not Sn.EOF
Label1.Caption = "Věta: " & Str(i + 1) & " z " & Str(rCount)
Label1.Refresh
For j = 0 To Sn.Fields.Count - 1
' Připojení každého pole do tabulky:
If Sn(j).Type < 11 Then
xl.cells(i + 2, j + 1).value = Sn(j)
Else
' Vyseparování Memo a Long Binary polí.
'Není zaručeno, že jsou textové .
xl.cells(i + 2, j + 1).value = "Memo nebo Binární data"
End If
Next j
Sn.MoveNext
i = i + 1
Loop
' Uložení tabulky:
Label1.Caption = "Ukládání tabulky ..."
Label1.Refresh
xl.SaveAs "C:\TMP\TITLES.XLS"
' Ukončení práce s objektem Excelu.
Label1.Caption = "Ukončování ..."
Label1.Refresh
xl.Application.Quit
Else
' Nejsou žádné záznamy.
End If
' Uvolnění paměti:
Label1.Caption = "Uvolňování paměti ..."
Label1.Refresh
Set xl = Nothing
Set Sn = Nothing
Set db = Nothing
Screen.MousePointer = 0 ' Původní ukazatel myši.
Label1.Caption = "Ready"
Label1.Refresh
End Sub