| {\rtf1\ansi\ansicpg1252\deff0\deftab720{\fonttbl{\f0\fswiss MS Sans Serif;}{\f1\froman\fcharset2 Symbol;}} {\colortbl\red0\green0\blue0;\red0\green0\blue255;} \deflang1044\pard\plain\f0\fs20\cf0 I wrote this code for work. When you don't have Access on a user's machine where your VB program is, you can still check out its structure to pinpoint a problem. \par I also have a "Database Helper" program that I wrote that allows you to view the tables in the DB, run custom Select queries and Executes against an Access DB. Maybe I'll submit that one next. \par \plain\f0\fs17\cf0 \par Option Explicit \par Dim dbAccess As DAO.Database\tab 'Database Object \par Dim rsAccess As DAO.Recordset\tab 'Recordset Object \par Dim i As Integer \par Dim j As Long \par Dim oTable As DAO.TableDef\tab 'TableDef Object \par Dim oField As DAO.Field\tab 'Field Object \par \par \plain\f0\fs17\cf1 Private Sub cmdBrowse_Click()\plain\f0\fs17\cf0 \par On Error GoTo CancelBrowse \par 'Open Common Dialog for User to input Database Path \par With dlgCommon \par .CancelError = True \par .InitDir = App.Path \par .DialogTitle = "Open Database..." \par .Filter = "Access Databases *.mdb|*.mdb" \par .FileName = "" \par .ShowOpen \par txtDBPath = .FileName \par End With \par Exit Sub \par \par CancelBrowse: \par If Err.Number = 32755 Then 'User Pressed Cancel button \par Exit Sub \par Else \par MsgBox Err.Number & Chr(10) & _ \par Err.Description \par End If \par \plain\f0\fs17\cf1 End Sub\plain\f0\fs17\cf0 \par \par \plain\f0\fs17\cf1 Private Sub cmdPrint_Click()\plain\f0\fs17\cf0 \par On Error GoTo NoDB \par 'If no printers on user's system, get out \par If Printers.Count < 1 Then Exit Sub \par \par 'If no DB specified, get out \par If txtDBPath = "" Then Exit Sub \par \par 'this is for Password-protected Access databases \par If frmPassword.pstrPassword = "" Then \par 'No password (if password-protected, will error out \par 'and show "Enter Password" form \par Set dbAccess = OpenDatabase(Trim(txtDBPath), True, True) \par Else \par 'Password has been specified \par Set dbAccess = OpenDatabase(Trim(txtDBPath), True, True, ";pwd=" & frmPassword.pstrPassword) \par frmPassword.pstrPassword = "" \par End If \par \par If optHTML.Value = True Then 'Print Structure in an HTML file \par PrintHTML \par Set dbAccess = Nothing \par Exit Sub \par Else 'Print Structure to a printer \par Screen.MousePointer = vbHourglass \par Printer.Print Trim(txtDBPath) \par Printer.Print "" \par Printer.Print "" \par For Each oTable In dbAccess.TableDefs 'Loop through each table in the database \par \par 'this next line determines whether to print the Access System tables or not \par If chkSystemTables.Value = vbChecked Or Not UCase(Left(oTable.Name, 4)) = "MSYS" Then \par \par 'Printer Setup Header Stuff \par Printer.FontSize = 14 \par Printer.FontBold = True \par Printer.Print "TABLE NAME = " & oTable.Name \par Printer.FontSize = 8 \par Printer.FontBold = False \par Printer.Print "=======================================" \par Printer.Print "Date Created =" & oTable.DateCreated \par Printer.Print "Date Last Modified = " & oTable.LastUpdated \par Printer.Print "Records = " & oTable.RecordCount \par Printer.Print "---------------------------------------------------" \par Printer.Print "" \par Printer.Print "" \par \par 'Dont print System table breakdown \par If Not UCase(Left(oTable.Name, 4)) = "MSYS" Then \par 'open recordset on current table \par Set rsAccess = dbAccess.OpenRecordset(oTable.Name, dbOpenTable) \par \par 'All this X and Y stuff sets up the Columns and headings \par Printer.CurrentX = 500 \par Printer.FontBold = True \par Printer.Print "Fields Listing" \par Printer.FontBold = False \par Printer.CurrentX = 1000 \par j = Printer.CurrentY \par Printer.Print "Field Name" \par Printer.CurrentX = 3000 \par If Printer.CurrentY < j Then \par j = Printer.CurrentY \par End If \par Printer.CurrentY = j \par Printer.Print "Type" \par Printer.CurrentX = 5000 \par If Printer.CurrentY < j Then \par j = Printer.CurrentY \par End If \par Printer.CurrentY = j \par Printer.Print "Size" \par Printer.CurrentX = 7000 \par If Printer.CurrentY < j Then \par j = Printer.CurrentY \par End If \par Printer.CurrentY = j \par Printer.Print "Required" \par Printer.CurrentX = 9000 \par If Printer.CurrentY < j Then \par j = Printer.CurrentY \par End If \par Printer.CurrentY = j \par Printer.Print "Allow Null" \par Printer.CurrentX = 1000 \par j = Printer.CurrentY \par Printer.Print "-------------------" \par Printer.CurrentX = 3000 \par If Printer.CurrentY < j Then \par j = Printer.CurrentY \par End If \par Printer.CurrentY = j \par Printer.Print "--------" \par Printer.CurrentX = 5000 \par If Printer.CurrentY < j Then \par j = Printer.CurrentY \par End If \par Printer.CurrentY = j \par Printer.Print "--------" \par Printer.CurrentX = 7000 \par If Printer.CurrentY < j Then \par j = Printer.CurrentY \par End If \par Printer.CurrentY = j \par Printer.Print "--------------" \par Printer.CurrentX = 9000 \par If Printer.CurrentY < j Then \par j = Printer.CurrentY \par End If \par Printer.CurrentY = j \par Printer.Print "---------------" \par i = 0 \par \par 'Loop thru each field in current table - Line up columns and print field info \par For Each oField In rsAccess.Fields \par Printer.CurrentX = 1000 \par j = Printer.CurrentY \par Printer.Print oField.Name \par Printer.CurrentX = 3000 \par If Printer.CurrentY < j Then \par j = Printer.CurrentY \par End If \par Printer.CurrentY = j \par \par 'convert datatype into English \par Printer.Print GetFieldType(oField.Type) \par \par Printer.CurrentX = 5000 \par If Printer.CurrentY < j Then \par j = Printer.CurrentY \par End If \par Printer.CurrentY = j \par Printer.Print oField.Size \par Printer.CurrentX = 7000 \par If Printer.CurrentY < j Then \par j = Printer.CurrentY \par End If \par Printer.CurrentY = j \par Printer.Print oField.Required \par Printer.CurrentX = 9000 \par If Printer.CurrentY < j Then \par j = Printer.CurrentY \par End If \par Printer.CurrentY = j \par Printer.Print oField.AllowZeroLength \par i = i + 1 \par Next \par End If \par \par 'Get any indexes for current table \par If oTable.Indexes.Count > 0 Then \par Printer.Print "" \par Printer.CurrentX = 500 \par Printer.FontBold = True \par Printer.Print "Index Listing" \par Printer.FontBold = False \par j = Printer.CurrentY \par Printer.CurrentX = 1000 \par Printer.Print "Index Name" \par If Printer.CurrentY < j Then \par j = Printer.CurrentY \par End If \par Printer.CurrentY = j \par Printer.CurrentX = 3000 \par Printer.Print "Fields" \par If Printer.CurrentY < j Then \par j = Printer.CurrentY \par End If \par Printer.CurrentY = j \par Printer.CurrentX = 6000 \par Printer.Print "Unique" \par j = Printer.CurrentY \par Printer.CurrentX = 1000 \par Printer.Print "----------------" \par If Printer.CurrentY < j Then \par j = Printer.CurrentY \par End If \par Printer.CurrentY = j \par Printer.CurrentX = 3000 \par Printer.Print "----------" \par If Printer.CurrentY < j Then \par j = Printer.CurrentY \par End If \par Printer.CurrentY = j \par Printer.CurrentX = 6000 \par Printer.Print "----------" \par \par 'loop thru table Indexes (if any) \par For i = 0 To oTable.Indexes.Count - 1 \par j = Printer.CurrentY \par Printer.CurrentX = 1000 \par Printer.Print oTable.Indexes(i).Name \par If Printer.CurrentY < j Then \par j = Printer.CurrentY \par End If \par Printer.CurrentY = j \par Printer.CurrentX = 3000 \par Printer.Print oTable.Indexes(i).Fields \par If Printer.CurrentY < j Then \par j = Printer.CurrentY \par End If \par Printer.CurrentY = j \par Printer.CurrentX = 6000 \par Printer.Print oTable.Indexes(i).Unique \par Next i \par End If \par \par 'Clear recordset for next table \par Set rsAccess = Nothing \par \par 'Print each table on separate page or not \par If chkSeparated.Value = vbChecked Then \par Printer.EndDoc \par Else \par Printer.Print "" \par Printer.Print "" \par End If \par End If \par Next \par If Not chkSeparated.Value = vbChecked Then \par Printer.EndDoc \par End If \par \par 'Clear database variable \par Set dbAccess = Nothing \par MsgBox "Your Access Structure has been printed to " & Printer.DeviceName, vbInformation, "Complete" \par Screen.MousePointer = vbDefault \par Exit Sub \par End If \par \par NoDB: \par If Err.Number = 3031 Then 'Database needs a password \par frmPassword.Show vbModal \par If frmPassword.pblnCancel = True Then Exit Sub \par cmdPrint_Click \par Err.Clear \par Exit Sub \par End If \par MsgBox Err.Description \par Screen.MousePointer = vbDefault \par \plain\f0\fs17\cf1 End Sub\plain\f0\fs17\cf0 \par \par \plain\f0\fs17\cf1 Private Function GetFieldType(TypeCode As Integer)\plain\f0\fs17\cf0 \par 'This routine accepts the Fieldtype variable and returns the English version for printing \par Select Case TypeCode \par Case dbBinary \par GetFieldType = "Binary" \par Case dbBoolean \par GetFieldType = "Boolean" \par Case dbByte \par GetFieldType = "Byte" \par Case dbChar \par GetFieldType = "Character" \par Case dbCurrency \par GetFieldType = "Currency" \par Case dbDate \par GetFieldType = "Date/Time" \par Case dbDecimal \par GetFieldType = "Decimal" \par Case dbDouble \par GetFieldType = "Double" \par Case dbFloat \par GetFieldType = "Float" \par Case dbGUID \par GetFieldType = "GUID" \par Case dbInteger \par GetFieldType = "Integer" \par Case dbLong \par GetFieldType = "Long" \par Case dbLongBinary \par GetFieldType = "OLE Object" \par Case dbMemo \par GetFieldType = "Memo" \par Case dbNumeric \par GetFieldType = "Numeric" \par Case dbSingle \par GetFieldType = "Single" \par Case dbText \par GetFieldType = "Text" \par Case dbTime \par GetFieldType = "Time" \par Case dbTimeStamp \par GetFieldType = "TimeStamp" \par Case dbVarBinary \par GetFieldType = "VarBinary" \par Case Else \par GetFieldType = "Undetermined" \par End Select \par \plain\f0\fs17\cf1 End Function\plain\f0\fs17\cf0 \par \par \plain\f0\fs17\cf1 Private Sub PrintHTML()\plain\f0\fs17\cf0 \par 'this routine prints the Access Structure to an HTML file \par Dim SaveFile As String \par On Error GoTo CancelHTML \par \par 'More Common Dialog \par With dlgCommon \par .CancelError = True \par .DialogTitle = "Save HTML Page As..." \par .Filter = "Web Page *.htm|*.htm;*.html" \par .InitDir = "C:\\" \par .FileName = "Structure.htm" \par .ShowSave \par SaveFile = .FileName \par End With \par DoEvents \par Open SaveFile For Output As #2 \par \par 'Set database Object \par Set dbAccess = OpenDatabase(Trim(txtDBPath), True, True) \par \par 'HTML Template stuff \par Print #2, "" \par Print #2, "" \par Print #2, "" \par Print #2, " \par Print #2, "" \par Print #2, "" \par Print #2, " " \par \par 'Loop thru each table in Database \par For Each oTable In dbAccess.TableDefs \par Print #2, " " \par \par 'No System Tables \par If Not UCase(Left(oTable.Name, 4)) = "MSYS" Then \par \par 'open recordset for each table \par Set rsAccess = dbAccess.OpenRecordset(oTable.Name, dbOpenTable) \par Print #2, " Fields Listing "\par Print #2, "
\par \par 'Table Indexes \par If oTable.Indexes.Count > 0 Then \par Print #2, " Index Listing "\par Print #2, "
\par Print #2, " ==================================================================================== "\par End If \par Next \par Print #2, " End of Listing \par Print #2, " India web developer web development India | India web development company India ecommerce web developer \par Print #2, "" \par Close #2 \par MsgBox "Your HTML Listing has been saved as " & dlgCommon.FileName, vbInformation, "Complete" \par Exit Sub \par \par CancelHTML: \par If Err.Number = 32755 Then \par Exit Sub \par Else \par MsgBox Err.Number & Chr(10) & _ \par Err.Description \par End If \par \plain\f0\fs17\cf1 End Sub\plain\f0\fs17\cf0 \par \par \plain\f0\fs17\cf1 Private Sub optHTML_Click()\plain\f0\fs17\cf0 \par 'Disable Irrelevant Check Buttons \par chkSeparated.Enabled = False \par chkSystemTables.Enabled = False \par \plain\f0\fs17\cf1 End Sub\plain\f0\fs17\cf0 \par \par P\plain\f0\fs17\cf1 rivate Sub optPrinter_Click()\plain\f0\fs17\cf0 \par 'Enable Relevant Check Buttons \par chkSeparated.Enabled = True \par chkSystemTables.Enabled = True \par \plain\f0\fs17\cf1 End Sub\plain\f0\fs17\cf0 \par \par } |
Access Printer |