Převod tabulky na sešit Excelu

Postup:
  • Založte nový projekt, v něm bude formulář Form1.
  • Na Form1 připojte tlačítko Command1 a jmenovku Label1.
  • Na událost Form1_Load zapište následující kód:
    
    Sub Form_Load ()
    
    Label1.AutoSize = True
    Label1.Caption = "Ready"
    Label1.Refresh
    
    End Sub
  • 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
    
  • Spusťte aplikaci a po klepnutí na tlačítko Command1 se převede tabulka Titles z databáze Biblio.mdb na sešit Titles.Xls.

Zpět

Autor: The Bozena