Dialog Vybrat tabulku - VBA

[Kurimak]

Věděl by někdo, jak do makra v Excelu dostat dialogové okno Vybrat tabulku z Accessu - jak napsat pro jeho vyvolání kód.
Přes nahrávání maker se mi to nedaří.

[guest]

Dvě věci. Jestli se nepletu, tento dialog se objevuje v rámci importu dat z Accessu do Excelu. Je tedy součástí nějakého průvodce, kterému předchází dialog pro výběr souboru. Jak chcete skočit do nějakého kroku procesu z ničeho nic? Kromě toho jsem přesvědčen o tom, že dialog pro napojení nepotřebujete. Nebo skutečně musíte vybírat z dostupných tabulek?

[Kurimak]

Ano je to dialog v importu dat z Accessu do Excelu. Potřebuji vybírat různé tabulky. Zatím jsem to vyřešil tak, že název tabulky, kterou chci importovat, píšu do buňky na listu. Možnost určit název tabulky v průběhu makra by vše usnadnila.
Pokud by to bylo složité, spokojím se s tím, co už mám.

Kód makra uvádím dole:

Kód: Vybrat vše

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

[guest]

Jukněte na Google... Získat seznam tabulek, ať už pod ADO, DAO, OLEDB není přeci problém. Výsledek hoďte do ComboBoxu a je to.

https://social.msdn.microsoft.com/Forum ... m=exceldev

[Kurimak]

Děkuji. Trochu jsem to upravil. Bylo třeba ještě přes Tools References zatrhnout knihovnu: Microsoft DAO Library 3.6.
Teď už si s tím dál nějak poradím:

Sub ListTables()
Dim DB As Database
Dim T As TableDef
Set DB = OpenDatabase(GetFileName())
For Each T In DB.TableDefs
MsgBox T.Name
Next
End Sub
Function GetFileName()

Dim sFname As Variant
Dim i As Long
Dim sname As String
sname = Application _
.GetOpenFilename("Databáze Access (*.mdb), *.mdb,(*.accdb), *.accdb ")
GetFileName = sname

End Function