Private Sub ImportAccess_Click()
Dim Cela_Cesta As String, Cesta As Variant, Cesta2 As String, F As String
Dim Radek As Long
Dim Database As Object
Dim Rs As Object
Dim Odkaz As Worksheet
Dim Sloupec As Integer
Dim Tabulka As String
Dim Pripona As String, Znak As String, I As Integer, Poloha As Integer
Dim Delka As Integer
'Spuštění dialogu pro výběr souboru a ověření výběru
Cesta = Application _
.GetOpenFilename("Databáze Access (*.mdb), *.mdb,(*.accdb), *.accdb ")
If Cesta = False Then
MsgBox "Nic neotevřeno.", vbInformation, "Informace uživateli"
Exit Sub
End If
If Worksheets("Ovladac").Cells(2, 2).Value = "" Then
MsgBox "Není vyplněn název tabulky pro import", vbCritical, "Chyba!"
Exit Sub
End If
Tabulka = Trim(Worksheets("Ovladac").Cells(2, 2).Value)
Pripona = Worksheets("Ovladac").Cells(4, 2).Value
Worksheets("Access").Cells.Delete
'Definování umístění složky a jejího názvu
Delka = Len(Cesta)
For I = Delka To 1 Step -1
Znak = Mid(Cesta, I, 1)
If Znak = "\" Then
Poloha = I
Exit For
End If
Next I
Cela_Cesta = Left(Cesta, Poloha) & Pripona
Cesta2 = Left(Cesta, Poloha)
Application.ScreenUpdating = False
F = Dir(Cela_Cesta)
Radek = 2
'Definování odkazu pro výběr dat
Set Odkaz = Worksheets("Access")
'Vytvoření objektové proměnné spustí Access na pozadí
Dim app As New Access.Application
'Otevření zdrojové databáze a vytvoření její objektové proměnné
On Error GoTo Chyba2
app.OpenCurrentDatabase Cesta2 & F
Set Database = app.CurrentDb
' Vytvoření recordsetu
On Error GoTo Chyba
Set Rs = Database.OpenRecordset(Tabulka)
'Zápis názvu polí
For Sloupec = 0 To Rs.Fields.Count - 1
Worksheets("Access").Range("A1").Offset(0, Sloupec).Value = _
Rs.Fields(Sloupec).Name
Next
' Zkopírování vybraných záznamů do sešitu
Odkaz.Cells(Radek, 1).CopyFromRecordset Rs
Rs.Close
'Přičítání řádků - určení prvního neposaného řádku
Radek = Cells.CurrentRegion.Rows.Count + 1
'Uzavření aktuální databáze
app.CloseCurrentDatabase
'Procházení dalších souborů
Do
F = Dir
If F <> "" Then
'Otevření zdrojové databáze a vytvoření její objektové proměnné
On Error GoTo Chyba2
app.OpenCurrentDatabase Cesta2 & F
Set Database = app.CurrentDb
' Vytvoření recordsetu
On Error GoTo Chyba
Set Rs = Database.OpenRecordset(Tabulka)
'Zkopírování vybraných záznamů do sešitu
Odkaz.Cells(Radek, 1).CopyFromRecordset Rs
Rs.Close
'Přičítání řádků - určení prvního nepopsaného řádku
Radek = Cells.CurrentRegion.Rows.Count + 1
If Radek >= 1048576 Then MsgBox "Sešit je již zaplněn.", vbCritical, "Chyba"
'Uzavření aktuální databáze
app.CloseCurrentDatabase
End If
Loop While F <> ""
' Ukončení Accessu
app.Quit
Worksheets("Access").Activate
Application.ScreenUpdating = True
Exit Sub
Chyba:
MsgBox "Databáze: " & Cesta2 & F & " neobsahuje importovanou tabulku.", vbCritical, "Chyba!"
Exit Sub
Chyba2:
MsgBox "Zřejmě byla vybrána databáze se špatným formátem.", vbCritical, "Chyba!"
'
'Application.ScreenUpdating = True
'
End Sub