2018-01-20, 11:52
Ich muss gelegentlich eine Access-Datenbank umziehen lassen, die auf diverse verlinkte Datenbanken zugreift (um das 2 GB Maximum zu umgehen). Da die Verlinkungen absolut sind und nicht relativ, muss man jede Verlinkung nach dem Umzug manuell anpassen, was bei mehr als 100 Tabellen mühselig und fehlerträchtig ist. Basierend auf Code von Stackexchange/Stackoverflow habe ich daher ein paar Hilfsfunktionen gebaut, die den Umzug deutlich vereinfachen. Die Annahme
Der Code besteht aus mehreren Funktionen:
getDatabaseName()
extrahiert den Namen der Datenbank aus dem Pfad
GetFolder()
fragt beim Nutzer den Pfad ab, in dem die neuen Datenbank-Dateien liegen.
verlinkeTabellenNeu()
biegt die Links auf die Datenbankdateien um
Hinweis: Es empfiehlt sich nach Abschluss ein Auslesen aller Verlinkungen und Abgleichen z.B. in Excel, um auf Nummer sicher gehen zu können, dass alle Verlinkungen erfolgreich waren. Zum Auslesen der Verlinkungen kann man den Code unten am Ende des Artikels nutzen.
Option Compare Database
Function getDatabaseName(currentPath As String)
' Uwe Ziegenhagen, 2017-11-03
' Extrahiert den Namen der Datenbank aus dem Pfad,
' wertet dazu die Position des letzten "\" aus:
' von innen nach außen:
' kehre String um
' finde den letzten Backslash
' nimm den substring bis zum letzten Backslash
' reverse diesen Substring wieder
getDatabaseName = StrReverse(Left(StrReverse(currentPath), InStr(StrReverse(currentPath), "\") - 1))
End Function
Function GetFolder() As String
' https://stackoverflow.com/questions/26392482/vba-excel-to-prompt-user-response-to-select-folder-and-return-the-path-as-string
' based on https://www.ozgrid.com/forum/forum/help-forums/excel-general/126180-getfolder-function?t=182343
' requires references to Microsoft Office xx.0 Object library
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
'.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Sub verlinkeTabellenNeu()
' Uwe Ziegenhagen, 2017-11-03
' Ruft vom User einen Pfad ab und verlinkt alle Tabellen mit diesem Pfad neu
' based on code from https://stackoverflow.com/questions/4928134/changing-linked-table-location-programatically
ordnerNeu = GetFolder()
Dim dbs As DAO.Database
Dim tdf As DAO.TableDef
Set dbs = CurrentDb()
With dbs
For Each tdf In .TableDefs
'Is the table a linked table?
If tdf.Attributes And dbAttachedODBC Or tdf.Attributes And dbAttachedTable Then
With tdf
oldPath = .Properties("Connect").Value
.Connect = ";DATABASE=" & ordnerNeu & "\" & getDatabaseName(.Properties("Connect").Value)
.RefreshLink
Debug.Print oldPath & "@@@" & .Properties("Connect").Value
End With
End If
Next tdf
End With
End Sub |
Option Compare Database
Function getDatabaseName(currentPath As String)
' Uwe Ziegenhagen, 2017-11-03
' Extrahiert den Namen der Datenbank aus dem Pfad,
' wertet dazu die Position des letzten "\" aus:
' von innen nach außen:
' kehre String um
' finde den letzten Backslash
' nimm den substring bis zum letzten Backslash
' reverse diesen Substring wieder
getDatabaseName = StrReverse(Left(StrReverse(currentPath), InStr(StrReverse(currentPath), "\") - 1))
End Function
Function GetFolder() As String
' https://stackoverflow.com/questions/26392482/vba-excel-to-prompt-user-response-to-select-folder-and-return-the-path-as-string
' based on https://www.ozgrid.com/forum/forum/help-forums/excel-general/126180-getfolder-function?t=182343
' requires references to Microsoft Office xx.0 Object library
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
'.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Sub verlinkeTabellenNeu()
' Uwe Ziegenhagen, 2017-11-03
' Ruft vom User einen Pfad ab und verlinkt alle Tabellen mit diesem Pfad neu
' based on code from https://stackoverflow.com/questions/4928134/changing-linked-table-location-programatically
ordnerNeu = GetFolder()
Dim dbs As DAO.Database
Dim tdf As DAO.TableDef
Set dbs = CurrentDb()
With dbs
For Each tdf In .TableDefs
'Is the table a linked table?
If tdf.Attributes And dbAttachedODBC Or tdf.Attributes And dbAttachedTable Then
With tdf
oldPath = .Properties("Connect").Value
.Connect = ";DATABASE=" & ordnerNeu & "\" & getDatabaseName(.Properties("Connect").Value)
.RefreshLink
Debug.Print oldPath & "@@@" & .Properties("Connect").Value
End With
End If
Next tdf
End With
End Sub
Code zum Auslesen der Verlinkungen
Sub LinkedTableConnection()
' http://p2p.wrox.com/access-vba/37117-finding-linked-tables.html
Dim dbs As DAO.Database
Dim tdf As DAO.TableDef
Set dbs = CurrentDb()
With dbs
For Each tdf In .TableDefs
'Is the table a linked table?
If tdf.Attributes And dbAttachedODBC Or tdf.Attributes And dbAttachedTable Then
With tdf
' Connect property contains path of link
' Debug.Print "Connect Property of " & .Name & " is: " & .Properties("Connect").Value
Debug.Print "kompletter Pfad: " & tdf.Connect
' Debug.Print "Name der Datenbank: " & getDatabaseName(.Properties("Connect").Value)
End With
End If
Next tdf
End With
End Sub |
Sub LinkedTableConnection()
' http://p2p.wrox.com/access-vba/37117-finding-linked-tables.html
Dim dbs As DAO.Database
Dim tdf As DAO.TableDef
Set dbs = CurrentDb()
With dbs
For Each tdf In .TableDefs
'Is the table a linked table?
If tdf.Attributes And dbAttachedODBC Or tdf.Attributes And dbAttachedTable Then
With tdf
' Connect property contains path of link
' Debug.Print "Connect Property of " & .Name & " is: " & .Properties("Connect").Value
Debug.Print "kompletter Pfad: " & tdf.Connect
' Debug.Print "Name der Datenbank: " & getDatabaseName(.Properties("Connect").Value)
End With
End If
Next tdf
End With
End Sub
Uwe Ziegenhagen likes LaTeX and Python, sometimes even combined.
Do you like my content and would like to thank me for it? Consider making a small donation to my local fablab, the Dingfabrik Köln. Details on how to donate can be found here Spenden für die Dingfabrik.
More Posts - Website
2017-12-10, 19:32
Ich muss mich gelegentlich mit MS Access beschäftigen und habe eine Möglichkeit gesucht, Tabellenstrukturen zu exportieren. Basierend auf Code von Allen Browne (http://allenbrowne.com/func-06.html) habe ich um seine TableInfo()
Funktion eine Exportfunktion geschrieben.

Option Compare Database
' based on http://allenbrowne.com/func-06.html
' modified for the export of the information by Uwe Ziegenhagen
Sub exportTableInformation()
On Error GoTo TableInfoErr
' Purpose: Display the field names, types, sizes and descriptions for a table.
' Argument: Name of a table in the current database.
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim fld As DAO.Field
Set db = CurrentDb()
' ask user for path of the output file
' https://support.office.com/de-de/article/InputBox-Funktion-Eingabefeld-17821927-28b7-4350-b7f1-4786575314d9
Dim Message, Title, Default, MyValue
Message = "File will be overwritten..." ' Set prompt.
Title = "Enter file of output file" ' Set title.
Default = "c:\somefile.csv" ' Set default.
' Display message, title, and default value.
outputfilePath = InputBox(Message, Title, Default)
n = FreeFile()
Open outputfilePath For Output As #n
Print #n, "SOURCE;TABLE;FIELDNAME;FIELDTYPE;SIZE;DESCRIPTION"
Set db = CurrentDb()
Debug.Print
For Each tdf In db.TableDefs
' ignore system and temporary tables
If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*") Then
For Each fld In tdf.Fields
Debug.Print db.Name & ";" & tdf.Name & ";" & fld.Name & ";" & FieldTypeName(fld) & ";" & fld.Size & ";" & GetDescrip(fld)
Print #n, db.Name & ";" & tdf.Name & ";" & fld.Name & ";" & FieldTypeName(fld) & ";" & fld.Size & ";" & GetDescrip(fld)
Next
End If
Next
Set tdf = Nothing
Set db = Nothing
Close #n
TableInfoExit:
Set db = Nothing
Exit Sub
TableInfoErr:
Select Case Err
Case 3265& 'Table name invalid
MsgBox strTableName & " table doesn't exist"
Case Else
Debug.Print "TableInfo() Error " & Err & ": " & Error
End Select
Resume TableInfoExit
End Sub
Function GetDescrip(obj As Object) As String
' http://allenbrowne.com/func-06.html
On Error Resume Next
GetDescrip = obj.Properties("Description")
End Function
Function FieldTypeName(fld As DAO.Field) As String
'http://allenbrowne.com/func-06.html
'Purpose: Converts the numeric results of DAO Field.Type to text.
Dim strReturn As String 'Name to return
Select Case CLng(fld.Type) 'fld.Type is Integer, but constants are Long.
Case dbBoolean: strReturn = "Yes/No" ' 1
Case dbByte: strReturn = "Byte" ' 2
Case dbInteger: strReturn = "Integer" ' 3
Case dbLong ' 4
If (fld.Attributes And dbAutoIncrField) = 0& Then
strReturn = "Long Integer"
Else
strReturn = "AutoNumber"
End If
Case dbCurrency: strReturn = "Currency" ' 5
Case dbSingle: strReturn = "Single" ' 6
Case dbDouble: strReturn = "Double" ' 7
Case dbDate: strReturn = "Date/Time" ' 8
Case dbBinary: strReturn = "Binary" ' 9 (no interface)
Case dbText '10
If (fld.Attributes And dbFixedField) = 0& Then
strReturn = "Text"
Else
strReturn = "Text (fixed width)" '(no interface)
End If
Case dbLongBinary: strReturn = "OLE Object" '11
Case dbMemo '12
If (fld.Attributes And dbHyperlinkField) = 0& Then
strReturn = "Memo"
Else
strReturn = "Hyperlink"
End If
Case dbGUID: strReturn = "GUID" '15
'Attached tables only: cannot create these in JET.
Case dbBigInt: strReturn = "Big Integer" '16
Case dbVarBinary: strReturn = "VarBinary" '17
Case dbChar: strReturn = "Char" '18
Case dbNumeric: strReturn = "Numeric" '19
Case dbDecimal: strReturn = "Decimal" '20
Case dbFloat: strReturn = "Float" '21
Case dbTime: strReturn = "Time" '22
Case dbTimeStamp: strReturn = "Time Stamp" '23
'Constants for complex types don't work prior to Access 2007 and later.
Case 101&: strReturn = "Attachment" 'dbAttachment
Case 102&: strReturn = "Complex Byte" 'dbComplexByte
Case 103&: strReturn = "Complex Integer" 'dbComplexInteger
Case 104&: strReturn = "Complex Long" 'dbComplexLong
Case 105&: strReturn = "Complex Single" 'dbComplexSingle
Case 106&: strReturn = "Complex Double" 'dbComplexDouble
Case 107&: strReturn = "Complex GUID" 'dbComplexGUID
Case 108&: strReturn = "Complex Decimal" 'dbComplexDecimal
Case 109&: strReturn = "Complex Text" 'dbComplexText
Case Else: strReturn = "Field type " & fld.Type & " unknown"
End Select
FieldTypeName = strReturn
End Function |
Option Compare Database
' based on http://allenbrowne.com/func-06.html
' modified for the export of the information by Uwe Ziegenhagen
Sub exportTableInformation()
On Error GoTo TableInfoErr
' Purpose: Display the field names, types, sizes and descriptions for a table.
' Argument: Name of a table in the current database.
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim fld As DAO.Field
Set db = CurrentDb()
' ask user for path of the output file
' https://support.office.com/de-de/article/InputBox-Funktion-Eingabefeld-17821927-28b7-4350-b7f1-4786575314d9
Dim Message, Title, Default, MyValue
Message = "File will be overwritten..." ' Set prompt.
Title = "Enter file of output file" ' Set title.
Default = "c:\somefile.csv" ' Set default.
' Display message, title, and default value.
outputfilePath = InputBox(Message, Title, Default)
n = FreeFile()
Open outputfilePath For Output As #n
Print #n, "SOURCE;TABLE;FIELDNAME;FIELDTYPE;SIZE;DESCRIPTION"
Set db = CurrentDb()
Debug.Print
For Each tdf In db.TableDefs
' ignore system and temporary tables
If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*") Then
For Each fld In tdf.Fields
Debug.Print db.Name & ";" & tdf.Name & ";" & fld.Name & ";" & FieldTypeName(fld) & ";" & fld.Size & ";" & GetDescrip(fld)
Print #n, db.Name & ";" & tdf.Name & ";" & fld.Name & ";" & FieldTypeName(fld) & ";" & fld.Size & ";" & GetDescrip(fld)
Next
End If
Next
Set tdf = Nothing
Set db = Nothing
Close #n
TableInfoExit:
Set db = Nothing
Exit Sub
TableInfoErr:
Select Case Err
Case 3265& 'Table name invalid
MsgBox strTableName & " table doesn't exist"
Case Else
Debug.Print "TableInfo() Error " & Err & ": " & Error
End Select
Resume TableInfoExit
End Sub
Function GetDescrip(obj As Object) As String
' http://allenbrowne.com/func-06.html
On Error Resume Next
GetDescrip = obj.Properties("Description")
End Function
Function FieldTypeName(fld As DAO.Field) As String
'http://allenbrowne.com/func-06.html
'Purpose: Converts the numeric results of DAO Field.Type to text.
Dim strReturn As String 'Name to return
Select Case CLng(fld.Type) 'fld.Type is Integer, but constants are Long.
Case dbBoolean: strReturn = "Yes/No" ' 1
Case dbByte: strReturn = "Byte" ' 2
Case dbInteger: strReturn = "Integer" ' 3
Case dbLong ' 4
If (fld.Attributes And dbAutoIncrField) = 0& Then
strReturn = "Long Integer"
Else
strReturn = "AutoNumber"
End If
Case dbCurrency: strReturn = "Currency" ' 5
Case dbSingle: strReturn = "Single" ' 6
Case dbDouble: strReturn = "Double" ' 7
Case dbDate: strReturn = "Date/Time" ' 8
Case dbBinary: strReturn = "Binary" ' 9 (no interface)
Case dbText '10
If (fld.Attributes And dbFixedField) = 0& Then
strReturn = "Text"
Else
strReturn = "Text (fixed width)" '(no interface)
End If
Case dbLongBinary: strReturn = "OLE Object" '11
Case dbMemo '12
If (fld.Attributes And dbHyperlinkField) = 0& Then
strReturn = "Memo"
Else
strReturn = "Hyperlink"
End If
Case dbGUID: strReturn = "GUID" '15
'Attached tables only: cannot create these in JET.
Case dbBigInt: strReturn = "Big Integer" '16
Case dbVarBinary: strReturn = "VarBinary" '17
Case dbChar: strReturn = "Char" '18
Case dbNumeric: strReturn = "Numeric" '19
Case dbDecimal: strReturn = "Decimal" '20
Case dbFloat: strReturn = "Float" '21
Case dbTime: strReturn = "Time" '22
Case dbTimeStamp: strReturn = "Time Stamp" '23
'Constants for complex types don't work prior to Access 2007 and later.
Case 101&: strReturn = "Attachment" 'dbAttachment
Case 102&: strReturn = "Complex Byte" 'dbComplexByte
Case 103&: strReturn = "Complex Integer" 'dbComplexInteger
Case 104&: strReturn = "Complex Long" 'dbComplexLong
Case 105&: strReturn = "Complex Single" 'dbComplexSingle
Case 106&: strReturn = "Complex Double" 'dbComplexDouble
Case 107&: strReturn = "Complex GUID" 'dbComplexGUID
Case 108&: strReturn = "Complex Decimal" 'dbComplexDecimal
Case 109&: strReturn = "Complex Text" 'dbComplexText
Case Else: strReturn = "Field type " & fld.Type & " unknown"
End Select
FieldTypeName = strReturn
End Function
Uwe Ziegenhagen likes LaTeX and Python, sometimes even combined.
Do you like my content and would like to thank me for it? Consider making a small donation to my local fablab, the Dingfabrik Köln. Details on how to donate can be found here Spenden für die Dingfabrik.
More Posts - Website