I am using access 2003. I am trying to pass two variables to a function with no luck. I am new to passing variables so Im not sure if I picked the correct reference type, I have picked byref I am not sure that is the correct choice. What I am trying to do is develop a procedure that loops through all the tables in a database and tells me what the table name is, field name, data type, and all the other fields that are associted with the data type such as Field Size, Format, input mask,etc and export the data to excel. I had it working where it would tell me the table name, Field name and Description. I noticed as I looked at the tables that the field type changes depending on what type of datatype you have so I am trying to change field names to line up with what the data really is. The line Call GetRowType(dBase.TableDefs(lTbl).Fields(lFld), ByRef fRow as Integer) is what is giving me the problem. ByRef fRow as Integer is what I recently added.Any help would be appreciated.
Code:
Public Sub cmdTblInfo_Click()
Dim lTbl As Long
Dim lFld As Long
Dim lDFld As String
Dim dBase As DAO.Database
Dim xlApp As Object
Dim wbExcel As Object
Dim lRow As Long
Dim fRow As Long
Dim dtDate As Date
Dim strFileLoc As String
Dim strOpenFile As String
Dim strSaveFile As String
Dim rst As Recordset
Dim DtaTyp As String
'Set current database to a variable adn create a new Excel instance
Set dBase = CurrentDb
'Set on error in case there are no tables
On Error Resume Next
' OPEN EXCEL
Call XLCreate
If gbXLPresent = True Then
'OPEN EXCEL
With goXL
strFileLoc = "Z:\Adhoc projects\WMG\"
strOpenFile = "TableDescriptions" & ".xlt"
.Workbooks.Open FileName:=strFileLoc & strOpenFile
'Select Sheetname for information to go into.
.Sheets("Descriptions").Select
.Cells(1, 1).Select
End With
lRow = 1
fRow = 1
'Loop through all tables
For lTbl = 0 To dBase.TableDefs.Count
'If the table name is a temporary or system table then ignore it
If Left(dBase.TableDefs(lTbl).Name, 1) = "~" Or _
Left(dBase.TableDefs(lTbl).Name, 4) = "MSYS" Then
'~ indicates a temporary table
'MSYS indicates a system level table
Else
If fRow = 1 Then
With goXL.ActiveSheet
.Range("A" & fRow) = "Table Name"
.Range("B" & fRow) = "Field Name"
'ByVal vntMyArgument As Variant
[red] Call GetRowType(dBase.TableDefs(lTbl).Fields(lFld), ByRef fRow as Integer)[/red]
End With
Call XLFormatAutoFit(1, 12)
Call XLFormatFreezeTopRow
'Otherwise, loop through each table, writing the table and field names
'to the Excel file
For lFld = 0 To dBase.TableDefs(lTbl).Fields.Count - 1
lRow = fRow + 1
With goXL.ActiveSheet
.Range("A" & lRow) = dBase.TableDefs(lTbl).Name
.Range("B" & lRow) = dBase.TableDefs(lTbl).Fields(lFld).Name
.Range("C" & lRow) = dBase.TableDefs(lTbl).Fields(lFld).Type
.Range("C" & lRow) = GetDataType(dBase.TableDefs(lTbl).Fields(lFld))
.Range("D" & lRow) = dBase.TableDefs(lTbl).Fields(lFld).Type
.Range("D" & lRow) = GetField(dBase.TableDefs(lTbl).Fields(lFld))
.Range("E" & lRow) = dBase.TableDefs(lTbl).Fields(lFld).Properties("Decimcal Places")
.Range("E" & lRow) = dBase.TableDefs(lTbl).Fields(lFld).Properties("Description")
.Range("F" & lRow) = dBase.TableDefs(lTbl).Fields(lFld).DefaultValue
.Range("G" & lRow) = dBase.TableDefs(lTbl).Fields(lFld).Required
If .Range("G" & lRow) = dBase.TableDefs(lTbl).Fields(lFld).Required = False Then
.Range("G" & lRow) = "No"
End If
If .Range("G" & lRow) = dBase.TableDefs(lTbl).Fields(lFld).Required = True Then
.Range("G" & lRow) = "Yes"
End If
If .Range("H" & lRow) = dBase.TableDefs(lTbl).Fields(lFld).AllowZeroLength = False Then
.Range("H" & lRow) = "No"
End If
If .Range("H" & lRow) = dBase.TableDefs(lTbl).Fields(lFld).AllowZeroLength = True Then
.Range("H" & lRow) = "Yes"
End If
.Range("I" & lRow) = dBase.TableDefs(lTbl).Fields(lFld).Properties("Input Mask")
.Range("J" & lRow) = dBase.TableDefs(lTbl).Indexes.Count
'.Range("J" & lRow) = dBase.TableDefs(lTbl).Fields(lFld).Properties("Decimcal Places")
'.Range("E" & lRow) = dBase.TableDefs(lTbl).Fields(lFld).Properties("Description")
Call XLFormatAutoFit(1, 12)
' .Range("F" & lRow) = dBase.TableDefs(lTbl).Fields(lFld).Properties("Default Value")
' .Range("G" & lRow) = dBase.TableDefs(lTbl).Fields(lFld).Properties("Required")
' .Range("H" & lRow) = dBase.TableDefs(lTbl).Fields(lFld).Properties("Allow Zero Length")
' .Range("I" & lRow) = dBase.TableDefs(lTbl).Fields(lFld).Properties("Indexed")
' .Range("J" & lRow) = dBase.TableDefs(lTbl).Fields(lFld).Properties("Decimal Places")
' .Range("K" & lRow) = dBase.TableDefs(lTbl).Fields(lFld).Properties("Input Mask")
' .Range("L" & lRow) = dBase.TableDefs(lTbl).Fields(lFld).Properties("Format")
End With
Next lFld
End If 'fRow
End If ' Temp table check If Left(dBase.TableDefs(lTbl).Name, 1) = "~" Or
Next lTbl
'End If ' Loop for Table names 'Resume error breaks
On Error GoTo 0
With goXL.ActiveWorkbook
strFileLoc = "Z:\Adhoc projects\WMG\"
strSaveFile = "TableDescriptions" & parseRptDateMY
.SaveAs strFileLoc & strSaveFile & ".xls"
.Close
End With
Else
MsgBox "Can't create Excel Object", vbOKOnly, "Excel not found"
End If 'gbXLPresent
'Message Excel Is closed
' Close Excel Instance
Call XLKill
' Message it is closed
MsgBox "Reports Completed.", , "Done!"
'Release database object from memory
Set dBase = Nothing
End Sub
'Modules
Function GetField(F As Field) As String
Dim FieldType As String
Dim DtaType As String
Select Case (F.Type)
Case dbBoolean: FieldType = "Yes/No"
Case dbByte: FieldType = "Byte"
Case dbInteger: FieldType = "Integer"
Case dbCurrency: FieldType = "Currency"
Case dbSingle: FieldType = "Single"
Case dbDouble: FieldType = "Double"
Case dbDate: FieldType = "Date/Time"
Case dbBinary: FieldType = "Binary"
Case dbLongBinary: FieldType = "OLE Object"
Case dbText: FieldType = "Text"
'If (F.Attributes = 2) Then
'FieldType = "Currency"
'End If
Case dbGUID: FieldType = "Replication ID"
Case dbBigInt: FieldType = "Big Integer" '16
Case dbVarBinary: FieldType = "VarBinary" '17
Case dbChar: FieldType = "Char" '18
Case dbNumeric: FieldType = "Numeric" '19
Case dbDecimal: FieldType = "Decimal" '20
Case dbFloat: FieldType = "Float" '21
Case dbTime: FieldType = "Time" '22
Case dbTimeStamp: FieldType = "Time Stamp" '23
Case dbGUID: FieldType = "Number"
Case dbFixedField: FieldType = "Fixed Field Numeric Only"
Case dbVariableField: FieldType = "Variable Field Text Fields only"
Case dbLong
If (F.Attributes = 17) Then
FieldType = "AutoNumber"
Else
FieldType = "Long Integer"
End If
Case dbVariableField
Case dbNumeric
Case dbFixedField
Case dbUpdatableField
Case dbDescending
Case dbMemo
If (F.Attributes = 2) Then
FieldType = "Memo"
Else
FieldType = "HyperLink"
End If
If F.Attributes > 0 And F.Attributes < 9 And F.Attributes <> 2 Then
DtaTyp = "Number"
End If
'default: FieldType = "Other"
End Select
GetField = FieldType
End Function
Function GetFieldDescription(F As Field) As String
Dim Description As String
Description = ""
On Error Resume Next
Description = F.Properties("Description")
GetFieldDescription = Description
End Function
Function GetDataType(D As Field) As String
Dim FieldType As String
Dim DtaType As String
Select Case (D.Type)
Case dbBoolean: FieldType = "Yes/No"
'Case dbByte: FieldType = "Byte"
Case dbByte: FieldType = "Number"
'Case dbInteger: FieldType = "Integer"
Case dbInteger: FieldType = "Number"
Case dbLong:
If (D.Attributes = 1) Then
FieldType = "Number"
Else
FieldType = "AutoNumber"
End If
Case dbCurrency: FieldType = "Currency"
'Case dbSingle: FieldType = "Single"
Case dbSingle: FieldType = "Number"
'Case dbDouble: FieldType = "Double"
Case dbDouble: FieldType = "Number"
Case dbDate: FieldType = "Date/Time"
Case dbBinary: FieldType = "Binary"
Case dbLongBinary: FieldType = "OLE Object"
Case dbText: FieldType = "Text"
'Case dbText
'If (D.Attributes = 2) Then
'FieldType = "Currency"
'Else
'FieldType = "Text"
'End If
Case dbBigInt: FieldType = "Big Integer" '16
Case dbVarBinary: FieldType = "VarBinary" '17
Case dbChar: FieldType = "Char" '18
Case dbNumeric: FieldType = "Numeric" '19
Case dbDecimal: FieldType = "Number" '20
Case dbFloat: FieldType = "Float" '21
Case dbTime: FieldType = "Time" '22
Case dbTimeStamp: FieldType = "Time Stamp" '23
Case dbGUID: FieldType = "Number"
Case dbFixedField: FieldType = "Fixed Field Numeric Only"
Case dbVariableField: FieldType = "Variable Field Text Fields only"
Case dbVariableField
Case dbNumeric
Case dbFixedField
Case dbUpdatableField
Case dbDescending
Case dbMemo
If (D.Attributes = 2) Then
FieldType = "Memo"
Else
FieldType = "HyperLink"
End If
'default: FieldType = "Other"
End Select
GetDataType = FieldType
'GetFieldType1 = DataType
End Function
Function GetRowType(R As Field, fRow As Integer) As String
Dim RowType As String
Select Case (R.Type)
Case dbText
'Text Format
If (R.Attributes = 2) Then
With goXL.ActiveSheet
.Range("C" & fRow) = "Field Size"
.Range("D" & fRow) = "Format"
.Range("E" & fRow) = "Input Mask"
.Range("F" & fRow) = "Caption"
.Range("G" & fRow) = "Default Value"
.Range("H" & fRow) = "Required"
.Range("I" & fRow) = "Allow Zero Length"
.Range("J" & fRow) = "Indexed"
End With
Else
'Currency Format
With goXL.ActiveSheet
.Range("C" & fRow) = "Format"
.Range("D" & fRow) = "Decimal Place"
.Range("E" & fRow) = "Input Mask"
.Range("F" & fRow) = "Caption"
.Range("G" & fRow) = "Default Value"
.Range("H" & fRow) = "Required"
.Range("I" & fRow) = "Indexed"
End With
End If
Case dbMemo
'Memo Format
If (R.Attributes = 2) Then
With goXL.ActiveSheet
.Range("C" & fRow) = "Format"
.Range("D" & fRow) = "Default Value"
.Range("E" & fRow) = "Required"
.Range("F" & fRow) = "Allow Zero Length"
.Range("G" & fRow) = "Indexed"
End With
Else
'Hyperlink Format
With goXL.ActiveSheet
.Range("C" & fRow) = "Format"
.Range("D" & fRow) = "Caption"
.Range("E" & fRow) = "Default Value"
.Range("F" & fRow) = "Required"
.Range("G" & fRow) = "Allow Zero Length"
.Range("H" & fRow) = "Indexed"
End With
End If
Case dbLong:
If (R.Attributes = 1) Then
'Number Format
With goXL.ActiveSheet
.Range("C" & fRow) = "Field Size"
.Range("D" & fRow) = "Format"
.Range("E" & fRow) = "Input Mask"
.Range("F" & fRow) = "Caption"
.Range("G" & fRow) = "Default Value"
.Range("H" & fRow) = "Required"
.Range("I" & fRow) = "Allow Zero Length"
.Range("J" & fRow) = "Indexed"
End With
Else
'AutoNumber Format
With goXL.ActiveSheet
.Range("C" & fRow) = "Field Size"
.Range("D" & fRow) = "New Values"
.Range("E" & fRow) = "Format"
.Range("F" & fRow) = "Caption"
.Range("G" & fRow) = "Indexed"
End With
End If
Case dbDate:
'Date/Time Format
With goXL.ActiveSheet
.Range("C" & fRow) = "Format"
.Range("D" & fRow) = "Input Mask"
.Range("E" & fRow) = "Caption"
.Range("F" & fRow) = "Default Value"
.Range("G" & fRow) = "Required"
.Range("H" & fRow) = "Indexed"
End With
Case dbBoolean
'Yes/No Format
With goXL.ActiveSheet
.Range("C" & fRow) = "Format"
.Range("D" & fRow) = "Caption"
.Range("E" & fRow) = "Default Value"
.Range("F" & fRow) = "Required"
.Range("G" & fRow) = "Indexed"
End With
Case dbLongBinary
'OLE Object
With goXL.ActiveSheet
.Range("C" & fRow) = "Caption"
.Range("D" & fRow) = "Required"
End With
''Case dbByte: FieldType = "Byte"
'Case dbByte: FieldType = "Number"
''Case dbInteger: FieldType = "Integer"
'Case dbInteger: FieldType = "Number"
'Case dbSingle: FieldType = "Single"
'Case dbSingle: FieldType = "Number"
'Case dbDouble: FieldType = "Double"
'Case dbDouble: FieldType = "Number"
'Case dbDate: FieldType = "Date/Time"
'Case dbBinary: FieldType = "Binary"
'
'Case dbText: FieldType = "Text"
'Case dbText
'If (D.Attributes = 2) Then
'FieldType = "Currency"
'Else
'FieldType = "Text"
'End If
'Case dbBigInt: FieldType = "Big Integer" '16
'Case dbVarBinary: FieldType = "VarBinary" '17
'Case dbChar: FieldType = "Char" '18
'Case dbNumeric: FieldType = "Numeric" '19
'Case dbDecimal: FieldType = "Number" '20
'Case dbFloat: FieldType = "Float" '21
'Case dbTime: FieldType = "Time" '22
'Case dbTimeStamp: FieldType = "Time Stamp" '23
'Case dbGUID: FieldType = "Number"
'Case dbFixedField: FieldType = "Fixed Field Numeric Only"
'Case dbVariableField: FieldType = "Variable Field Text Fields only"
''
'Case dbVariableField
'
'Case dbNumeric
'
'Case dbFixedField
'
'Case dbUpdatableField
'
'Case dbDescending
'default: FieldType = "Other"
End Select
GetRowType = FieldType
'GetFieldType1 = DataType
End Function