clsvbtableclass.cls

VB代码生成器

      Select Case strHeadInfo
         Case "dtm"
            strDefaultValue = "#5/8/1972#"
         Case "str"
            strDefaultValue = """"""
         Case "lng", "int", "byt", "flt", "dbl", "sng"
            strDefaultValue = "0"
         Case "bln"
            strDefaultValue = "False"
         Case Else '"var"
            strDefaultValue = "Empty"
      End Select
'      strTemp = strTemp & Space(6) & "udt" & strTableName & "." & strHeadInfo & strColumnName & " = IIf(IsNull(mrst(""" & strColumnName & """)), " & strDefaultValue & ", mrst(""" & strColumnName & """))" & vbCrLf
      strTemp = strTemp & Space(6) & "." & strHeadInfo & strColumnName & " = IIf(IsNull(mrst(""" & strColumnName & """)), " & strDefaultValue & ", mrst(""" & strColumnName & """))" & vbCrLf
   Next I
   
   strTemp = strTemp & "   End With" & vbCrLf
   strTemp = strTemp & "   GetResult = udt" & strTableName & vbCrLf
   strTemp = strTemp & "End Function" & vbCrLf & vbCrLf
   
   CreateGetResult = strTemp
End Function

Private Function CreateMoveFunction(ByVal vstrProjectName As String, _
                                    ByRef objTable As Table) As String

   Dim strTemp As String
   Dim strTableName As String
   strTableName = objTable.Name
   
   strTemp = ""
   strTemp = strTemp & "Public Function QMoveFirst(ByRef rudt" & strTableName & " As typ" & strTableName & ", _" & vbCrLf
   strTemp = strTemp & "                           Optional ByRef rlngErrNum As Long = 0, _" & vbCrLf
   strTemp = strTemp & "                           Optional ByRef rstrErrDescr As String = """") As Boolean" & vbCrLf
   strTemp = strTemp & "   On Error GoTo QMoveFirstErr" & vbCrLf
   strTemp = strTemp & "   QMoveFirst = False" & vbCrLf & vbCrLf

   strTemp = strTemp & "   mrst.MoveFirst" & vbCrLf
   strTemp = strTemp & "   rudt" & strTableName & " = GetResult()" & vbCrLf & vbCrLf

   strTemp = strTemp & "   QMoveFirst = True" & vbCrLf
   strTemp = strTemp & "   Err.Clear" & vbCrLf
   strTemp = strTemp & "QMoveFirstErr:" & vbCrLf
   strTemp = strTemp & "   rlngErrNum = Err.Number" & vbCrLf
   strTemp = strTemp & "   rstrErrDescr = Err.Description" & vbCrLf
   strTemp = strTemp & "End Function" & vbCrLf & vbCrLf

   strTemp = strTemp & "Public Function QMoveLast(ByRef rudt" & strTableName & " As typ" & strTableName & ", _" & vbCrLf
   strTemp = strTemp & "                           Optional ByRef rlngErrNum As Long = 0, _" & vbCrLf
   strTemp = strTemp & "                           Optional ByRef rstrErrDescr As String = """") As Boolean" & vbCrLf
   strTemp = strTemp & "   On Error GoTo QMoveLastErr" & vbCrLf
   strTemp = strTemp & "   QMoveLast = False" & vbCrLf & vbCrLf

   strTemp = strTemp & "   mrst.MoveLast" & vbCrLf
   strTemp = strTemp & "   rudt" & strTableName & " = GetResult()" & vbCrLf & vbCrLf

   strTemp = strTemp & "   QMoveLast = True" & vbCrLf
   strTemp = strTemp & "   Err.Clear" & vbCrLf
   strTemp = strTemp & "QMoveLastErr:" & vbCrLf
   strTemp = strTemp & "   rlngErrNum = Err.Number" & vbCrLf
   strTemp = strTemp & "   rstrErrDescr = Err.Description" & vbCrLf
   strTemp = strTemp & "End Function" & vbCrLf & vbCrLf

   strTemp = strTemp & "Public Function QMoveNext(ByRef rudt" & strTableName & " As typ" & strTableName & ", _" & vbCrLf
   strTemp = strTemp & "                           Optional ByRef rlngErrNum As Long = 0, _" & vbCrLf
   strTemp = strTemp & "                           Optional ByRef rstrErrDescr As String = """") As Boolean" & vbCrLf
   strTemp = strTemp & "   On Error GoTo QMoveNextErr" & vbCrLf
   strTemp = strTemp & "   QMoveNext = False" & vbCrLf & vbCrLf

   strTemp = strTemp & "   mrst.MoveNext" & vbCrLf
   strTemp = strTemp & "   rudt" & strTableName & " = GetResult()" & vbCrLf & vbCrLf

   strTemp = strTemp & "   QMoveNext = True" & vbCrLf
   strTemp = strTemp & "   Err.Clear" & vbCrLf
   strTemp = strTemp & "QMoveNextErr:" & vbCrLf
   strTemp = strTemp & "   rlngErrNum = Err.Number" & vbCrLf
   strTemp = strTemp & "   rstrErrDescr = Err.Description" & vbCrLf
   strTemp = strTemp & "End Function" & vbCrLf & vbCrLf

   strTemp = strTemp & "Public Function QMovePrevious(ByRef rudt" & strTableName & " As typ" & strTableName & ", _" & vbCrLf
   strTemp = strTemp & "                           Optional ByRef rlngErrNum As Long = 0, _" & vbCrLf
   strTemp = strTemp & "                           Optional ByRef rstrErrDescr As String = """") As Boolean" & vbCrLf
   strTemp = strTemp & "   On Error GoTo QMovePreviousErr" & vbCrLf
   strTemp = strTemp & "   QMovePrevious = False" & vbCrLf & vbCrLf

   strTemp = strTemp & "   mrst.MovePrevious" & vbCrLf
   strTemp = strTemp & "   rudt" & strTableName & " = GetResult()" & vbCrLf & vbCrLf

   strTemp = strTemp & "   QMovePrevious = True" & vbCrLf
   strTemp = strTemp & "   Err.Clear" & vbCrLf
   strTemp = strTemp & "QMovePreviousErr:" & vbCrLf
   strTemp = strTemp & "   rlngErrNum = Err.Number" & vbCrLf
   strTemp = strTemp & "   rstrErrDescr = Err.Description" & vbCrLf
   strTemp = strTemp & "End Function" & vbCrLf & vbCrLf

   strTemp = strTemp & "Public Function QMoveTo(ByVal vlngNumRecords As Long, _" & vbCrLf
   strTemp = strTemp & "                        ByVal vlngStart As Long, _" & vbCrLf
   strTemp = strTemp & "                        ByRef rudt" & strTableName & " As typ" & strTableName & ", _" & vbCrLf
   strTemp = strTemp & "                        Optional ByRef rlngErrNum As Long = 0, _" & vbCrLf
   strTemp = strTemp & "                        Optional ByRef rstrErrDescr As String = """") As Boolean" & vbCrLf
   strTemp = strTemp & "   On Error GoTo QMoveToErr" & vbCrLf
   strTemp = strTemp & "   QMoveTo = False" & vbCrLf & vbCrLf

   strTemp = strTemp & "   mrst.Move vlngNumRecords, vlngStart" & vbCrLf
   strTemp = strTemp & "   rudt" & strTableName & " = GetResult()" & vbCrLf & vbCrLf

   strTemp = strTemp & "   QMoveTo = True" & vbCrLf
   strTemp = strTemp & "   Err.Clear" & vbCrLf
   strTemp = strTemp & "QMoveToErr:" & vbCrLf
   strTemp = strTemp & "   rlngErrNum = Err.Number" & vbCrLf
   strTemp = strTemp & "   rstrErrDescr = Err.Description" & vbCrLf
   strTemp = strTemp & "End Function" & vbCrLf & vbCrLf
   
   CreateMoveFunction = strTemp
End Function

Private Function CreateGetFindSQL(ByVal vstrProjectName As String, _
                                 ByRef objTable As Table) As String

   Dim strTemp As String
   Dim strTableName As String, strColumnName As String, strHeadInfo As String
   Dim I As Long, lngCount As Long
   strTableName = objTable.Name
   
   strTemp = ""
   strTemp = strTemp & "Public Function GetFindSQL(udt" & strTableName & " As typ" & strTableName & ") As String" & vbCrLf
   strTemp = strTemp & "   Dim strSQL As String" & vbCrLf
   strTemp = strTemp & "   Dim strSymbol As String" & vbCrLf
   strTemp = strTemp & "   strSymbol = GetDateSymbo(DatabaseType)" & vbCrLf & vbCrLf

   strTemp = strTemp & "   strSQL = ""Select * From " & strTableName & " Where 1=1""" & vbCrLf & vbCrLf

   lngCount = objTable.Columns.Count
   For I = 0 To lngCount - 1
      strColumnName = objTable.Columns.Item(I).Name
      If strColumnName <> mstrAutoIncrement Then
         strHeadInfo = GetColumnTypeInfoHead(objTable.Columns.Item(I))
         Select Case strHeadInfo
            Case "dtm"
               strTemp = strTemp & "   If udt" & strTableName & "." & strHeadInfo & strColumnName & " > #5/8/1900# Then" & vbCrLf
               strTemp = strTemp & "      strSQL = strSQL & "" And " & strColumnName & " >= "" & strSymbol & Format(udt" & strTableName & "." & strHeadInfo & strColumnName & ", ""yyyy-mm-dd 00:00:00"") & strSymbol" & vbCrLf
               strTemp = strTemp & "      strSQL = strSQL & "" And " & strColumnName & " <= "" & strSymbol & Format(udt" & strTableName & "." & strHeadInfo & strColumnName & ", ""yyyy-mm-dd 23:59:59"") & strSymbol" & vbCrLf
               strTemp = strTemp & "   End If" & vbCrLf
         
            Case "str"
               strTemp = strTemp & "   If Len(udt" & strTableName & "." & strHeadInfo & strColumnName & ") > 0 Then" & vbCrLf
               strTemp = strTemp & "      strSQL = strSQL & "" And " & strColumnName & " Like '%"" & udt" & strTableName & "." & strHeadInfo & strColumnName & " & ""%'""" & vbCrLf
               strTemp = strTemp & "   End If" & vbCrLf

            Case "dbl", "sng"
               strTemp = strTemp & "   If (udt" & strTableName & "." & strHeadInfo & strColumnName & " > NULL_INTEGER + 10 ^ -NULL_FLOAT_EPSINON) and (udt" & strTableName & "." & strHeadInfo & strColumnName & " < NULL_INTEGER - 10 ^ -NULL_FLOAT_EPSINON) Then" & vbCrLf
               strTemp = strTemp & "      strSQL = strSQL & "" And " & strColumnName & " = "" & udt" & strTableName & "." & strHeadInfo & strColumnName & vbCrLf
               strTemp = strTemp & "   End If" & vbCrLf

            Case "lng", "int", "byt", "bln"
               strTemp = strTemp & "   If udt" & strTableName & "." & strHeadInfo & strColumnName & " <> NULL_INTEGER Then" & vbCrLf
               strTemp = strTemp & "      strSQL = strSQL & "" And " & strColumnName & " = "" & udt" & strTableName & "." & strHeadInfo & strColumnName & vbCrLf
               strTemp = strTemp & "   End If" & vbCrLf
            
            Case Else '"var"
               strTemp = strTemp & "   If Len(udt" & strTableName & "." & strHeadInfo & strColumnName & ") > 0 Then" & vbCrLf
               strTemp = strTemp & "      strSQL = strSQL & "" And " & strColumnName & " Like '%"" & udt" & strTableName & "." & strHeadInfo & strColumnName & " & ""%'""" & vbCrLf
               strTemp = strTemp & "   End If" & vbCrLf

         End Select
      End If
   Next
'   strTemp = strTemp & "   strSQL = strSQL & vbCrLf"
   strTemp = strTemp & "   GetFindSQL = strSQL" & vbCrLf
   strTemp = strTemp & "End Function" & vbCrLf & vbCrLf

   CreateGetFindSQL = strTemp
End Function

Private Function CreateTranceferSymbo() As String

   Dim strTemp As String
   
   strTemp = ""
   strTemp = strTemp & "Private Sub TranceferSymbo(ByVal vvarFieldValue As Variant, _" & vbCrLf
   strTemp = strTemp & "                              ByRef rstrSymbo As String, _" & vbCrLf
   strTemp = strTemp & "                              ByRef rstrFieldValue As String)" & vbCrLf
   strTemp = strTemp & "   Dim strTypeName As String" & vbCrLf & vbCrLf

   strTemp = strTemp & "   strTypeName = TypeName(vvarFieldValue)" & vbCrLf & vbCrLf

   strTemp = strTemp & "   Select Case strTypeName" & vbCrLf
   strTemp = strTemp & "      Case ""Date""" & vbCrLf
   strTemp = strTemp & "         rstrFieldValue = Format(vvarFieldValue, ""yyyy-mm-dd hh:nn:ss"")" & vbCrLf
   strTemp = strTemp & "         rstrSymbo = GetDateSymbo(DatabaseType)" & vbCrLf
   strTemp = strTemp & "      Case ""String""" & vbCrLf
   strTemp = strTemp & "         rstrFieldValue = vvarFieldValue" & vbCrLf
   strTemp = strTemp & "         rstrSymbo = ""'""" & vbCrLf
   strTemp = strTemp & "      Case Else" & vbCrLf
   strTemp = strTemp & "         rstrFieldValue = CStr(vvarFieldValue)" & vbCrLf
   strTemp = strTemp & "         rstrSymbo = """"" & vbCrLf
   strTemp = strTemp & "   End Select" & vbCrLf
   strTemp = strTemp & "End Sub"
   
   CreateTranceferSymbo = strTemp
End Function

Private Function GetColumnTypeInfoHead(ColumnTemp As Column) As String
   Dim strColumnTypeInfo As String

   Select Case ColumnTemp.Type
      Case adDate, adDBDate, adDBTime, adDBTimeStamp
         strColumnTypeInfo = "dtm"
      Case adCurrency
         strColumnTypeInfo = "cur"
      Case adDouble
         strColumnTypeInfo = "dbl"
      Case adInteger
         strColumnTypeInfo = "lng"
      Case adSingle
         strColumnTypeInfo = "sng"
      Case adSmallInt
         strColumnTypeInfo = "int"
      Case adChar, adVarChar, adLongVarChar, adWChar, adVarWChar, adLongVarWChar
         strColumnTypeInfo = "str"
      Case adBoolean
         strColumnTypeInfo = "bln"
      Case adUnsignedTinyInt
         strColumnTypeInfo = "byt"
      Case Else
         strColumnTypeInfo = "var"
   End Select

   GetColumnTypeInfoHead = strColumnTypeInfo
End Function