clsvbtableclass.cls

VB代码生成器

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsVBTableClass"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'**********************************************************************
'**  功能描述: 代码生成器VB源码表操作部份
'**
'**  作    者: 陈顺球(LionCSQ)
'**  创建时间: 2005 年 09 月 08 日
'**-------------------------------------------------------------------
'**
'**  改进人员: 寻百安(XunBaian)
'**  改进日期: 2005 年 09 月 15 日

'**  改进描述:
'**********************************************************************

Option Explicit
Private mstrAutoIncrement As String

Public Function GetTableString(ByVal vstrProjectName As String, _
                              ByRef objTable As Table, _
                              ByVal vstrAutoIncrement As String, _
                              ByRef rstrClassString As String, _
                              Optional ByVal vblnView As Boolean = True, _
                              Optional ByRef rlngErrNum As Long = 0, _
                              Optional ByRef rstrErrDescr As String = "") As Boolean
   Dim strTemp As String
   Dim strTableType As String
   On Error GoTo GetTableStringErr
   strTableType = UCase(objTable.Type)

   GetTableString = False
   mstrAutoIncrement = vstrAutoIncrement
'   mstrAutoIncrement = GetPrimaryKey(objTable)

   strTemp = FileHeadInfo(vstrProjectName, objTable, vblnView)
   If strTableType <> "VIEW" Then
      strTemp = strTemp & CreateQAddNew(vstrProjectName, objTable)
      strTemp = strTemp & CreateGetUpdateString(vstrProjectName, objTable)
      strTemp = strTemp & CreateQUpdateFunction(vstrProjectName, objTable)
      strTemp = strTemp & CreateQDelFunction(vstrProjectName, objTable)
   End If
   strTemp = strTemp & CreateGetResults(vstrProjectName, objTable)
   strTemp = strTemp & CreateQGetAll(vstrProjectName, objTable)
   strTemp = strTemp & CreateQGetByField(vstrProjectName, objTable)
   strTemp = strTemp & CreateQGetBySQL(vstrProjectName, objTable)
   strTemp = strTemp & CreateQGetByWhere(vstrProjectName, objTable)
   strTemp = strTemp & CreateGetResult(vstrProjectName, objTable)
   strTemp = strTemp & CreateMoveFunction(vstrProjectName, objTable)
   strTemp = strTemp & CreateGetFindSQL(vstrProjectName, objTable)
   strTemp = strTemp & CreateTranceferSymbo()

   rstrClassString = strTemp
   GetTableString = True
   Err.Clear
GetTableStringErr:
   rlngErrNum = Err.Number
   rstrErrDescr = Err.Description
End Function

Private Function FileHeadInfo(ByVal vstrProjectName As String, _
                           ByRef objTable As Table, _
                           ByVal vblnView As Boolean) As String
   Dim strTemp As String
   Dim strTableName As String
   strTableName = objTable.Name

   If Not vblnView Then
      strTemp = "VERSION 1.0 CLASS" & vbCrLf
      strTemp = strTemp & "BEGIN" & vbCrLf
         strTemp = strTemp & Space(3) & "MultiUse = -1  'True" & vbCrLf
         strTemp = strTemp & Space(3) & "Persistable = 0  'NotPersistable" & vbCrLf
         strTemp = strTemp & Space(3) & "DataBindingBehavior = 0  'vbNone" & vbCrLf
         strTemp = strTemp & Space(3) & "DataSourceBehavior = 0   'vbNone" & vbCrLf
         strTemp = strTemp & Space(3) & "MTSTransactionMode = 0   'NotAnMTSObject" & vbCrLf
      strTemp = strTemp & "End" & vbCrLf
      strTemp = strTemp & "Attribute VB_Name = ""cls" & strTableName & """" & vbCrLf
      strTemp = strTemp & "Attribute VB_GlobalNameSpace = False" & vbCrLf
      strTemp = strTemp & "Attribute VB_Creatable = True" & vbCrLf
      strTemp = strTemp & "Attribute VB_PredeclaredId = False" & vbCrLf
      strTemp = strTemp & "Attribute VB_Exposed = True" & vbCrLf & vbCrLf
   
      strTemp = strTemp & "Option Explicit" & vbCrLf & vbCrLf
   End If

   strTemp = strTemp & "Private mobjQDatabase As clsQDatabase" & vbCrLf
   strTemp = strTemp & "Private mrst As ADODB.Recordset" & vbCrLf
   strTemp = strTemp & "Private Const MSTR_DATABASENAME As String = """ & vstrProjectName & """" & vbCrLf
   strTemp = strTemp & "Private Const MSTR_TABLENAME As String = """ & strTableName & """" & vbCrLf
   strTemp = strTemp & "Private mlngRecordCount As Long" & vbCrLf
   strTemp = strTemp & "Private mstrSQL As String" & vbCrLf & vbCrLf

   strTemp = strTemp & "Private Sub Class_Initialize()" & vbCrLf
      strTemp = strTemp & Space(3) & "Set mobjQDatabase = New clsQDatabase" & vbCrLf
      strTemp = strTemp & Space(3) & "mlngRecordCount = -1" & vbCrLf
      
      strTemp = strTemp & Space(3) & "If ConnectionState <> adStateOpen Then" & vbCrLf
         strTemp = strTemp & Space(6) & "Call mobjQDatabase.QOpenConnection(MSTR_DATABASENAME, False)" & vbCrLf
      strTemp = strTemp & Space(3) & "End If" & vbCrLf
   strTemp = strTemp & "End Sub" & vbCrLf & vbCrLf

   strTemp = strTemp & "Private Sub Class_Terminate()" & vbCrLf
      strTemp = strTemp & Space(3) & "Call mobjQDatabase.QCloseRecordSet(MSTR_DATABASENAME, mrst)" & vbCrLf
      strTemp = strTemp & Space(3) & "Set mobjQDatabase = Nothing" & vbCrLf
   strTemp = strTemp & "End Sub" & vbCrLf & vbCrLf

   strTemp = strTemp & "Public Property Get TableName() As String" & vbCrLf
      strTemp = strTemp & Space(3) & "TableName = MSTR_TABLENAME" & vbCrLf
   strTemp = strTemp & "End Property" & vbCrLf & vbCrLf

   strTemp = strTemp & "Public Property Get RecordCount() As Long" & vbCrLf
      strTemp = strTemp & Space(3) & "RecordCount = mlngRecordCount" & vbCrLf
   strTemp = strTemp & "End Property" & vbCrLf & vbCrLf

   strTemp = strTemp & "Public Property Get ConnectionState() As Long" & vbCrLf
      strTemp = strTemp & Space(3) & "ConnectionState = mobjQDatabase.QConnectionState(MSTR_DATABASENAME)" & vbCrLf
   strTemp = strTemp & "End Property" & vbCrLf & vbCrLf

   strTemp = strTemp & "Public Property Get DatabaseType() As EnuDatabaseType" & vbCrLf
      strTemp = strTemp & Space(3) & "DatabaseType = mobjQDatabase.QDatabaseType(MSTR_DATABASENAME)" & vbCrLf
   strTemp = strTemp & "End Property" & vbCrLf & vbCrLf

   strTemp = strTemp & "Public Property Get ConnectionString() As String" & vbCrLf
      strTemp = strTemp & Space(3) & "ConnectionString = mobjQDatabase.QConnectionString(MSTR_DATABASENAME)" & vbCrLf
   strTemp = strTemp & "End Property" & vbCrLf & vbCrLf

'   strTemp = strTemp & "Public Function SetConnection(Optional ByVal vblnIsReSet As Boolean = True, _" & vbCrLf
'                  strTemp = strTemp & Space(27) & "Optional ByRef rintDatabaseType As EnuDatabaseType = enuDatabaseType_SQLServer, _" & vbCrLf
'                  strTemp = strTemp & Space(27) & "Optional ByRef rstrConnectionString As String, _" & vbCrLf
'                  strTemp = strTemp & Space(27) & "Optional ByRef rlngErrNum As Long = 0, _" & vbCrLf
'                  strTemp = strTemp & Space(27) & "Optional ByRef rstrErrDescr As String = """") As Boolean" & vbCrLf
'      strTemp = strTemp & Space(3) & "SetConnection = mobjQDatabase.QOpenConnection(MSTR_DATABASENAME, vblnIsReSet, DatabaseType, mstrConnectionString, rlngErrNum, rstrErrDescr)" & vbCrLf
'      strTemp = strTemp & Space(3) & "rintDatabaseType = DatabaseType" & vbCrLf
'      strTemp = strTemp & Space(3) & "rstrConnectionString = mstrConnectionString" & vbCrLf
'   strTemp = strTemp & "End Function" & vbCrLf & vbCrLf

   strTemp = strTemp & "Private Function GetDateSymbo(ByVal vintDatabaseType As EnuDatabaseType) As String" & vbCrLf
      strTemp = strTemp & Space(3) & "Dim strSymbol As String" & vbCrLf
      strTemp = strTemp & Space(3) & "Select Case vintDatabaseType" & vbCrLf
         strTemp = strTemp & Space(6) & "Case enuDatabaseType_SQLServer" & vbCrLf
            strTemp = strTemp & Space(9) & "strSymbol = ""'""" & vbCrLf
         strTemp = strTemp & Space(6) & "Case enuDatabaseType_Access" & vbCrLf
            strTemp = strTemp & Space(9) & "strSymbol = ""#""" & vbCrLf
         strTemp = strTemp & Space(6) & "Case Else" & vbCrLf
            strTemp = strTemp & Space(9) & "strSymbol = ""'""" & vbCrLf
      strTemp = strTemp & Space(3) & "End Select" & vbCrLf
      strTemp = strTemp & Space(3) & "GetDateSymbo = strSymbol" & vbCrLf
   strTemp = strTemp & "End Function" & vbCrLf & vbCrLf

   FileHeadInfo = strTemp

End Function

Private Function CreateQAddNew(ByVal vstrProjectName As String, _
                              ByRef objTable As Table) As String
   Dim strTemp As String
   Dim strTableName As String, strHeadInfo As String
   Dim I As Long, lngCount As Long
   Dim strColummName As String
   Dim lngKeyCount As Long

   strTableName = objTable.Name

   strTemp = ""
   strTemp = strTemp & "Public Function QAddNew(ByRef udt" & strTableName & " As typ" & strTableName & ", _" & vbCrLf
                     strTemp = strTemp & Space(24) & "Optional ByVal vstrUpdateByFieldName As String = ""NotUpdate"", _" & vbCrLf
                     strTemp = strTemp & Space(24) & "Optional ByVal vstrUpdateByFieldValue As Variant, _" & vbCrLf
                     strTemp = strTemp & Space(24) & "Optional ByRef rlngErrNum As Long = 0, _" & vbCrLf
                     strTemp = strTemp & Space(24) & "Optional ByRef rstrErrDescr As String = """") As Boolean" & vbCrLf
      strTemp = strTemp & Space(3) & "Dim blnAddNew As Boolean" & vbCrLf
      strTemp = strTemp & Space(3) & "Dim strSymbol As String" & vbCrLf & vbCrLf
   
      strTemp = strTemp & Space(3) & "On Error GoTo QAddNewErr" & vbCrLf
      strTemp = strTemp & Space(3) & "QAddNew = False" & vbCrLf & vbCrLf

      strTemp = strTemp & Space(3) & "blnAddNew = True" & vbCrLf
      strTemp = strTemp & Space(3) & "If Len(vstrUpdateByFieldName) > 0 And vstrUpdateByFieldName <> ""NotUpdate"" Then" & vbCrLf & vbCrLf
         
         strTemp = strTemp & Space(6) & "If Not QGetByField(vstrUpdateByFieldName, vstrUpdateByFieldValue, rlngErrNum, rstrErrDescr) Then" & vbCrLf
            strTemp = strTemp & Space(9) & "Err.Raise rlngErrNum, , rstrErrDescr" & vbCrLf
         strTemp = strTemp & Space(6) & "End If" & vbCrLf & vbCrLf
               
         strTemp = strTemp & Space(6) & "If mlngRecordCount > 0 Then" & vbCrLf
            strTemp = strTemp & Space(9) & "If Not QUpdateByField(vstrUpdateByFieldName, vstrUpdateByFieldValue, udt" & strTableName & ", False, rlngErrNum, rstrErrDescr) Then" & vbCrLf
               strTemp = strTemp & Space(12) & "Err.Raise rlngErrNum, , rstrErrDescr" & vbCrLf
            strTemp = strTemp & Space(9) & "End If" & vbCrLf & vbCrLf
                     
            strTemp = strTemp & Space(9) & "blnAddNew = False" & vbCrLf
         strTemp = strTemp & Space(6) & "End If" & vbCrLf
      strTemp = strTemp & Space(3) & "End If" & vbCrLf & vbCrLf
      
      strTemp = strTemp & Space(3) & "If blnAddNew Then" & vbCrLf
         
         strTemp = strTemp & Space(6) & "strSymbol = GetDateSymbo(DatabaseType)" & vbCrLf & vbCrLf
      
         strTemp = strTemp & Space(6) & "mstrSQL = ""Insert Into "" & MSTR_TABLENAME & _" & vbCrLf & Space(12) & """ ("
      lngCount = objTable.Columns.Count
      For I = 0 To lngCount - 1
         strColummName = objTable.Columns.Item(I).Name
         
         If strColummName <> mstrAutoIncrement Then
            If I <> 0 Then
               If Right(strTemp, 1) <> "(" Then
                  strTemp = strTemp & ","
               End If
               If I Mod 10 = 0 Then
                  strTemp = strTemp & """ & _" & vbCrLf & Space(12) & """"
               End If
            End If
            strTemp = strTemp & strColummName
         End If
      Next I
      strTemp = strTemp & ") "" " & vbCrLf
      
      strTemp = strTemp & Space(6) & "With udt" & strTableName & vbCrLf
      strTemp = strTemp & Space(9) & "mstrSQL = mstrSQL & ""Values("
      
      For I = 0 To lngCount - 1
         strColummName = objTable.Columns.Item(I).Name
         If strColummName <> mstrAutoIncrement Then
            strHeadInfo = GetColumnTypeInfoHead(objTable.Columns.Item(I))