Option Explicit

Private Declare Function SetWindowPos Lib "user32" ( _
    ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
    ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
    ByVal cy As Long, ByVal wFlags As Long) As Long

Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const FLAGS As Long = SWP_NOMOVE Or SWP_NOSIZE
Private Const HWND_TOPMOST = -1

Private Sub Form_Load()
  SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS
End Sub

Private Sub Command1_Click()
  Dim sDBFileName As String

  sDBFileName = Durchsuchen
  If sDBFileName = "" Then Exit Sub

  Me.Caption = "Analyse: " & sDBFileName
  DatenbankAnalysieren (sDBFileName)
End Sub

Private Sub DatenbankAnalysieren(p As String)
  On Error GoTo ErrorHandle

  Dim sDB As String

  Dim i As Integer
  Dim j As Integer

  Dim db As Database
  Dim rs As Recordset
  Dim td As TableDef
  Dim fd As Field

  Dim sMDBPath As String
  Dim sTables As String

  Set db = Workspaces(0).OpenDatabase(p)
  sMDBPath = "Datenbank: " & _
         Mid(db.Name, InStrRev(db.Name, "\") + 1) & vbNewLine & _
         db.Name & vbNewLine & vbNewLine

  For i = 0 To db.TableDefs.Count - 1
    Set td = db.TableDefs(i)

    If Left(td.Name, 4) <> "MSys" Then

      sDB = sDB & vbNewLine & Space(3) & "TABELLE: "
      sDB = sDB & td.Name & vbNewLine & vbNewLine

      sTables = sTables & vbNewLine & td.Name

      For j = 0 To td.Fields.Count - 1
        Set fd = td.Fields(j)
        sDB = sDB & Space(6) & "SPALTE: "
        sDB = sDB & fd.Name & vbCrLf

        sDB = sDB & Space(9) & "Datentyp: "
        Select Case fd.Type
          Case dbBoolean
            sDB = sDB & "Boolean" & vbCrLf
          Case dbByte
             sDB = sDB & "Byte" & vbCrLf
          Case dbInteger
            sDB = sDB & "Integer" & vbCrLf
          Case dbLong
            sDB = sDB & "Long" & vbCrLf
          Case dbCurrency
            sDB = sDB & "Currency" & vbCrLf
          Case dbSingle
            sDB = sDB & "Single" & vbCrLf
          Case dbDouble
            sDB = sDB & "Double" & vbCrLf
          Case dbDate
            sDB = sDB & "Date" & vbCrLf
          Case dbText
            sDB = sDB & "Text" & vbCrLf
          Case dbLongBinary
            sDB = sDB & "LongBinary" & vbCrLf
          Case dbMemo
            sDB = sDB & "Memo" & vbCrLf
          Case Else
            sDB = sDB & "(unknown) & vbCrLf"
        End Select

        If fd.Type <> dbLongBinary And fd.Type <> dbMemo Then
          sDB = sDB & Space(9) & "Größe in Bytes: "
          sDB = sDB & fd.Size & vbCrLf
        End If
       Next j
     End If
   Next i

   db.Close

   sTables = "Alle TABELLEN:" & vbNewLine & sTables
   txtDB.Text = sMDBPath & sTables & vbNewLine & vbNewLine & sDB

   Me.SetFocus
   Exit Sub

ErrorHandle:
  If Err.Number = cdlCancel Then
    Err.Clear
  Else
    MsgBox "Fehler: " & Err.Number & vbCrLf & _
            Err.Description, vbOKOnly, Me.Caption
  End If
End Sub

Private Function Durchsuchen() As String
  On Error GoTo ErrorHandle

  With CommonDialog1
    .CancelError = True
    .DialogTitle = "Wählen Sie eine Datenbank"
    .Filter = "Access-datenbanken(*.mdb)|*.mdb"
    .ShowOpen
    Durchsuchen = .FileName
  End With

  Exit Function

ErrorHandle:
  If Err.Number = cdlCancel Then
    Err.Clear
  Else
    MsgBox "Fehler: " & Err.Number & vbCrLf & _
            Err.Description, vbOKOnly, Me.Caption
  End If
End Function

Private Sub txtDB_OleDragDrop(Data As DataObject, _
        Effect As Long, Button As Integer, _
        Shift As Integer, x As Single, y As Single)
  Dim f

  If Not Data.GetFormat(vbCFFiles) Then Exit Sub

  For Each f In Data.Files
    If LCase(Right(f, 3)) = "mdb" Then
      DatenbankAnalysieren CStr(f)
      Exit Sub
    End If
  Next
End Sub