' *******************************************************************
' * Module : M99 Debug Support
' * Debug support                                                   *
' * Author : JohnLeo Carton - Database Consult da                   *
' * Public Function Prefix : M99_                                   *
' * Date Started : 30-9-93                                          *
' *******************************************************************
Option Compare Database
Option Explicit


' Usage This text file is one module containing two pulic functions
' function M99_DumpToWord and M99_DumpToNotepad
' They will write a word/notepad document using the definition of the current database
' very handy if you have used those description fields.

' This code was written by me and as far as i know is slow but relatively bug free
' you may do what you want with it, but naturally i accept no resposibility for any grief
' or inconvenience it may cause you.
' You are free to distribute / change / sell / spit on / hate this code i only offer it in
' the hope that soemone finds it useful (as i have).
'
' I can be reached on the following
'     1)  JohnLeo Carton   jlmcc@msn.com
'     2)  73474.645@compuserve.com
'


Private Function GetFieldDescription (fld As Field)
    On Error GoTo leh_getfielddescription

    GetFieldDescription = fld.Properties("Description")
    Exit Function

leh_getfielddescription:
    GetFieldDescription = Null
    Exit Function

End Function

Private Function GetIndexDescription (ndx As Index)
    On Error GoTo leh_getIndexdescription

    GetIndexDescription = ndx.Properties("Description")
    Exit Function

leh_getIndexdescription:
    GetIndexDescription = Null
    Exit Function


End Function

Private Function GetTableDescription (tbl As TableDef)
    On Error GoTo leh_getTabledescription

    GetTableDescription = tbl.Properties("Description")
    Exit Function

leh_getTabledescription:
    GetTableDescription = Null
    Exit Function


End Function

Function M99_DumpToNotepad ()
  '*************************************************************************
  '* Function : Dum all tables
  '* Description : Dumps the definition of all user tables on this database
  '*************************************************************************
  Dim fnOutput%, irc%, sTemp$
  Static vsType$(1 To 12), vbUseSize%(1 To 12)
  Dim db As Database        ' Set up the database
  Dim tdef As TableDef, fld As Field, ndx As Index, i%, j%, k%
  Set db = DBEngine(0)(0)

  On Error GoTo lerh_M99_DumpAllTables

  vsType(1) = "Binary":   vbUseSize(1) = 0
  vsType(2) = "Byte":     vbUseSize(2) = 0
  vsType(3) = "Integer":  vbUseSize(3) = 0
  vsType(4) = "Long":     vbUseSize(4) = 0
  vsType(5) = "Currency": vbUseSize(5) = 0
  vsType(6) = "Single":   vbUseSize(6) = 0
  vsType(7) = "Double":   vbUseSize(7) = 0
  vsType(8) = "Date":     vbUseSize(8) = 0
  vsType(9) = "??":       vbUseSize(9) = 0
  vsType(10) = "Text":    vbUseSize(10) = 1
  vsType(11) = "Ole":     vbUseSize(11) = 0
  vsType(12) = "Memo":    vbUseSize(12) = 1

  fnOutput = FreeFile
  Open "c:\temp.txt" For Output As #fnOutput

  For i = 0 To db.TableDefs.Count - 1
10  Set tdef = db.TableDefs(i)
    If Left(tdef.Name, 4) <> "MSys" Then
      Print #fnOutput, "Table :"; tdef.Name

      If tdef.RecordCount < 0 Then ' Attached table
	Print #fnOutput, "  Source Table Name :"; tdef.SourceTableName
	Print #fnOutput, "  Connect :"; tdef.Connect
      Else
	Print #fnOutput, "  RecordCount :"; tdef.RecordCount
      End If

      Print #fnOutput, " "
15    For j = 0 To tdef.indexes.Count - 1
	Set ndx = tdef.indexes(j)
	Print #fnOutput, "  Index ("; j; ") :"; ndx.Name
	
	Print #fnOutput, "    Flags : ";
	If ndx.Primary Then Print #fnOutput, "Primary ";
	If ndx.Clustered Then Print #fnOutput, "Clustered ";
	If ndx.foreign Then Print #fnOutput, "Foreign ";
	If ndx.IgnoreNulls Then Print #fnOutput, "IgnoreNulls ";
	If ndx.Unique Then Print #fnOutput, "Unique ";
	If ndx.Required Then Print #fnOutput, "Required ";
	Print #fnOutput, " "

	Print #fnOutput, "    Fields : ";
	For k = 0 To ndx.Fields.Count - 1
	  Set fld = ndx.Fields(j)
	  Print #fnOutput, fld.Name; IIf(((fld.Attributes And DB_DESCENDING) <> 0), "-", "");
	Next
	Print #fnOutput, " "
      Next

      Print #fnOutput, " "
      Print #fnOutput, "  Table fields:"
      Print #fnOutput, " "
      Print #fnOutput, "    Name"; Tab(40); "Type"
      Print #fnOutput, "    ===="; Tab(40); "===="
20    For j = 0 To tdef.Fields.Count - 1
	Set fld = tdef.Fields(j)
	sTemp = vsType(fld.Type)
	If (fld.Attributes And DB_VARIABLEFIELD) <> 0 Then sTemp = sTemp + "(" + fld.Size + ")"
	If (fld.Attributes And DB_AUTOINCRFIELD) <> 0 Then sTemp = sTemp + " Auto increment"
	Print #fnOutput, "    "; fld.Name; Tab(40); sTemp; ""
      Next
30    Print #fnOutput, " "
      Print #fnOutput, " "
    End If
  Next

  Close #fnOutput
  irc = Shell("Notepad c:\temp.txt", 3)
  Exit Function

lerh_M99_DumpAllTables:
  If Erl > 10 Then Resume 30
  MsgBox Error$
  Close #fnOutput
  Exit Function
End Function

Function M99_DumpToWord ()
  '*************************************************************************
  '* Function : Dump all tables to Word
  '* Description : Dumps the definition of all user tables on this database
  '*               Quick and Dirty
  '*************************************************************************
  Dim sTemp$, varRet  As Variant, z%
  Static vsType$(1 To 12), vbUseSize%(1 To 12)
  Dim db As Database, bQuitError%, objWord As Object, varDesc As Variant
  Dim tdef As TableDef, fld As Field, ndx As Index, i%, j%, k%

  bQuitError = True
  On Error GoTo lerh_M99_DumpToWord

  vsType(1) = "Binary":   vbUseSize(1) = 0
  vsType(2) = "Byte":     vbUseSize(2) = 0
  vsType(3) = "Integer":  vbUseSize(3) = 0
  vsType(4) = "Long":     vbUseSize(4) = 0
  vsType(5) = "Currency": vbUseSize(5) = 0
  vsType(6) = "Single":   vbUseSize(6) = 0
  vsType(7) = "Double":   vbUseSize(7) = 0
  vsType(8) = "Date":     vbUseSize(8) = 0
  vsType(9) = "??":       vbUseSize(9) = 0
  vsType(10) = "Text":    vbUseSize(10) = 1
  vsType(11) = "Ole":     vbUseSize(11) = 0
  vsType(12) = "Memo":    vbUseSize(12) = 1

  Set db = DBEngine(0)(0)
  Set objWord = CreateObject("Word.Basic")
  objWord.FileNew
  objWord.Style "Heading 1"
  objWord.Insert "Access Database Dump"
  objWord.InsertPara
  objWord.Bold 0

  bQuitError = False

  varRet = SysCmd(SYSCMD_INITMETER, "Generating Doc", db.TableDefs.Count - 1)
 

  For i = 0 To db.TableDefs.Count - 1
    varRet = SysCmd(SYSCMD_UPDATEMETER, i)
    z% = DoEvents() ' allow the message bar to redraw

    Set tdef = db.TableDefs(i)
    ' If table name starts with MSys its a system table
    If Left(tdef.Name, 4) = "MSys" Then GoTo lerh_M99_DumpToWord_30

    '********************************************************************************
    ' Write the table section
    '********************************************************************************
    objWord.Style "Heading 2"
    objWord.Insert "Table :" & tdef.Name: objWord.InsertPara

    objWord.Style "Normal"
    If tdef.RecordCount < 0 Then ' Attached table
      objWord.Insert "Source Table Name :" & tdef.SourceTableName: objWord.InsertPara
      objWord.Insert "Connect :" & tdef.Connect: objWord.InsertPara
    Else
      objWord.Insert "RecordCount :" & tdef.RecordCount: objWord.InsertPara
    End If

    varDesc = GetTableDescription(tdef)
    If Not IsNull(varDesc) Then objWord.Insert "Description :" & varDesc: objWord.InsertPara


    '********************************************************************************
    ' Indexes section
    '********************************************************************************
    objWord.Style "Heading 3"
    objWord.Insert "Indexes"
    objWord.InsertPara
    objWord.Style "Normal"

    z% = DoEvents() ' Allow Background processing

    objWord.TableInsertTable 0, 5, 1, , , 20, 1
    objWord.Bold: objWord.Insert "#"
    objWord.TableColumnWidth ".35"""
    objWord.NextCell: objWord.Bold: objWord.Insert "Name"
    objWord.TableColumnWidth "1"""
    objWord.NextCell: objWord.Bold: objWord.Insert "Flags"
    objWord.TableColumnWidth "1"""
    objWord.NextCell: objWord.Bold: objWord.Insert "Field"
    objWord.TableColumnWidth "1.65"""
    objWord.NextCell: objWord.Bold: objWord.Insert "Description"
    objWord.TableColumnWidth "2.0"""

    For j = 0 To tdef.indexes.Count - 1
      z% = DoEvents() ' Allow Bacground processing
      Set ndx = tdef.indexes(j)

      '###### Index No
      objWord.NextCell: objWord.Bold 0: objWord.Insert Str$(j)

      '###### Index Name
      objWord.NextCell: objWord.Bold 0: objWord.Insert ndx.Name

      '###### Index Flags
      objWord.NextCell: objWord.Bold 0
      If ndx.Primary Then objWord.Insert "Prim "
      If ndx.Clustered Then objWord.Insert "Cls"
      If ndx.foreign Then objWord.Insert "Fgn "
      If ndx.IgnoreNulls Then objWord.Insert "IgNull "
      If ndx.Unique Then objWord.Insert "Unique "
      If ndx.Required Then objWord.Insert "Reqd "
      
      varDesc = GetIndexDescription(ndx)
      If IsNull(varDesc) Then varDesc = ""

      '###### Fields (and description on first line)
      For k = 0 To ndx.Fields.Count - 1
	z% = DoEvents() ' Allow Bacground processing
	If (k > 0) Then     ' If second line skip number,name,flags
	  objWord.NextCell
	  objWord.NextCell
	  objWord.NextCell
	End If
	Set fld = ndx.Fields(k)

	'####### Field Name
	objWord.NextCell: objWord.Bold 0: objWord.Insert fld.Name & IIf(((fld.Attributes And DB_DESCENDING) <> 0), "-", "")
	
	'####### Description (first line only)
	objWord.NextCell: objWord.Bold 0: objWord.Insert varDesc
	varDesc = ""

      Next
    Next

    '********************************************************************************
    ' Fields section
    '********************************************************************************
    objWord.LineDown
    objWord.Style "Heading 3"
    objWord.Insert "Fields in table"
    objWord.InsertPara
    objWord.Style "Normal"

    z% = DoEvents() ' Allow Bacground processing

    objWord.TableInsertTable 0, 3, 1, , , 20, 1
    objWord.Bold: objWord.Insert "Name"
    objWord.TableColumnWidth "2"""
    objWord.NextCell: objWord.Bold: objWord.Insert "Type"
    objWord.TableColumnWidth "1"""
    objWord.NextCell: objWord.Bold: objWord.Insert "Description"
    objWord.TableColumnWidth "3.0"""
    
    For j = 0 To tdef.Fields.Count - 1
      z% = DoEvents() ' Allow Bacground processing
      Set fld = tdef.Fields(j)
      sTemp = vsType(fld.Type)
      If (fld.Attributes And DB_VARIABLEFIELD) <> 0 Then sTemp = sTemp + "(" + fld.Size + ")"
      If (fld.Attributes And DB_AUTOINCRFIELD) <> 0 Then sTemp = sTemp + " Auto increment"

      '####### Field Name
      objWord.NextCell: objWord.Bold 0: objWord.Insert fld.Name
      '####### Field Type
      objWord.NextCell: objWord.Bold 0: objWord.Insert sTemp
      
      '####### Field Description
      varDesc = GetFieldDescription(fld)
      If IsNull(varDesc) Then varDesc = ""
      objWord.NextCell: objWord.Bold 0: objWord.Insert varDesc
    Next

    objWord.LineDown


lerh_M99_DumpToWord_30:
  Next
  bQuitError = True

  objWord.FileSaveAs "c:\temp.doc"
  varRet = SysCmd(SYSCMD_CLEARSTATUS)
  Exit Function

lerh_M99_DumpToWord:
  MsgBox Error$ & " line : " & Erl
  If Not bQuitError Then Resume lerh_M99_DumpToWord_30
  varRet = SysCmd(SYSCMD_CLEARSTATUS)
  Exit Function

End Function

