uweziegenhagen.de

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 Explicit
 
Function Contains(needle As String, haystack As String, separator As String) As Boolean
 
Dim rv As Boolean, lb As Long, ub As Long, i As Long, field() As String
 
field = Split(haystack, separator)
 
    lb = LBound(field)
    ub = UBound(field)
    For i = lb To ub
        If field(i) = needle Then
            rv = True
            Exit For
        End If
    Next i
    Contains = rv
End Function

Function InRange(needle As Variant, haystack As Range) As Boolean
Dim rv As Boolean, cell As Range
 
    For Each cell In haystack
        If cell = needle Then
            rv = True
            Exit For
        End If
    Next cell
    InRange = rv
 
End Function

Function GetUsername()
     Set objAD = CreateObject("ADSystemInfo")
     Set objUser = GetObject("LDAP://" & objAD.UserName)
     GetUsername = objUser.DisplayName
End Function

Function getOrder()
    auswahl = Range("Auswahl")
    bestellstring = "* " & GetUsername() & ": "
    Order = 0
 
    For i = 1 To UBound(auswahl)
        If (auswahl(i, 3)) > 0 Then
            If Order > 0 Then
                bestellstring = bestellstring & ", "
            End If
            bestellstring = bestellstring & auswahl(i, 3) & " x " & auswahl(i, 1)
            Order = 1
        End If
    Next i
 
    Debug.Print bestellstring
    getOrder = bestellstring
 
End Function

Sub Mail_small_Text_Outlook()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
 
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
 
    strbody = "Hier ist meine Bestellung:" & vbNewLine & vbNewLine & vbNewLine
 
 
    body = getOrder()
 
    If Len(Range("kommentar") > 0) Then
        body = body & vbNewLine & Range("kommentar")
    End If
 
 
 
    On Error Resume Next
    With OutMail
        .To = Range("receiver")
        .CC = ""
        .BCC = ""
        .Subject = Range("subject")
        .body = strbody & body
        .Display
    End With
    On Error GoTo 0
 
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Sub showUsername()
   MsgBox VBA.Environ("Username")
End Sub

Function GetUsername()
     Set objAD = CreateObject("ADSystemInfo")
     Set objUser = GetObject("LDAP://" & objAD.UserName)
     GetUsername = objUser.DisplayName
End Function

Sub Schaltfläche1_Klicken()
 
Dim c As Range
For Each c In Range("Workbooks")
    MsgBox (c.Value)
    Set kopiereWas = ThisWorkbook.Sheets("Template")
    Set kopiereWohin = Workbooks.Open(Application.ActiveWorkbook.Path + "\\" + c.Value)
    kopiereWas.Copy kopiereWohin.Sheets(1)
Next c
End Sub