Option Compare Database Option Explicit Dim strBasePath As String 'variables used for exporting Dim strOutputPath As String Public strObjectName As String Public Function UpdateDocumentationTables() As Boolean On Error GoTo ErrorTrap Dim dbCurrent As DAO.Database Set dbCurrent = CurrentDb strBasePath = left(dbCurrent.Name, Len(dbCurrent.Name) - Len(Dir(dbCurrent.Name, vbNormal))) & "Backup\" & left(Dir(dbCurrent.Name, vbNormal), Len(Dir(dbCurrent.Name, vbNormal)) - 4) & "_" 'outputs code modules Call CallOutPutModules 'puts query details into table Call FX_GetQueryDetails 'outputs query details Call FX_OutputQueriesToText 'defines and create path for tables strOutputPath = Replace(strOutputPath, "\Queries\", "\Tables\") Call MakeDirMulti(strOutputPath) Call FX_GetTableDetails Call FX_GetTableFeatures UpdateDocumentationTables = True ExitFx: Exit Function ErrorTrap: GoTo ExitFx UpdateDocumentationTables = False End Function Function CallOutPutModules() ''outputs all module, form, and sheet code ''directory specified in variable ''creates directories as needed ''creates up to 99 backups per day (arbitrary) Dim strDate As String Dim strOutputVersion As Integer 'used in new directory name strDate = Format(Date, "YYYY-MM-DD") strOutputVersion = 1 strOutputPath = strBasePath & strDate & "-" & strOutputVersion 'checks for directory existence 'loops through until output directory is uniquely named While Len(Dir(strOutputPath, vbDirectory)) > 0 And strOutputVersion < 99 strOutputVersion = strOutputVersion + 1 strOutputPath = strBasePath & strDate & "-" & strOutputVersion & "\" Wend 'creates directory then populates via OutPutModules code If Len(Dir(strOutputPath, vbDirectory)) = 0 Then MakeDirMulti strOutputPath OutPutModules (strOutputPath) Else MsgBox "Unable to make directory.", vbOKOnly, "Output Error" End If End Function Public Function FX_GetQueryDetails() strObjectName = "TBL_MetaData_QueryCode" ''verifies table existence, if not creates If FX_TableExists(strObjectName) = False Then Call FX_Create_TableQueries End If Call FX_WriteQueries End Function Public Function FX_GetTableDetails() strObjectName = "TBL_MetaData_TableStructures" ''verifies table existence, if not creates If FX_TableExists(strObjectName) = False Then Call FX_Create_TableStructures End If Call FX_Write_TableStructures End Function Public Function FX_GetTableFeatures() strObjectName = "TBL_MetaData_TableFeatures" ''verifies table existence, if not creates If FX_TableExists(strObjectName) = False Then Call FX_Create_TableFeatures End If Call FX_Write_TableFeatures End Function Function OutPutModules(strMyloc As Variant) '****************************************************************** ' This function will export ALL modules in the current dbase as ' text files to the user supplied location or to the default ' location. This function will except an optional argument as the ' location to export to. The Optional argument should consist of a ' path to the location where you want to store the text files. If ' you don't supply the optional argument, the default location of ' c:\ will be used. '****************************************************************** On Error GoTo OutPutModules_Error Dim strMyMsg As String Dim strMyTitle As String Dim strModuleName As String Dim intI As Integer Dim mdl As Module Dim strMyExt As String Dim strDisplayError As String Dim strNewMsg As String Dim strNewLoc As String ' If user enters the backslash in the location, for example, 'A:\', ' parse out the '\' backslash, assign the drive letter and the colon ' ONLY to variable 'Myloc'. If right(strMyloc, 1) = "\" Then strMyloc = left(strMyloc, Len(strMyloc) - 1) ' Set extension for file names. strMyExt = ".txt" ' Loop through module names and outputs to text For intI = 0 To Application.Modules.Count - 1 With Application.Modules(intI) ' Set string variable(strModuleName) to module names. strModuleName = .Name ' Print out ALL modules in designated format to designated drive/folder. strNewLoc = strMyloc & "\" & strModuleName & strMyExt 'Debug.Print intI & " : " & strModuleName & " : " & strNewLoc DoCmd.OutputTo acOutputModule, strModuleName, acFormatTXT, strNewLoc, 0 End With Next intI Exit Function OutPutModules_Error: Set mdl = Modules(strModuleName) strMyTitle = "Error in Procedure: OutPutTo ; Module: " & mdl strMyMsg = "Error Number: " & err.Number & Chr(13) & Chr(10) strMyMsg = strMyMsg & "Error Description :" & err.Description & Chr(13) & Chr(10) MsgBox strMyMsg, vbExclamation, strMyTitle End Function Function FX_Create_TableQueries() ' Requires Microsoft Active X Data Object library ' Requires ADO Extesnions for DDL and Security 'Defines variables for table creation Dim cnnSQLData As ADODB.Connection Dim rstSQLData As ADODB.Recordset Dim cat As ADOX.Catalog Dim tbl As ADOX.Table Dim tblName As String 'variable for message boxes Dim Response As Long On Error GoTo errTrap 'build table Set cnnSQLData = CurrentProject.Connection Set cat = New ADOX.Catalog Set cat.ActiveConnection = cnnSQLData Set tbl = New ADOX.Table 'Assign name, fields, and populate tblName = "TBL_MetaData_QueryCode" With tbl Set .ParentCatalog = cat .Name = tblName With .Columns .Append "QueryID", adInteger .Item("QueryID").Properties("AutoIncrement") = True .Append "Name", adVarWChar, 255 .Append "Description", adVarWChar, 255 .Append "SQL", adLongVarWChar, 8000 End With End With With tbl .Columns(1).Attributes = adColNullable .Columns(2).Attributes = adColNullable .Columns(3).Attributes = adColNullable End With 'Create Table With cat.Tables .Append tbl .Refresh End With 'Close connections to first connection and set to nothing cnnSQLData.Close Set cnnSQLData = Nothing Set rstSQLData = Nothing ''Superfluous ' Response = MsgBox("Table built!", vbOKOnly, "Yahoo!") Exit Function errTrap: Response = MsgBox(err.Description, vbOKOnly, "Error!") If Not cnnSQLData Is Nothing Then If cnnSQLData.State <> 0 Then cnnSQLData.Close Exit Function Set cnnSQLData = Nothing Set rstSQLData = Nothing End If End If End Function Function FX_Create_TableStructures() ' Requires Microsoft Active X Data Object library ' Requires ADO Extesnions for DDL and Security 'Defines variables for table creation Dim cnnSQLData As ADODB.Connection Dim rstSQLData As ADODB.Recordset Dim cat As ADOX.Catalog Dim tbl As ADOX.Table Dim tblName As String 'variable for message boxes Dim Response As Long On Error GoTo errTrap 'build table Set cnnSQLData = CurrentProject.Connection Set cat = New ADOX.Catalog Set cat.ActiveConnection = cnnSQLData Set tbl = New ADOX.Table 'Assign name, fields, and populate tblName = "TBL_MetaData_TableStructures" With tbl Set .ParentCatalog = cat .Name = tblName With .Columns .Append "TableID", adInteger .Item("TableID").Properties("AutoIncrement") = True .Append "Name", adVarWChar, 255 .Append "Description_Table", adVarWChar, 255 .Append "Field", adVarWChar, 255 .Append "Type", adVarWChar, 255 .Append "Size", adInteger .Append "Description_Field", adLongVarWChar, 8000 End With End With With tbl .Columns(1).Attributes = adColNullable .Columns(2).Attributes = adColNullable .Columns(3).Attributes = adColNullable .Columns(4).Attributes = adColNullable .Columns(5).Attributes = adColNullable .Columns(6).Attributes = adColNullable End With 'Create Table With cat.Tables .Append tbl .Refresh End With 'Close connections to first connection and set to nothing cnnSQLData.Close Set cnnSQLData = Nothing Set rstSQLData = Nothing ''Superfluous ' Response = MsgBox("Table built!", vbOKOnly, "Yahoo!") Exit Function errTrap: Response = MsgBox(err.Description, vbOKOnly, "Error!") If Not cnnSQLData Is Nothing Then If cnnSQLData.State <> 0 Then cnnSQLData.Close Exit Function Set cnnSQLData = Nothing Set rstSQLData = Nothing End If End If End Function Function FX_Create_TableFeatures() ' Requires Microsoft Active X Data Object library ' Requires ADO Extesnions for DDL and Security 'Defines variables for table creation Dim cnnSQLData As ADODB.Connection Dim rstSQLData As ADODB.Recordset Dim cat As ADOX.Catalog Dim tbl As ADOX.Table Dim tblName As String 'variable for message boxes Dim Response As Long On Error GoTo errTrap 'build table Set cnnSQLData = CurrentProject.Connection Set cat = New ADOX.Catalog Set cat.ActiveConnection = cnnSQLData Set tbl = New ADOX.Table 'Assign name, fields, and populate tblName = "TBL_MetaData_TableFeatures" With tbl Set .ParentCatalog = cat .Name = tblName With .Columns .Append "TableID", adInteger .Item("TableID").Properties("AutoIncrement") = True .Append "Name", adVarWChar, 255 .Append "Description_Table", adVarWChar, 255 .Append "RecordCount", adInteger .Append "Size", adInteger End With End With With tbl .Columns(1).Attributes = adColNullable .Columns(2).Attributes = adColNullable .Columns(3).Attributes = adColNullable .Columns(4).Attributes = adColNullable End With 'Create Table With cat.Tables .Append tbl .Refresh End With 'Close connections to first connection and set to nothing cnnSQLData.Close Set cnnSQLData = Nothing Set rstSQLData = Nothing ''Superfluous ' Response = MsgBox("Table built!", vbOKOnly, "Yahoo!") Exit Function errTrap: Response = MsgBox(err.Description, vbOKOnly, "Error!") If Not cnnSQLData Is Nothing Then If cnnSQLData.State <> 0 Then cnnSQLData.Close Exit Function Set cnnSQLData = Nothing Set rstSQLData = Nothing End If End If End Function Public Function FX_WriteQueries() As Boolean Dim Response As Long On Error GoTo ErrorTrap 'Set Default value as false FX_WriteQueries = False Dim dbCurrent As DAO.Database Dim rstQueries As DAO.Recordset Set dbCurrent = CurrentDb Dim dCounter As Double Dim strReports As String 'purges current table of queries dbCurrent.Execute "DELETE * FROM TBL_MetaData_QueryCode" Set rstQueries = dbCurrent.OpenRecordset("TBL_MetaData_QueryCode", dbOpenTable) 'loops through querydefs and writes values into table For dCounter = 0 To ((dbCurrent.QueryDefs.Count) - 1) With rstQueries .AddNew .Fields(1) = dbCurrent.QueryDefs(dCounter).Name 'some queries have no description 'text written first, and left if error, else writes description .Fields(2) = "No Description" On Error Resume Next '.Fields(2) = dbCurrent.QueryDefs(dCounter).Properties("Description") 'some queries are too complex to write 'error written first, and left if error, else writes SQL .Fields(3) = "Error in Query" On Error Resume Next .Fields(3) = dbCurrent.QueryDefs(dCounter).SQL .Update End With Next rstQueries.Close Set rstQueries = Nothing FX_WriteQueries = True Exit Function ErrorTrap: Response = MsgBox(err.Number & Chr(33) & err.Description & Chr(33) & err.Source, "Table Count", vbOKOnly, "Object Count") FX_WriteQueries = False rstQueries.Close Set rstQueries = Nothing End Function Public Function FX_Write_TableStructures() As Boolean Dim Response As Long On Error GoTo ErrorTrap 'sets default values as false FX_Write_TableStructures = False Dim dbCurrent As DAO.Database Dim rstQuery As DAO.Recordset Set dbCurrent = CurrentDb Dim dCounter As Double Dim dFieldCount As Double Dim strReports As String dbCurrent.Execute "DELETE * FROM TBL_MetaData_TableStructures" Set rstQuery = dbCurrent.OpenRecordset("TBL_MetaData_TableStructures", dbOpenTable) For dCounter = 0 To ((dbCurrent.TableDefs.Count) - 1) With rstQuery If Not InStr(1, dbCurrent.TableDefs(dCounter).Name, "dbo") Then For dFieldCount = 0 To dbCurrent.TableDefs(dCounter).Fields.Count - 1 .AddNew .Fields(1) = dbCurrent.TableDefs(dCounter).Name .Fields(2) = "No Description" On Error Resume Next '.Fields(2) = dbCurrent.TableDefs(dCounter).Properties("Description") .Fields(3) = dbCurrent.TableDefs(dCounter).Fields(dFieldCount).Name .Fields(4) = FX_FieldTypeName(dbCurrent.TableDefs(dCounter).Fields(dFieldCount).Type) .Fields(5) = dbCurrent.TableDefs(dCounter).Fields(dFieldCount).Size .Fields(6) = "No Description" On Error Resume Next '.Fields(6) = dbCurrent.TableDefs(dCounter).Fields(dFieldCount).Properties("Description") .Update Next dFieldCount End If '.MoveNext End With Next rstQuery.Close Set rstQuery = Nothing dbCurrent.Close Set dbCurrent = Nothing FX_Write_TableStructures = True Exit Function ErrorTrap: FX_Write_TableStructures = False rstQuery.Close Set rstQuery = Nothing dbCurrent.Close Set dbCurrent = Nothing Response = MsgBox(err.Number & Chr(33) & err.Description & Chr(33) & err.Source, "Table Count", vbOKOnly, "Object Count") End Function Public Function FX_Write_TableFeatures() As Boolean Dim Response As Long On Error GoTo ErrorTrap 'sets default values as false FX_Write_TableFeatures = False Dim dbCurrent As DAO.Database Dim rstQuery As DAO.Recordset Set dbCurrent = CurrentDb Dim dCounter As Double Dim dFieldCount As Double Dim strReports As String dbCurrent.Execute "DELETE * FROM TBL_MetaData_TableFeatures" Set rstQuery = dbCurrent.OpenRecordset("TBL_MetaData_TableFeatures", dbOpenTable) For dCounter = 0 To ((dbCurrent.TableDefs.Count) - 1) With rstQuery If Not InStr(1, dbCurrent.TableDefs(dCounter).Name, "dbo") Then .AddNew .Fields(1) = dbCurrent.TableDefs(dCounter).Name .Fields(2) = "No Description" On Error Resume Next .Fields(2) = dbCurrent.TableDefs(dCounter).Properties("Description") '.Fields(3) = "Disabled" '.Fields(3) = Fx_Table_RecordCount(dbCurrent.TableDefs(dCounter).Name) .Fields(3) = dbCurrent.TableDefs(dCounter).RecordCount 'On Error Resume Next '.Fields(4) = dbCurrent.TableDefs(dCounter). .Update End If '.MoveNext End With Next rstQuery.Close Set rstQuery = Nothing dbCurrent.Close Set dbCurrent = Nothing FX_Write_TableFeatures = True Exit Function ErrorTrap: FX_Write_TableFeatures = False rstQuery.Close Set rstQuery = Nothing dbCurrent.Close Set dbCurrent = Nothing Response = MsgBox(err.Number & Chr(33) & err.Description & Chr(33) & err.Source, "Table Count", vbOKOnly, "Object Count") End Function Private Function FX_FieldTypeName(n As Long) As String 'Purpose: Converts the numeric results of DAO fieldtype to text. 'Note: fld.Type is Integer, but the constants are Long. Dim strReturn As String 'Name to return Select Case n Case dbBoolean strReturn = "Yes/No" '1 Case dbByte strReturn = "Byte" '2 Case dbInteger strReturn = "Integer" '3 Case dbLong strReturn = "Long Integer" '4 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 Case dbText strReturn = "Text" '10 Case dbLongBinary strReturn = "OLE Object" '11 Case dbMemo strReturn = "Memo" '12 Case dbGUID strReturn = "GUID" '15 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 Case Else strReturn = "Field type " & n & "unknown" End Select FX_FieldTypeName = strReturn End Function Public Function FX_OutputQueriesToText() As Boolean On Error GoTo ErrorTrap 'values ofr local table to write to Dim dbCurrent As DAO.Database Dim daorsQueryCode As DAO.Recordset Set dbCurrent = CurrentDb Dim strFullPath As String strOutputPath = strOutputPath & "\Queries\" strOutputPath = Replace(strOutputPath, "\\", "\") MkDir strOutputPath Set daorsQueryCode = dbCurrent.OpenRecordset("TBL_MetaData_QueryCode", dbOpenTable, dbOptimistic) 'evaluates error, if no recordset, writes error message 'else, write stored proc If Not daorsQueryCode.EOF Or daorsQueryCode.BOF Then daorsQueryCode.MoveFirst While Not daorsQueryCode.EOF strFullPath = strOutputPath & FX_IllegalChar_Replace(daorsQueryCode(1) & ".txt", "_") WriteToCMDFile strFullPath, daorsQueryCode(3) daorsQueryCode.MoveNext Wend End If FX_OutputQueriesToText = True If IsObject(daorsQueryCode) Then daorsQueryCode.Close Set daorsQueryCode = Nothing End If dbCurrent.Close Set dbCurrent = Nothing Exit Function ErrorTrap: FX_OutputQueriesToText = False MsgBox err.Number & ": " & err.Description If IsObject(daorsQueryCode) Then daorsQueryCode.Close Set daorsQueryCode = Nothing End If dbCurrent.Close Set dbCurrent = Nothing End Function