快速开发平台--自动生成类模块代码

时　间: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