根据表的字段，自动生成对应的类模块。
使用的时候务必保证有一个完全空白的类模块，里面不能有任何的文本。
窗体代码如下：
Option Compare Database
Option Explicit
Private Sub btnGenerateClassFile_Click()
Dim strLineText As String
Dim strMessage As String
Dim clsModule As Module
Dim strFilePath As String
Dim strModuelVariant As String
Dim strAreaVariant As String
Dim strRecordSet As String
Dim strOptional As String
If IsNull(Me.cboClassModule) Or IsNull(Me.cboTableList) Then Exit Sub
LoadFieldList Me.cboTableList, Me '//选择的表的字段记录集加载到窗体的记录集
With Me.Recordset
If .EOF Then Exit Sub
'//在桌面生成一个文本文件
strFilePath = DeskTopPath & "\Test.cls"
If Len(Dir(strFilePath)) > 0 Then
Kill strFilePath
End If
Open strFilePath For Append Shared As #1
'//*.cls文件头
' Print #1, "VERSION 1.0 CLASS"
' Print #1, "BEGIN"
' Print #1, " MultiUse = -1 'True"
' Print #1, "End"
' Print #1, "Attribute VB_Name =cls_tblSupplier" '//替换成选择的表"
' Print #1, "Attribute VB_GlobalNameSpace = False"
' Print #1, "Attribute VB_Creatable = False"
' Print #1, "Attribute VB_PredeclaredId = False"
' Print #1, "Attribute VB_Exposed = False"
Print #1, "Option Compare Database"
Print #1, "Option Explicit"
Print #1,
strRecordSet = "mrst" & Me.cboClassModule
.MoveFirst
'//声明区
'//构造字段对应的全局变量
Do Until .EOF
strLineText = "private " & FieldVariant(!Name, !Type) & " AS " & FieldTypeText(!Type)
Print #1, strLineText
.MoveNext
Loop
'//其它变量
Print #1, "Private mblnCorrectData As Boolean"
Print #1, "Private mstrWrongMessage As String"
Print #1, "Public Event InvalidData(strMessage As String)"
Print #1, "Private " & strRecordSet & " as DAO.RecordSet"
Print #1, "Private mblnAddFlag As Boolean"
Print #1, "Private mblnSaveEnable as Boolean"
Print #1,
.MoveFirst
Do Until .EOF
'//构造字段对应的属性
Print #1, "'//" & !Name & "属性"
strModuelVariant = FieldVariant(!Name, !Type)
strAreaVariant = FieldVariant(!Name, !Type, 1)
If !Required Then
strOptional = "Optional strMessage As String"
Else
strOptional = ""
End If
'//Get()
Print #1, "Public Property Get " & !Name & "(" & strOptional & ") As " & FieldTypeText(!Type)
Print #1, " " & !Name & "= " & strModuelVariant
Print #1, "End Property"
'//Let()
If Len(strOptional) > 0 Then strOptional = strOptional & ","
Print #1, "Public Property Let " & !Name & "(" & strOptional & "ByVal " & strAreaVariant & " As " & FieldTypeText(!Type) & ")"
'//数字类型的字段检查是否输入的为数字
If !Type = 4 Or !Type = 5 Then
Print #1, " Dim blnCorrectData as boolean"
Print #1, " blnCorrectData=IsNumeric(" & strAreaVariant & ")"
Print #1, " mblnCorrectData = mblnCorrectData And blnCorrectData"
Print #1, " if not mblnCorrectData then"
Print #1, " mstrWrongMessage=mstrWrongMessage & strMessage & " & """" & "需要输入数字! " & """"
Print #1, " RaiseEvent InvalidData(mstrWrongMessage)"
Print #1, " Exit Property"
Print #1, " End if"
Else
If !Required Then
Print #1, " Dim blnCorrectData as boolean"
'//不能为空规则
Print #1, " blnCorrectData=CheckNull(" & strAreaVariant & ")"
Print #1, " mblnCorrectData = mblnCorrectData And blnCorrectData"
Print #1, " if not mblnCorrectData then"
Print #1, " mstrWrongMessage=mstrWrongMessage & strMessage & " & """" & "不能为空! " & """"
Print #1, " RaiseEvent InvalidData(mstrWrongMessage)"
Print #1, " Exit Property"
Print #1, " End if"
'//不能重复规则
Print #1, " blnCorrectData=CheckUnique(" & """" & !Name & """" & "," & strAreaVariant & ")"
Print #1, " mblnCorrectData = mblnCorrectData And blnCorrectData"
Print #1, " if not mblnCorrectData then"
Print #1, " mstrWrongMessage=mstrWrongMessage & strMessage & " & """" & "不能重复! " & """"
Print #1, " RaiseEvent InvalidData(mstrWrongMessage)"
Print #1, " Exit Property"
Print #1, " End if"
End If
End If
Print #1, " " & strModuelVariant & "= " & strAreaVariant
Print #1, "End Property"
Print #1,
.MoveNext
Loop
'//CorrectData方法
Print #1, "'//CorrectData方法"
Print #1, "Public Function CorrectData() As Boolean"
Print #1, " CorrectData = mblnCorrectData"
Print #1, " mblnSaveEnable = mblnCorrectData"
Print #1, " If Not CorrectData Then"
Print #1, " RaiseEvent InvalidData(mstrWrongMessage)"
Print #1, " End If"
Print #1, "End Function"
'//模块初始化事件
Print #1, "Private Sub Class_Initialize()"
Print #1, " mblnCorrectData = True"
Print #1, " mstrWrongMessage =" & """" & """"
Print #1, " Set " & strRecordSet & "=CurrentDb.OpenRecordSet(" & """" & "Select * FROM " & Me.cboTableList & """" & ")"
Print #1, " Call Scatter"
Print #1, "End Sub"
'//Scatter方法
Print #1, "'//Scatter方法"
Print #1, "public sub Scatter()"
Print #1, " With " & strRecordSet
.MoveFirst
Do Until .EOF
If !Type = 4 Or !Type = 5 Then
Print #1, " " & FieldVariant(!Name, !Type) & " =Nz( !" & !Name & ",0)"
Else
Print #1, " " & FieldVariant(!Name, !Type) & " =Nz( !" & !Name & "," & """" & """" & ")"
End If
.MoveNext
Loop
Print #1, " End With"
Print #1, "End Sub"
'//AddFlag方法
Print #1, "'//设置添加还是编辑标志变量"
Print #1, "Public Property Get AddFlag() as Boolean"
Print #1, " AddFlag=mblnAddFlag"
Print #1, "End Property"
Print #1, "Public Property Let AddFlag(ByVal ablnAddFlag as Boolean)"
Print #1, " mblnAddFlag=ablnAddFlag"
Print #1, "End Property"
'//ModifyRecord方法
Print #1, "'//ModifyRecord方法"
Print #1, "public sub ModifyRecord()"
Print #1, "'//根据主键字段类型的不同需要自行设置"
Print #1, " If not mblnSaveEnable Then "
Print #1, " MsgBox " & """" & "不能保存，请先调用StartSave方法！" & """" & ",vbCritical," & """" & "提示" & """"
Print #1, " Exit Sub"
Print #1, " End if"
Print #1, " With " & strRecordSet
Print #1, " If mblnAddFlag Then"
Print #1, " .AddNew"
Print #1, " !ID=GetNewID()"
Print #1, " else"
Print #1, " .Edit"
Print #1, " End If "
.MoveFirst
Do Until .EOF
If !Name <> "ID" Then
Print #1, " " & "!" & !Name & "=" & FieldVariant(!Name, !Type)
End If
.MoveNext
Loop
Print #1, " .Update"
Print #1, " If mblnAddFlag Then"
Print #1, " mlngID=!ID"
Print #1, " End If "
Print #1, " End With"
Print #1, "End Sub"
'//GotoRecord方法
Print #1, "'//GotoRecord方法"
Print #1, "Public Sub GotoRecord(ByVal alngID as long )"
Print #1, " " & strRecordSet & ".FindFirst " & """" & "ID=" & """" & " & alngID"
Print #1, " If alngID=0 then"
Print #1, " " & strRecordSet & ".AddNew"
Print #1, " End if"
Print #1, " Call Scatter"
Print #1, "End Sub"
'//GetNewID方法
Print #1, "'//GetNewID方法"
Print #1, "Public Function GetNewID() As Long"
Print #1, " GetNewID=DMax(" & """" & "ID" & """" & "," & """" & Me.cboTableList & """" & ")+1"
Print #1, "End Function"
'//CheckLength方法
Print #1, "'//CheckLength方法"
Print #1, "Public Function CheckLength(lngLength as long, CheckValue as string) As Boolean"
Print #1, " CheckLength=(len(CheckValue)>lnglength)"
Print #1, "End Function"
'//CheckUnique方法
Print #1, "'//CheckUnique方法"
Print #1, "Public Function CheckUnique(FieldName as string , CheckValue as string) As Boolean"
Print #1, " dim lngCurrentID"
Print #1, " If mblnAddFlag then"
Print #1, " lngCurrentID=0"
Print #1, " Else"
Print #1, " lngCurrentID=mlngID"
Print #1, " End If"
Print #1, " If DCount(FieldName," & """" & Me.cboTableList & """" & "," & _
"""" & "ID<> " & """" & " & lngCurrentID & " & """" & " And " & _
"""" & " & FieldName & " & """" & "='" & """" & "& CheckValue &" & """" & "'" & """" & ")=0 Then"
Print #1, " CheckUnique=true"
Print #1, " End If"
Print #1, "End Function"
'//CheckNull方法
Print #1, "'//CheckNull方法"
Print #1, "Public Function CheckNull(CheckValue as string) As Boolean"
Print #1, " CheckNull=(len(CheckValue)>0 )"
Print #1, "End Function"
'//StartSave方法
Print #1, "'//StartSave方法"
Print #1, "Public Function StartSave()"
Print #1, " mblnCorrectData＝True"
Print #1, " mstrWrongMessage=" & """" & """"
Print #1, " mblnSaveEnable=True"
Print #1, "End Function"
'//Delete方法
Print #1, "'//Delete方法"
Print #1, "Public Function Delete()"
Print #1, " With " & strRecordSet
Print #1, " .Delete"
Print #1, " End With"
Print #1, " Call MoveNext "
Print #1, "End Function"
'//MovePreviouis方法
Print #1, "'//MovePreviouis方法"
Print #1, "Public Function MovePreviouis()"
Print #1, " With " & strRecordSet
Print #1, " If Not .BOF Then"
Print #1, " .MovePrevious"
Print #1, " If .BOF Then"
Print #1, " .MoveFirst"
Print #1, " End If"
Print #1, " End If"
Print #1, " End With"
Print #1, " Call Scatter"
Print #1, "End Function"
'//MoveNext方法
Print #1, "'//MoveNext方法"
Print #1, "Public Function MoveNext()"
Print #1, " With " & strRecordSet
Print #1, " If Not .EOF Then"
Print #1, " .MoveNext"
Print #1, " If .EOF Then"
Print #1, " .MoveLast"
Print #1, " End If"
Print #1, " End If"
Print #1, " End With"
Print #1, " Call Scatter"
Print #1, "End Function"
'//InvalidData属性
Print #1, "Public Property Get InvalidData() as Boolean"
Print #1, " InvalidData=not mblnCorrectData"
Print #1, "End Property"
End With
'//关闭文件
Close #1
If Not IsNull(Me.cboClassModule) Then
DoCmd.OpenModule Me.cboClassModule
Me.SetFocus
Set clsModule = Modules(Me.cboClassModule)
With clsModule
If .CountOfLines = 0 Then
.AddFromFile strFilePath
MsgBox "代码添加成功！", vbInformation, "提示"
DoCmd.OpenModule Me.cboClassModule
Else
MsgBox "请检查是否选择了正确的类模块" & vbCrLf & " 如果正确请清空类模块的所有文本！", vbExclamation, "提示"
End If
End With
End If
End Sub
'//字段对应的变量前缀
Private Function FieldVariant(FieldName As String, FieldType As Integer, Optional VariantArea As Integer = 0) As String
Dim strPrefix As String
Dim strArea As String
Select Case VariantArea
Case 0
strArea = "m"
Case 1
strArea = "a"
End Select
Select Case FieldType
Case 4
strPrefix = strArea & "lng"
Case 10
strPrefix = strArea & "str"
Case 1
strPrefix = strArea & "bln"
Case 5
strPrefix = strArea & "cur"
Case 8
strPrefix = strArea & "dat"
Case Else
strPrefix = strArea & "var"
End Select
FieldVariant = strPrefix & FieldName
End Function
'//字段对应的变量类型文本
Private Function FieldTypeText(FieldType As Integer) As String
Dim strVariantText As String
Select Case FieldType
Case 4
strVariantText = "long"
Case 10
strVariantText = "string"
Case 1
strVariantText = "boolean"
Case 5
strVariantText = "currency"
Case 8
strVariantText = "date"
Case Else
strVariantText = "variant"
End Select
FieldTypeText = strVariantText
End Function
'//桌面路径
Private Function DeskTopPath() As String
Dim wshshell As Object
Set wshshell = CreateObject("wscript.shell")
DeskTopPath = wshshell.regread("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\desktop")
Set wshshell = Nothing
End Function
'//刷新模块列表
Private Sub btnRefresh_Click()
Dim objAccess As Object
Dim objModule As Module
Dim i As Integer
Dim strModuleName As String
Application.Echo False
Me.cboClassModule.RowSource = ""
For Each objAccess In CurrentProject.AllModules
strModuleName = objAccess.Name
DoCmd.OpenModule strModuleName
If Modules(strModuleName).Type = acStandardModule Or (Modules(strModuleName).CountOfLines > 0) Then
' DoCmd.Close acModule, strModuleName
' Me.SetFocus
Else
Me.cboClassModule.AddItem strModuleName
End If
Next
Application.Echo True
End Sub
Private Sub Form_Load()
btnRefresh_Click
LoadRDPObjectList rotTable, Me.cboTableList
End Sub
