快速開發平臺--自動生成類模塊代碼
來源:www.accessoft.com 點擊數:1328 評論數:1 評論 | 收藏 | 複製
時 間:2013-12-17 20:22:36
作 者:Aaron ID：20267 城市：閔行
摘 要:根據表的字段，自動生成對應的類模塊。
正 文:
根據表的字段，自動生成對應的類模塊。
使用的時候務必保證有一個完全空白的類模塊，裏面不能有任何的文本。
窗體代碼如下：
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
