uweziegenhagen.de

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

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

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