clsvbconnectiontest.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 = "clsVBConnectionTest"
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

Public Function GetConnectionClass(ByVal vstrProjectName As String, _
                              ByRef rstrClassString As String, _
                              Optional ByVal vblnView As Boolean = True, _
                              Optional ByVal vblnProcedureExist As Boolean = True, _
                              Optional ByRef rlngErrNum As Long = 0, _
                              Optional ByRef rstrErrDescr As String = "") As Boolean
   Dim strTemp As String
   On Error GoTo GetConnectionClassErr
   GetConnectionClass = False
   
   strTemp = ""
   If Not vblnView Then
      strTemp = strTemp & "VERSION 1.0 CLASS" & vbCrLf
      strTemp = strTemp & "BEGIN" & vbCrLf
      strTemp = strTemp & "  MultiUse = -1  'True" & vbCrLf
      strTemp = strTemp & "  Persistable = 0  'NotPersistable" & vbCrLf
      strTemp = strTemp & "  DataBindingBehavior = 0  'vbNone" & vbCrLf
      strTemp = strTemp & "  DataSourceBehavior = 0   'vbNone" & vbCrLf
      strTemp = strTemp & "  MTSTransactionMode = 0   'NotAnMTSObject" & vbCrLf
      strTemp = strTemp & "End" & vbCrLf
      strTemp = strTemp & "Attribute VB_Name = ""clsConnection""" & 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
   End If
   strTemp = strTemp & "Option Explicit" & vbCrLf & vbCrLf

   strTemp = strTemp & "Private mobjQDatabase As clsQDatabase" & vbCrLf
   If vblnProcedureExist Then
      strTemp = strTemp & "Private mcolParams As Collection" & vbCrLf
   End If
   strTemp = strTemp & "Private mstrDatabaseName As String" & vbCrLf & vbCrLf

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

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

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

   strTemp = strTemp & "Public Property Get CurrentDatabaseName() As String" & vbCrLf
      strTemp = strTemp & Space(3) & "CurrentDatabaseName = mstrDatabaseName" & vbCrLf
   strTemp = strTemp & "End Property" & vbCrLf & vbCrLf

   strTemp = strTemp & "Public Sub SetDatabaseName(Optional ByVal vstrDatabaseName As String = """ & vstrProjectName & """)" & vbCrLf
      strTemp = strTemp & Space(3) & "If Len(vstrDatabaseName) = 0 Then" & vbCrLf
         strTemp = strTemp & Space(6) & "Exit Sub" & vbCrLf
      strTemp = strTemp & Space(3) & "End If" & vbCrLf
      strTemp = strTemp & Space(3) & "mstrDatabaseName = vstrDatabaseName" & vbCrLf
   strTemp = strTemp & "End Sub" & vbCrLf & vbCrLf

   strTemp = strTemp & "Public Function OpenConnection(Optional ByVal vblnIsReSet As Boolean = True, _" & vbCrLf
                  strTemp = strTemp & Space(27) & "Optional ByVal vlngHwnd As Long = 0, _" & 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) & "OpenConnection = mobjQDatabase.QOpenConnection(mstrDatabaseName, vblnIsReSet, vlngHwnd, rlngErrNum, rstrErrDescr)" & vbCrLf
   strTemp = strTemp & "End Function" & vbCrLf & vbCrLf

   strTemp = strTemp & "Public Function CloseConnection() As Boolean" & vbCrLf
   strTemp = strTemp & "   CloseConnection = mobjQDatabase.QCloseConnection(mstrDatabaseName)" & vbCrLf
   strTemp = strTemp & "End Function" & vbCrLf & vbCrLf

   strTemp = strTemp & "Private Sub Class_Initialize()" & vbCrLf
   
   strTemp = strTemp & "   mstrDatabaseName = """ & vstrProjectName & """" & vbCrLf
   If vblnProcedureExist Then
      strTemp = strTemp & "   Set mcolParams = New Collection" & vbCrLf
   End If
   
   strTemp = strTemp & "   Set mobjQDatabase = New clsQDatabase" & vbCrLf
      strTemp = strTemp & Space(3) & "If ConnectionState <> adStateOpen Then" & vbCrLf
         strTemp = strTemp & Space(6) & "Call OpenConnection(False)" & vbCrLf
      strTemp = strTemp & Space(3) & "End If" & vbCrLf
   strTemp = strTemp & "End Sub" & vbCrLf & vbCrLf

   strTemp = strTemp & "Private Sub Class_Terminate()" & vbCrLf
   strTemp = strTemp & "   Set mobjQDatabase = Nothing" & vbCrLf
   
   If vblnProcedureExist Then
      strTemp = strTemp & "   Call ClearParams" & vbCrLf
      strTemp = strTemp & "   Set mcolParams = Nothing" & vbCrLf
   End If
   strTemp = strTemp & "End Sub" & vbCrLf & vbCrLf

   If vblnProcedureExist Then
      strTemp = strTemp & "Private Sub ClearParams()" & vbCrLf
      strTemp = strTemp & "   Dim I As Long, lngCount As Long" & vbCrLf
      strTemp = strTemp & "   lngCount = mcolParams.Count" & vbCrLf
      strTemp = strTemp & "   For I = lngCount To 1 Step -1" & vbCrLf
      strTemp = strTemp & "      mcolParams.Remove I" & vbCrLf
      strTemp = strTemp & "   Next I" & vbCrLf
      strTemp = strTemp & "End Sub" & vbCrLf & vbCrLf
   End If
   
   rstrClassString = strTemp
   GetConnectionClass = True
   Err.Clear
GetConnectionClassErr:
   rlngErrNum = Err.Number
   rstrErrDescr = Err.Description
End Function

Public Function GetStoreProcedure(ByVal vstrProcedureName As String, _
                                    ByRef arrlngParamDirection() As Long, _
                                    ByRef arrstrParamName() As String, _
                                    ByRef arrlngParamType() As Long) As String
   Dim strTemp As String
   Dim I As Long, lngCount As Long
   Dim strParamDirection As String, strParamName As String, strParamType As String, strTypeHead As String
   Dim strAddParams As String, strReturnParams As String
   
   strTemp = ""
   strAddParams = ""
   strTemp = strTemp & "Public Function Exe_" & vstrProcedureName & "("
   
   lngCount = GetArrElementNb(arrstrParamName)
   For I = 0 To lngCount - 1
      strParamDirection = GetParamDirection(arrlngParamDirection(I))
      strParamName = GetParamName(arrstrParamName(I))
      Call GetParamType(arrlngParamType(I), arrlngParamDirection(I), strParamType, strTypeHead)
      
      strTemp = strTemp & strParamDirection & " " & strTypeHead & strParamName & " As " & RTrim(strParamType) & ", "  '_" & vbCrLf
      If I Mod 10 = 0 Or I = lngCount - 1 Then
         strTemp = strTemp & "_" & vbCrLf & Space(27)
      End If
      
      strAddParams = strAddParams & Space(6) & ".Add " & strTypeHead & strParamName & ", """ & strTypeHead & strParamName & """" & vbCrLf
      
      If Left(strTypeHead, 1) = "r" Then
'         strReturnParams = strReturnParams & Space(3) & strTypeHead & strParamName & " = mcolParams(""" & strTypeHead & strParamName & """)" & vbCrLf
         strReturnParams = strReturnParams & Space(3) & strTypeHead & strParamName & " = mcolParams(" & I + 1 & ")" & vbCrLf
      End If
   Next I
   
   If Right(strTemp, 27) <> Space(27) Then
      strTemp = strTemp & Space(27)
   End If
   
   strTemp = strTemp & "Optional ByRef robjRst As ADODB.Recordset, _" & 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) & "Call ClearParams" & vbCrLf
   strTemp = strTemp & Space(3) & "With mcolParams" & vbCrLf
   strTemp = strTemp & strAddParams
   strTemp = strTemp & Space(3) & "End With" & vbCrLf & vbCrLf
   
   strTemp = strTemp & Space(3) & "Exe_" & vstrProcedureName & " = mobjQDatabase.QExecuteStoreProcedure(mstrDatabaseName, """ & vstrProcedureName & """, mcolParams, robjRst, rlngErrNum, rstrErrDescr)" & vbCrLf & vbCrLf
   
   strTemp = strTemp & strReturnParams
   strTemp = strTemp & "End Function" & vbCrLf & vbCrLf
   
   GetStoreProcedure = strTemp

End Function

Private Function GetParamDirection(ByVal vlngParamDirection As Long) As String
   Dim strParamDirection As String
   
   strParamDirection = "ByRef"
   
   If vlngParamDirection = adParamInput Then
      strParamDirection = "ByVal"
   End If
   
   GetParamDirection = strParamDirection
End Function

Private Function GetParamName(ByVal vstrParamName As String) As String
   Dim strParamName As String
   
   strParamName = Mid(vstrParamName, 2)
   
   GetParamName = strParamName
End Function

Private Sub GetParamType(ByVal vlngParamType As Long, ByVal vlngParamDirection As Long, ByRef rstrParamType As String, ByRef rstrTypeHead As String)
   Select Case vlngParamType
      Case adDate, adDBDate, adDBTime, adDBTimeStamp
         rstrTypeHead = "dtm"
         rstrParamType = "Date"
      Case adCurrency
         rstrTypeHead = "cur"
         rstrParamType = "Currency"
      Case adDouble
         rstrTypeHead = "dbl"
         rstrParamType = "Double"
      Case adInteger
         rstrTypeHead = "lng"
         rstrParamType = "Long"
      Case adSingle
         rstrTypeHead = "sng"
         rstrParamType = "Single"
      Case adSmallInt
         rstrTypeHead = "int"
         rstrParamType = "Integer"
      Case adChar, adVarChar, adLongVarChar, adWChar, adVarWChar, adLongVarWChar
         rstrTypeHead = "str"
         rstrParamType = "String"
      Case adBoolean
         rstrTypeHead = "bln"
         rstrParamType = "Boolean"
      Case adUnsignedTinyInt
         rstrTypeHead = "byt"
         rstrParamType = "Byte"
'      Case adNumeric
'         rstrTypeHead = "var"
'         rstrParamType = "Variant"
      Case Else
         rstrTypeHead = "var"
         rstrParamType = "Variant"
   End Select
   
   If vlngParamDirection = adParamInput Then
      rstrTypeHead = "v" & rstrTypeHead
   Else
      rstrTypeHead = "r" & rstrTypeHead
   End If
   
End Sub
'Enum DataTypeEnum
'{
'    adEmpty = 0,
'    adTinyInt = 16,
'    adSmallInt = 2,
'    adInteger = 3,
'    adBigInt = 20,
'    adUnsignedTinyInt = 17,
'    adUnsignedSmallInt = 18,
'    adUnsignedInt = 19,
'    adUnsignedBigInt = 21,
'    adSingle = 4,
'    adDouble = 5,
'    adCurrency = 6,
'    adDecimal = 14,
'    adNumeric = 131,
'    adBoolean = 11,
'    adError = 10,
'    adUserDefined = 132,
'    adVariant = 12,
'    adIDispatch = 9,
'    adIUnknown = 13,
'    adGUID = 72,
'    adDate = 7,
'    adDBDate = 133,
'    adDBTime = 134,
'    adDBTimeStamp = 135,
'    adBSTR = 8,
'    adChar = 129,
'    adVarChar = 200,
'    adLongVarChar = 201,
'    adWChar = 130,
'    adVarWChar = 202,
'    adLongVarWChar = 203,
'    adBinary = 128,
'    adVarBinary = 204,
'    adLongVarBinary = 205,
'    adChapter = 136,
'    adFileTime = 64,
'    adPropVariant = 138,
'    adVarNumeric = 139,
'    adArray = 8192
'};