clsgetdatabase.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 = "clsGetDatabase"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'**********************************************************************
'**  功能描述: 代码生成器主控制模块
'**
'**  作    者: 陈顺球(LionCSQ)
'**  创建时间: 2005 年 09 月 08 日
'**-------------------------------------------------------------------
'**
'**  改进人员: 寻百安(XunBaian)
'**  改进日期: 2005 年 09 月 15 日

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

Option Explicit

Public Event GetDatabaseName(ByVal vstrDatabaseName As String)
Public Event SaveProgressValue(ByVal vlngValue As Long)
Public Event SaveProgressMax(ByVal vlngMax As Long)
Public Event SaveProgressEnd()

Private mobjCat As New ADOX.Catalog
Private mcnn As ADODB.Connection
Private mrst As ADODB.Recordset
Private mcmd As ADODB.Command

Private mobjBuildStruct As clsBuildStruct
Private mobjVBTableClass As clsVBTableClass
Private mobjVBConnectionTest As clsVBConnectionTest

Private mobjVCCppFile As clsVCCppFile
Private mobjVCHeadFile As clsVCHeadFile
Private mobjVCConnectionHead As clsVCConnectionHead
Private mobjVCConnectionCPP As clsVCConnectionCPP
Private mstrFolder As String '欲保存的文件名
Private mstrDatabaseName As String
Private mcolTables As Collection ', mcolRecordSet As Collection

Public Property Let FileFolder(ByVal vstrFolder As String)
   mstrFolder = vstrFolder
End Property

Public Function GetDatabaseInfo(ByRef robjTreeView As TreeView, _
                              ByVal vlngHWND As Long, _
                                Optional ByRef rlngErrNum As Long, _
                                Optional ByRef rstrErrDescr As String) As Boolean
   
   Dim NodeTemp As Node
'   Dim lngTableCount As Long
   Static objDataLinks As DataLinks
   
   On Error GoTo GetDatabaseInfoErr
   Dim strTableType As String
   GetDatabaseInfo = False
   
   ' 打开连接
   Set objDataLinks = New DataLinks
   objDataLinks.hWnd = vlngHWND
   Set mcnn = objDataLinks.PromptNew
   If mcnn Is Nothing Then
      Err.Raise vbObjectError, , "没有连接数据源"
   End If
'   Call objDataLinks.PromptEdit(mcnn)
   mcnn.Open
   
   ' 打开目录
   Set mobjCat.ActiveConnection = mcnn
   Set mcmd.ActiveConnection = mcnn
   mcmd.CommandType = adCmdStoredProc
   
   Dim objTable As Table
   Dim objColumn As Column

   If Not DeleteAllNode(robjTreeView, rlngErrNum, rstrErrDescr) Then

      Err.Raise rlngErrNum, , rstrErrDescr
   End If
   
   Dim strDatabase As String
   strDatabase = mcnn.Properties("Data Source").Value
   If Left(mcnn.Provider, 8) = "SQLOLEDB" Then
      mstrDatabaseName = mcnn.Properties("Initial Catalog").Value
      strDatabase = strDatabase & "." & mstrDatabaseName
   Else
      Dim lngSlashSpace As Long, lngDotSpace As Long, lngLenth As Long
      lngLenth = Len(strDatabase)
      lngSlashSpace = InStrRev(strDatabase, "\", lngLenth, vbTextCompare)
      lngDotSpace = InStrRev(strDatabase, ".", lngLenth, vbTextCompare)
      mstrDatabaseName = Mid(strDatabase, lngSlashSpace + 1, lngDotSpace - lngSlashSpace - 1)
   End If
   RaiseEvent GetDatabaseName(mstrDatabaseName)
   
   Set NodeTemp = AddNode(robjTreeView, "M1Manager", "服务器数据库 【" & mcnn.Provider & "】⊕【" & strDatabase & "】", Nothing, "Manager")
   NodeTemp.Expanded = True
   Call AddNode(robjTreeView, "T2Table", "表", NodeTemp, "Table")
   Call AddNode(robjTreeView, "V2View", "视图", NodeTemp, "View")
   Call AddNode(robjTreeView, "P2Procedure", "存储过程", NodeTemp, "Procedure")

   For Each objTable In mobjCat.Tables
      strTableType = StrConv(objTable.Type, vbProperCase)
      If strTableType = "Table" Or strTableType = "View" Then
         Set NodeTemp = AddNode(robjTreeView, Left(strTableType, 1) & "3" & objTable.Name, objTable.Name, robjTreeView.Nodes.Item(Left(strTableType, 1) & "2" & strTableType), strTableType)
         
         For Each objColumn In objTable.Columns
            Call AddNode(robjTreeView, "F4" & objTable.Name & "." & objColumn.Name, objColumn.Name, NodeTemp, "Field")
         Next objColumn
         
         mcolTables.Add objTable, objTable.Name
      End If
   Next objTable
   
   Dim objProcedure As Procedure
   Dim strParamName As String
   Dim I As Long, lngCount As Long
   
   For Each objProcedure In mobjCat.Procedures
      Dim str As String
      str = objProcedure.Name
      str = Left(str, Len(str) - 2)
      If Left(str, 3) <> "dt_" Then
         Set NodeTemp = AddNode(robjTreeView, "P3" & str, str, robjTreeView.Nodes.Item("P2Procedure"), "Procedure")
         mcmd.CommandText = str
         lngCount = mcmd.Parameters.Count
         If lngCount > 0 Then
            For I = 0 To lngCount - 1
               strParamName = mcmd.Parameters(I).Name
               Call AddNode(robjTreeView, "F4" & objProcedure.Name & "." & strParamName, strParamName, NodeTemp, "Field")
            Next I
         End If
      End If
   Next objProcedure
   
   GetDatabaseInfo = True
   
   Err.Clear
GetDatabaseInfoErr:
   Set objDataLinks = Nothing
   rlngErrNum = Err.Number
   rstrErrDescr = Err.Description
   
End Function

Public Function SaveFileVC(ByVal vobjTreeView As TreeView, _
                        Optional ByVal vblnCreateLib As Boolean = False, _
                        Optional ByVal vblnCreateLibResource As Boolean, _
                        Optional ByVal vstrProjectName As String = "", _
                        Optional ByRef rlngErrNum As Long, _
                        Optional ByRef rstrErrDescr As String) As Boolean
                        
   Dim tmpNode As Node
   Dim fld As Field, strAutoIncrement As String
   Dim strTempNodeKey As String, strNodeKeyHead As String
   Dim strCppFile As String, strHeadFile As String
   Dim strConnectionCPP As String, strConnectionHead As String
   Dim I As Long, lngCount As Long
   
   On Error GoTo SaveFileVCErr
   SaveFileVC = False

   If vstrProjectName = "" Then
      vstrProjectName = "NewProject"
   End If
   
   If Right(mstrFolder, 1) <> "\" Then
      mstrFolder = mstrFolder & "\"
   End If
   
   strConnectionCPP = ""
   strConnectionCPP = GetConnectionCPP(vstrProjectName)
   lngCount = vobjTreeView.Nodes.Count
   RaiseEvent SaveProgressMax(lngCount)
   For I = 1 To lngCount
'   For Each tmpNode In vobjTreeView.Nodes
      Set tmpNode = vobjTreeView.Nodes(I)
      strNodeKeyHead = Left(tmpNode.Key, 2)
      
      If Right(strNodeKeyHead, 1) = "3" Then
         strTempNodeKey = UCase(Left(strNodeKeyHead, 1))
         If strTempNodeKey = "T" Or strTempNodeKey = "V" Then
            
            strHeadFile = GetVCHeadString(vstrProjectName, tmpNode.Text, rlngErrNum, rstrErrDescr)
            If rlngErrNum <> 0 And rstrErrDescr <> "" Then
               Err.Raise rlngErrNum, , rstrErrDescr
            End If
            If Not WriteCodeFile(mstrFolder & tmpNode.Text & ".h", strHeadFile, "iOutput", rlngErrNum, rstrErrDescr) Then
               Err.Raise rlngErrNum, , rstrErrDescr
            End If
            
            strCppFile = GetVCCppString(vstrProjectName, tmpNode.Text, rlngErrNum, rstrErrDescr)
            If rlngErrNum <> 0 And rstrErrDescr <> "" Then
               Err.Raise rlngErrNum, , rstrErrDescr
            End If
            If Not WriteCodeFile(mstrFolder & tmpNode.Text & ".cpp", strCppFile, "iOutput", rlngErrNum, rstrErrDescr) Then
               Err.Raise rlngErrNum, , rstrErrDescr
            End If
            
         ElseIf strTempNodeKey = "P" Then
            strConnectionHead = strConnectionHead & GetConnectionHeadProc(vstrProjectName, tmpNode.Text, rlngErrNum, rstrErrDescr)
            If rlngErrNum <> 0 And rstrErrDescr <> "" Then
               Err.Raise rlngErrNum, , rstrErrDescr
            End If
            
            strConnectionCPP = strConnectionCPP & GetConnectionCPPProc(tmpNode.Text)
         End If
      End If
      RaiseEvent SaveProgressValue(I)
   Next I
   
   strConnectionHead = GetConnectionHead(vstrProjectName) & strConnectionHead & GetConnectionHeadTail
   If Not WriteCodeFile(mstrFolder & "DataConnection.h", strConnectionHead, "iOutput", rlngErrNum, rstrErrDescr) Then
      Err.Raise rlngErrNum, , rstrErrDescr
   End If
   
   If Not WriteCodeFile(mstrFolder & "DataConnection.cpp", strConnectionCPP, "iOutput", rlngErrNum, rstrErrDescr) Then
      Err.Raise rlngErrNum, , rstrErrDescr
   End If
   
   If vblnCreateLib Then
      Call ResDataToFile("VCQDATABASE", "DLL", mstrFolder & "\Dynamic Link Library\", "QDatabase.dll")
      Call ResDataToFile("VCQDATABASE", "LIB", mstrFolder & "\Dynamic Link Library\", "QDatabase.lib")
      Call ResDataToFile("QDATABASE", "H", mstrFolder & "\Dynamic Link Library\", "QDatabase.h")
      If vblnCreateLibResource Then
         Call ResDataToFile("QDATABASE_VC", "ZIP", mstrFolder & "\Dynamic Link Library\", "QDatabase.zip")
      End If
   End If
   SaveFileVC = True
   
   Err.Clear
SaveFileVCErr:
   RaiseEvent SaveProgressEnd
   rlngErrNum = Err.Number
   rstrErrDescr = Err.Description
   
End Function

Public Function SaveFileVB(ByVal vobjTreeView As TreeView, _
                        Optional ByVal vblnCreateLib As Boolean = False, _
                        Optional ByVal vblnCreateLibResource As Boolean, _
                        Optional ByVal vstrProjectName As String = "", _
                        Optional ByRef rlngErrNum As Long, _
                        Optional ByRef rstrErrDescr As String) As Boolean
                        
   Dim arrlngParamDirection() As Long, arrstrParamName() As String, arrlngParamType() As Long
   Dim I As Long, lngCount As Long
   Dim blnProcedureExist As Boolean
   
   Dim tmpNode As Node
   Dim strNodeKeyHead As String, strTempNodeKey As String
   
   Dim strClassFile As String
   Dim strStructFile As String
   Dim strStructHeadInfo As String
   Dim strConnectionClass As String
   Dim strStoreProcedure As String
   
   On Error GoTo SaveFileVBErr
   SaveFileVB = False
   
   If vstrProjectName = "" Then
      vstrProjectName = "NewProject"
   End If
   
   If Right(mstrFolder, 1) <> "\" Then
      mstrFolder = mstrFolder & "\"
   End If
   
   strStructHeadInfo = mobjBuildStruct.FileHeadInfo("clsDictionary")
   
   blnProcedureExist = False
   lngCount = vobjTreeView.Nodes.Count
   RaiseEvent SaveProgressMax(lngCount)
   For I = 1 To lngCount
'   For Each tmpNode In vobjTreeView.Nodes
      Set tmpNode = vobjTreeView.Nodes(I)
      strNodeKeyHead = Left(tmpNode.Key, 2)
      
      If Right(strNodeKeyHead, 1) = "3" Then
         strTempNodeKey = UCase(Left(strNodeKeyHead, 1))
         If strTempNodeKey = "T" Or strTempNodeKey = "V" Then
            strClassFile = GetTableString(vstrProjectName, tmpNode.Text, False, rlngErrNum, rstrErrDescr)
         
            If Not WriteCodeFile(mstrFolder & "cls" & tmpNode.Text & ".cls", strClassFile, "iOutput", rlngErrNum, rstrErrDescr) Then
               Err.Raise rlngErrNum, , rstrErrDescr
            End If
            
            strStructFile = strStructFile & GetStructString(tmpNode.Text)
            
         ElseIf strTempNodeKey = "P" Then
            strStoreProcedure = strStoreProcedure & GetProcedureString(vstrProjectName, tmpNode.Text, False, rlngErrNum, rstrErrDescr)
            blnProcedureExist = True
         End If
      End If
      RaiseEvent SaveProgressValue(I)
   Next I
   
   strStructFile = strStructHeadInfo & strStructFile
   If Not WriteCodeFile(mstrFolder & "clsDictionary.cls", strStructFile, "iOutput", rlngErrNum, rstrErrDescr) Then
      Err.Raise rlngErrNum, , rstrErrDescr
   End If
   
   If mobjVBConnectionTest.GetConnectionClass(vstrProjectName, strConnectionClass, False, blnProcedureExist, rlngErrNum, rstrErrDescr) Then
      If Not WriteCodeFile(mstrFolder & "clsConnection.cls", strConnectionClass & strStoreProcedure, "iOutput", rlngErrNum, rstrErrDescr) Then
         Err.Raise rlngErrNum, , rstrErrDescr
      End If
   Else
      Err.Raise rlngErrNum, , rstrErrDescr
   End If
   
   If vblnCreateLib Then
      Call ResDataToFile("VBQDATABASE", "DLL", mstrFolder & "\ActiveX Dynamic Link Library\", "QDatabase.dll")
      Call ResDataToFile("VBQDATABASE", "LIB", mstrFolder & "\ActiveX Dynamic Link Library\", "QDatabase.lib")
      If vblnCreateLibResource Then
         Call ResDataToFile("QDATABASE_VB", "ZIP", mstrFolder & "\ActiveX Dynamic Link Library\", "QDatabase.zip")
      End If
   End If
   
   SaveFileVB = True
   
   Err.Clear
SaveFileVBErr:
   RaiseEvent SaveProgressEnd
   rlngErrNum = Err.Number
   rstrErrDescr = Err.Description
End Function

Public Function GetVCHeadString(ByVal vstrProjectName As String, _
                                 ByVal vstrTableName As String, _
                                 Optional ByRef rlngErrNum As Long = 0, _
                                 Optional ByRef rstrErrDescr As String = "") As String
   Dim objTable As Table
   Dim strVCHeadString As String
   
   On Error GoTo GetVCHeadStringErr
   
   If Not mobjVCHeadFile.GetHeadFileString(vstrProjectName, SelectedTable(vstrTableName), strVCHeadString, rlngErrNum, rstrErrDescr) Then
      Err.Raise rlngErrNum, , rstrErrDescr
   End If
   GetVCHeadString = strVCHeadString
   
   Err.Clear
GetVCHeadStringErr:
   rlngErrNum = Err.Number
   rstrErrDescr = Err.Description
End Function

Public Function GetVCCppString(ByVal vstrProjectName As String, _
                                 ByVal vstrTableName As String, _
                                 Optional ByRef rlngErrNum As Long = 0, _
                                 Optional ByRef rstrErrDescr As String = "") As String
   Dim fld As Field
   Dim objTable As Table
   Dim strVCCppString As String
   Dim strAutoIncrement As String
   On Error GoTo GetVCCppStringErr
   
   If UCase(Left(mcnn.Provider, 7)) = "MSDAORA" Then
      mrst.Open "Select * From " & vstrTableName & " Where 1=0", mcnn