Function CreateClass(strTableName)
On Error Resume Next
Kill "C:\Temp\Declarations.txt"
Kill "C:\Temp\GetLet.txt"
Kill "C:\Temp\LoadMethod.txt"
Kill "C:\Temp\SaveMethod.txt"
On Error GoTo CreateClass_Err
Dim db As DAO.Database, tdf As DAO.TableDef, fld As DAO.Field, idx As DAO.Index
Dim strFile1 As String, strFile2 As String
Dim str1 As String, str2 As String, str3 As String, str4 As String, strKeyField As String
Dim strVarname As String
Dim intFileNo1 As Integer, intFileNo2 As Integer, intFileNo3 As Integer, intFileNo4 As Integer
Const SPACE3 = " "
Const SPACE6 = " "
Const SPACE9 = " "
intFileNo1 = FreeFile
Open "C:\Temp\Declarations.txt" For Output As intFileNo1
intFileNo2 = FreeFile
Open "C:\Temp\GetLet.txt" For Output As intFileNo2
intFileNo3 = FreeFile
Open "C:\Temp\LoadMethod.txt" For Output As intFileNo3
intFileNo4 = FreeFile
Open "C:\Temp\SaveMethod.txt" For Output As intFileNo4
Set db = CurrentDb
Set tdf = db.TableDefs(strTableName)
For Each idx In tdf.Indexes
If idx.Unique Then
strKeyField = idx.fields(0).Name
End If
Next
str3 = "Function Load()" & vbCrLf & _
SPACE3 & "Dim db as DAO.Database, rst as DAO.Recordset" & vbCrLf & vbCrLf & _
SPACE3 & "Set db = Currentdb" & vbCrLf & _
SPACE3 & "Set rst = db.openrecordset(" & Chr(34) & "SELECT * FROM " & tdf.Name & " WHERE " & strKeyField & " = " & Chr(34) & " & CStr(lng" & strKeyField & ")" & ")" & vbCrLf & _
SPACE3 & "With rst" & vbCrLf
str4 = "Function Save()" & vbCrLf & _
SPACE3 & "Dim db as DAO.Database, rst as DAO.Recordset" & vbCrLf & vbCrLf & _
SPACE3 & "Set db = Currentdb" & vbCrLf & _
SPACE3 & "Set rst = db.openrecordset(" & Chr(34) & "SELECT * FROM " & tdf.Name & " WHERE " & strKeyField & " = " & Chr(34) & " & CStr(lng" & strKeyField & ")" & ")" & vbCrLf & _
SPACE3 & "With rst" & vbCrLf & _
SPACE6 & "If .RecordCount=0 Then" & vbCrLf & _
SPACE9 & ".AddNew" & vbCrLf & _
SPACE6 & "Else" & vbCrLf & _
SPACE9 & ".Edit" & vbCrLf & _
SPACE6 & "Endif"
Print #intFileNo3, str3
Print #intFileNo4, str4
For Each fld In tdf.fields
If fld.Type = dbBoolean Then
strVarname = "boo" & fld.Name
str1 = "Private " & strVarname & " As Boolean"
str2 = "Public Property Get " & fld.Name & "() As Boolean" & vbCrLf & _
SPACE3 & fld.Name & " = " & strVarname & vbCrLf & _
"End Property" & vbCrLf & vbCrLf & _
"Public Property Let " & fld.Name & "(ByVal booNewValue as Boolean)" & vbCrLf & _
SPACE3 & strVarname & " = booNewValue" & vbCrLf & _
"End Property" & vbCrLf
ElseIf fld.Type = dbLong Or fld.Type = dbInteger Then
strVarname = "lng" & fld.Name
str1 = "Private " & strVarname & " As Long"
str2 = "Public Property Get " & fld.Name & "() As Long" & vbCrLf & _
SPACE3 & fld.Name & " = " & strVarname & vbCrLf & _
"End Property" & vbCrLf & vbCrLf & _
"Public Property Let " & fld.Name & "(ByVal lngNewValue as long)" & vbCrLf & _
SPACE3 & strVarname & " = lngNewValue" & vbCrLf & _
"End Property" & vbCrLf
ElseIf fld.Type = dbDouble Then
strVarname = "dbl" & fld.Name
str1 = "Private " & strVarname & " As Double"
str2 = "Public Property Get " & fld.Name & "() As Double" & vbCrLf & _
SPACE3 & fld.Name & " = " & strVarname & vbCrLf & _
"End Property" & vbCrLf & vbCrLf & _
"Public Property Let " & fld.Name & "(ByVal dblNewValue as Double)" & vbCrLf & _
SPACE3 & strVarname & " = dblNewValue" & vbCrLf & _
"End Property" & vbCrLf
ElseIf fld.Type = dbCurrency Then
strVarname = "cur" & fld.Name
str1 = "Private " & strVarname & " As Currency"
str2 = "Public Property Get " & fld.Name & "() As Currency" & vbCrLf & _
SPACE3 & fld.Name & " = " & strVarname & vbCrLf & _
"End Property" & vbCrLf & vbCrLf & _
"Public Property Let " & fld.Name & "(ByVal dblNewValue as Currency)" & vbCrLf & _
SPACE3 & strVarname & " = dblNewValue" & vbCrLf & _
"End Property" & vbCrLf
Else
strVarname = "var" & fld.Name
str1 = "Private " & strVarname & " As Variant"
str2 = "Public Property Get " & fld.Name & "() As Variant" & vbCrLf & _
SPACE3 & fld.Name & " = " & strVarname & vbCrLf & _
"End Property" & vbCrLf & vbCrLf & _
"Public Property Let " & fld.Name & "(ByVal varNewValue as Variant)" & vbCrLf & _
SPACE3 & strVarname & " = varNewValue" & vbCrLf & _
"End Property" & vbCrLf
End If
str3 = SPACE6 & strVarname & "= !" & fld.Name
str4 = SPACE6 & "!" & fld.Name & "= " & strVarname
Print #intFileNo1, str1
Print #intFileNo2, str2
Print #intFileNo3, str3
Print #intFileNo4, str4
Next
str3 = SPACE3 & "End With" & vbCrLf & _
SPACE3 & "rst.Close:Set rst = nothing" & vbCrLf & _
SPACE3 & "Set db = nothing" & vbCrLf & _
"End Function"
str4 = SPACE6 & ".Update" & vbCrLf & _
SPACE3 & "End With" & vbCrLf & _
SPACE3 & "rst.Close:Set rst = nothing" & vbCrLf & _
SPACE3 & "Set db = nothing" & vbCrLf & _
"End Function"
Print #intFileNo3, str3
Print #intFileNo4, str4
Close #intFileNo1
Close #intFileNo2
Close #intFileNo3
Close #intFileNo4
MsgBox "Finished"
Set idx = Nothing
Set tdf = Nothing
Set db = Nothing
Exit Function
CreateClass_Err:
MsgBox "An error has occurred"
Resume
End Function