|
Sub GetMDBDescription()
Dim sPath As String Dim db As Database Dim tdf As TableDef Dim qdf As QueryDef Dim fld As Field Dim iRow As Integer Dim sTemp As String On Error Goto ErrorHandler 'get the path of the mdb from the user sPath = InputBox("Please enter the MDB's path") 'clear the sheets contents. Also removes all formatting Cells.Delete iRow = 1 'exit the sub if the user does not enter a path If sPath <> vbNullString Then 'test the path to make sure that it actually points to a file sPathTest = Dir(sPath, vbNormal) Set db = OpenDatabase(sPath) 'format the sheet now that we have received a valid MDB to open Columns("A:A").VerticalAlignment = xlTop Columns("A:A").ColumnWidth = 36 Columns("B:B").VerticalAlignment = xlTop Columns("B:B").WrapText = True Columns("B:B").ColumnWidth = 26 Columns("D:D").VerticalAlignment = xlTop Columns("D:D").WrapText = True Columns("D:D").ColumnWidth = 43 ActiveSheet.Cells(iRow, 1) = "Tables" ActiveSheet.Cells(iRow, 1).Font.Bold = True ActiveSheet.Cells(iRow, 1).Font.Size = 12 iRow = iRow + 1 'scroll thru the tabledefs For Each tdf In db.TableDefs 'skip Access System tables - they all start with MSys If Left(tdf.Name, 4) <> "MSys" Then ActiveSheet.Cells(iRow, 1) = tdf.Name ActiveSheet.Cells(iRow, 1).Font.Bold = True ActiveSheet.Cells(iRow, 1).Font.Underline = xlUnderlineStyleSingle ActiveSheet.Cells(iRow, 2) = tdf.Properties("Description") 'merge the cells for the table descriptions sTemp = "B" & iRow & ":D" & iRow Range(sTemp).MergeCells = True iRow = iRow + 1 'generate a header for the fields ActiveSheet.Cells(iRow, 2) = "Field Name" ActiveSheet.Cells(iRow, 2).Font.Bold = True ActiveSheet.Cells(iRow, 2).Font.Underline = xlUnderlineStyleSingle ActiveSheet.Cells(iRow, 3) = "Type" ActiveSheet.Cells(iRow, 3).Font.Bold = True ActiveSheet.Cells(iRow, 3).Font.Underline = xlUnderlineStyleSingle ActiveSheet.Cells(iRow, 4) = "Description" ActiveSheet.Cells(iRow, 2).Font.Bold = True ActiveSheet.Cells(iRow, 4).Font.Underline = xlUnderlineStyleSingle iRow = iRow + 1 'scroll thru the fields For Each fld In tdf.Fields ActiveSheet.Cells(iRow, 2) = fld.Name ActiveSheet.Cells(iRow, 2).Font.Bold = True ActiveSheet.Cells(iRow, 3) = TypeName(fld.Type) ActiveSheet.Cells(iRow, 4) = fld.Properties("Description") iRow = iRow + 1 Next fld iRow = iRow + 1 End If Next tdf 'generate a query section header iRow = iRow + 1 ActiveSheet.Cells(iRow, 1) = "Queries" ActiveSheet.Cells(iRow, 1).Font.Bold = True ActiveSheet.Cells(iRow, 1).Font.Size = 12 'merge the cells for the Query descriptions sTemp = "B" & iRow & ":D" & iRow Range(sTemp).MergeCells = True iRow = iRow + 1 'scroll thru the queries For Each qdf In db.QueryDefs ActiveSheet.Cells(iRow, 1) = qdf.Name ActiveSheet.Cells(iRow, 1).Font.Bold = True ActiveSheet.Cells(iRow, 1).Font.Underline = xlUnderlineStyleSingle ActiveSheet.Cells(iRow, 4) = qdf.Properties("Description") 'merge the cells for the Query descriptions sTemp = "B" & iRow & ":D" & iRow Range(sTemp).MergeCells = True iRow = iRow + 1 Next qdf End If ExitSub: Exit Sub ErrorHandler: Select Case Err Case 3270 'property Not found Resume Next Case Else MsgBox Err.Description Goto ExitSub End Select End Sub Function TypeName(iType As Integer) As String Select Case iType Case dbBigInt TypeName = "Big Integer" Case dbBinary TypeName = "Binary" Case dbBoolean TypeName = "Boolean" Case dbByte TypeName = "Byte" Case dbChar TypeName = "Char" Case dbCurrency TypeName = "Currency" Case dbDate TypeName = "Date" Case dbDecimal TypeName = "Decimal" Case dbDouble TypeName = "Double" Case dbFloat TypeName = "Float" Case dbGUID TypeName = "GUID" Case dbInteger TypeName = "Integer" Case dbLong TypeName = "Long" Case dbLongBinary TypeName = "Long Binary" Case dbMemo TypeName = "Memo" Case dbNumeric TypeName = "Numeric" Case dbSingle TypeName = "Single" Case dbText TypeName = "Text" Case dbTime TypeName = "Time" Case dbTimeStamp TypeName = "Time Stamp" Case dbVarBinary TypeName = "VarBinary" Case Else TypeName = "" End Select End Function |