clsgetdatabase.cls

VB代码生成器

   Else
      mrst.Open "Select * From [" & vstrTableName & "] Where 1=0", mcnn
   End If
   
   strAutoIncrement = "(None)"
   For Each fld In mrst.Fields
      If fld.Properties("IsAutoIncrement") Then
         strAutoIncrement = fld.Name
         Exit For
      End If
   Next fld
   mrst.Close
   
   If Not mobjVCCppFile.GetCppFileString(vstrProjectName, SelectedTable(vstrTableName), strAutoIncrement, strVCCppString, rlngErrNum, rstrErrDescr) Then
      Err.Raise rlngErrNum, , rstrErrDescr
   End If
   GetVCCppString = strVCCppString
   
   Err.Clear
GetVCCppStringErr:
   rlngErrNum = Err.Number
   rstrErrDescr = Err.Description
End Function

Public Function GetStructString(ByVal vstrTableName As String, _
                                 Optional ByRef rlngErrNum As Long = 0, _
                                 Optional ByRef rstrErrDescr As String = "") As String
   Dim objTable As Table
   Dim strStructString As String
   
   On Error GoTo GetStructStringErr
   
   strStructString = mobjBuildStruct.BuildStruct(SelectedTable(vstrTableName))
   GetStructString = strStructString
   
   Err.Clear
GetStructStringErr:
   rlngErrNum = Err.Number
   rstrErrDescr = Err.Description
End Function

Public Function GetTableString(ByVal vstrProject As String, _
                              ByVal vstrTableName As String, _
                              Optional ByVal vblnView As Boolean = True, _
                              Optional ByRef rlngErrNum As Long = 0, _
                              Optional ByRef rstrErrDescr As String = "") As String
   Dim objTable As Table
   Dim fld As Field
   Dim strTableString As String
   Dim strAutoIncrement As String
   
   On Error GoTo GetTableStringErr
   
   If UCase(Left(mcnn.Provider, 7)) = "MSDAORA" Then
      mrst.Open "Select * From " & vstrTableName & " Where 1=0", mcnn
   Else
      mrst.Open "Select * From [" & vstrTableName & "] Where 1=0", mcnn
   End If
   
   strAutoIncrement = "(None)"
   For Each fld In mrst.Fields
      If fld.Properties("IsAutoIncrement") Then
         strAutoIncrement = fld.Name
         Exit For
      End If
   Next fld
   mrst.Close
   
   If Not mobjVBTableClass.GetTableString(vstrProject, SelectedTable(vstrTableName), strAutoIncrement, strTableString, vblnView, rlngErrNum, rstrErrDescr) Then
      Err.Raise rlngErrNum, , rstrErrDescr
   End If
   GetTableString = strTableString
   
   Err.Clear
GetTableStringErr:
   rlngErrNum = Err.Number
   rstrErrDescr = Err.Description
End Function

Public Function GetProcedureString(ByVal vstrProjectName As String, _
                                 Optional ByVal vstrProcedureName As String = "", _
                                 Optional ByVal vblnView As Boolean = True, _
                                 Optional ByRef rlngErrNum As Long = 0, _
                                 Optional ByRef rstrErrDescr As String = "") As String
   Dim arrlngParamDirection() As Long, arrstrParamName() As String, arrlngParamType() As Long
   Dim strStoreProcedure As String, strConnectionClass As String
   
   Dim I As Long, lngCount As Long
   On Error GoTo GetProcedureStringErr
   
   mcmd.CommandText = vstrProcedureName
   lngCount = mcmd.Parameters.Count
   If lngCount > 0 Then
      ReDim arrlngParamDirection(lngCount - 1)
      ReDim arrstrParamName(lngCount - 1)
      ReDim arrlngParamType(lngCount - 1)
      
      For I = 0 To lngCount - 1
         arrlngParamDirection(I) = mcmd.Parameters(I).Direction
         arrstrParamName(I) = mcmd.Parameters(I).Name
         arrlngParamType(I) = mcmd.Parameters(I).Type
      Next I
   End If
   
   If Len(vstrProcedureName) <> 0 Then
      strStoreProcedure = mobjVBConnectionTest.GetStoreProcedure(vstrProcedureName, arrlngParamDirection, arrstrParamName, arrlngParamType)
   End If

   strConnectionClass = ""
   If vblnView Then
      If Not mobjVBConnectionTest.GetConnectionClass(vstrProjectName, strConnectionClass, vblnView, True, rlngErrNum, rstrErrDescr) Then
         Err.Raise rlngErrNum, , rstrErrDescr
      End If
   End If
   GetProcedureString = strConnectionClass & strStoreProcedure
   
   Err.Clear
GetProcedureStringErr:
   rlngErrNum = Err.Number
   rstrErrDescr = Err.Description
End Function

Private Sub GetParamProperty(ByVal vstrProcedureName As String, _
                              ByRef rarrlngParamDirection() As Long, _
                              ByRef rarrstrParamName() As String, _
                              ByRef rarrlngParamType() As Long)
   Dim I As Long, lngCount As Long
   
   mcmd.CommandText = vstrProcedureName
   lngCount = mcmd.Parameters.Count
   If lngCount > 0 Then
      ReDim rarrlngParamDirection(lngCount - 1)
      ReDim rarrstrParamName(lngCount - 1)
      ReDim rarrlngParamType(lngCount - 1)
      
      For I = 0 To lngCount - 1
         rarrlngParamDirection(I) = mcmd.Parameters(I).Direction
         rarrstrParamName(I) = mcmd.Parameters(I).Name
         rarrlngParamType(I) = mcmd.Parameters(I).Type
      Next I
   End If
   
End Sub

Public Function GetConnectionHeadProc(ByVal vstrProjectName As String, _
                                 ByVal vstrProcedureName As String, _
                                 Optional ByRef rlngErrNum As Long = 0, _
                                 Optional ByRef rstrErrDescr As String = "") As String
   Dim arrlngParamDirection() As Long, arrstrParamName() As String, arrlngParamType() As Long
   Dim strStoreProcedure As String
   
   On Error GoTo GetConnectionHeadProcErr
   Call GetParamProperty(vstrProcedureName, arrlngParamDirection, arrstrParamName, arrlngParamType)
   
   strStoreProcedure = mobjVCConnectionHead.GetStoreProcedure(vstrProcedureName, arrlngParamDirection, arrstrParamName, arrlngParamType)
   
   GetConnectionHeadProc = strStoreProcedure
   
   Err.Clear
GetConnectionHeadProcErr:
   rlngErrNum = Err.Number
   rstrErrDescr = Err.Description
End Function

Public Function GetConnectionHead(ByVal vstrProjectName As String) As String
   GetConnectionHead = mobjVCConnectionHead.GetConnectionHead(vstrProjectName)
End Function

Public Function GetConnectionHeadTail() As String
   GetConnectionHeadTail = mobjVCConnectionHead.GetConnectionHeadTail
End Function

Public Function GetConnectionCPP(ByVal vstrProjectName As String) As String
   GetConnectionCPP = mobjVCConnectionCPP.GetConnectionCPP(vstrProjectName)
End Function

Public Function GetConnectionCPPProc(ByVal vstrProcedureName As String) As String
   Dim arrlngParamDirection() As Long, arrstrParamName() As String, arrlngParamType() As Long
   Dim strStoreProcedure As String
   
   Call GetParamProperty(vstrProcedureName, arrlngParamDirection, arrstrParamName, arrlngParamType)
   
   strStoreProcedure = mobjVCConnectionCPP.GetStoreProcedure(vstrProcedureName, arrlngParamDirection, arrstrParamName, arrlngParamType)
   
   GetConnectionCPPProc = strStoreProcedure
End Function

Public Function AddNode(ByRef robjTreeView As TreeView, _
                         ByVal vstrKeyName As String, _
                         ByVal vstrText As String, _
                         ByRef FatherNode As Node, _
                         Optional vstrImage As String = "Table") As Node
   On Error GoTo ErrHandle
   
   If FatherNode Is Nothing Then
      Set AddNode = robjTreeView.Nodes.Add(, _
                                      , _
                                      vstrKeyName, _
                                      vstrText, _
                                      vstrImage, _
                                      vstrImage)
   Else
      Set AddNode = robjTreeView.Nodes.Add(FatherNode, _
                                      tvwChild, _
                                      vstrKeyName, _
                                      vstrText, _
                                      vstrImage, _
                                      vstrImage)
   End If
   AddNode.Checked = True
   
   Exit Function
ErrHandle:
   vstrKeyName = vstrKeyName & Timer
   Resume
End Function

Public Function DeleteAllNode(ByRef robjTreeView As TreeView, _
                           Optional ByRef rlngErrNum As Long, _
                           Optional ByRef rstrErrDescr As String) As Boolean
   Dim I As Long, lngCount As Long
   
   On Error GoTo DeleteAllNodeErr
   DeleteAllNode = False
   
   lngCount = mcolTables.Count
   For I = lngCount To 1 Step -1
      mcolTables.Remove I
   Next I
   
   If robjTreeView.Nodes.Count > 0 Then
   
      
      robjTreeView.Nodes.Remove 1
      
      If Not DeleteAllNode(robjTreeView, rlngErrNum, rstrErrDescr) Then
      
         Err.Raise rlngErrNum, , rstrErrDescr
      End If
   End If
   
   
   DeleteAllNode = True
   
   Err.Clear
DeleteAllNodeErr:
   rlngErrNum = Err.Number
   rstrErrDescr = Err.Description
   
End Function

'Public Function SelectedRecordset(Optional ByVal Item As Long, _
'                              Optional ByVal Key As String, _
'                              Optional ByRef rlngErrNum As Long, _
'                              Optional ByRef rstrErrDescr As String) As ADODB.Recordset
'   On Error GoTo SelectedTableErr
'   Dim objTable As ADODB.Recordset
'
'   Set SelectedRecordset = Nothing
'
'   Set objTable = mcolRecordSet(Key)
'
'   Set SelectedRecordset = objTable
'
'   Err.Clear
'SelectedTableErr:
'   rlngErrNum = Err.Number
'   rstrErrDescr = Err.Description
'
'End Function

Private Function SelectedTable(Optional ByVal Key As String) As Table
   Dim objTable As Table
   
   Set SelectedTable = Nothing
   
   Set objTable = mcolTables(Key)
   
   Set SelectedTable = objTable
   
End Function
'
'Private Sub CheckUdlFile(ByVal vstrUdlFileName As String, ByVal vblnIsReSet As Boolean)
'   Dim SEI As SHELLEXECUTEINFO
'   Dim blnIsReSet As Boolean, lngState As Long
'   Dim strConnection As String
'   Dim pId As Long, pHnd As Long
'
'   On Error GoTo CheckUdlFileErr
'   blnIsReSet = vblnIsReSet
'   If Dir(vstrUdlFileName) = "" Then
'      Open vstrUdlFileName For Output As #1
'      Close #1
'      blnIsReSet = True
'   End If
'
'   lngState = mobjCnn.State
'   If (Not blnIsReSet) And (lngState = adStateClosed) Then
'      strConnection = "File Name=" & vstrUdlFileName
'      mobjCnn.Open strConnection
'   End If
'
'   If blnIsReSet Then
'      With SEI
'         .cbSize = Len(SEI)
'         .fMask = SEE_MASK_NOCLOSEPROCESS
'         .hWnd = 0
'         .lpVerb = vbNullChar
'         .lpFile = vstrUdlFileName
'         .lpParameters = vbNullChar
'         .lpDirectory = vbNullChar
'         .nShow = 0
'         .hInstApp = 0
'         .lpIDList = 0
'      End With
'      If ShellExecuteEx(SEI) <> 0 Then
'         WaitForSingleObject SEI.hProcess, INFINITE '等待结束
'         CloseHandle SEI.hProcess
'      Else
'         On Error GoTo 0
'         Err.Raise vbObjectError + 1, , "请手动打开数据源文件进行数据链接：" & vbCrLf & CurDir & "\" & vstrUdlFileName
'      End If
'   End If
'
'   Exit Sub
'CheckUdlFileErr:
'   blnIsReSet = True
'   Resume Next
'End Sub

Private Sub Class_Initialize()
'   Set mcolRecordSet = New Collection
   Set mcolTables = New Collection
   Set mrst = New ADODB.Recordset
   Set mcmd = New ADODB.Command
   Set mobjVBTableClass = New clsVBTableClass
   Set mobjBuildStruct = New clsBuildStruct
   Set mobjVBConnectionTest = New clsVBConnectionTest
   Set mobjVCCppFile = New clsVCCppFile
   Set mobjVCHeadFile = New clsVCHeadFile
   Set mobjVCConnectionHead = New clsVCConnectionHead
   Set mobjVCConnectionCPP = New clsVCConnectionCPP
End Sub

Private Sub Class_Terminate()
'   Set mcolRecordSet = Nothing
   On Error Resume Next
   Set mobjBuildStruct = Nothing
   Set mobjVBTableClass = Nothing
   Set mobjVBConnectionTest = Nothing
   Set mobjVCCppFile = Nothing
   Set mobjVCHeadFile = Nothing
   Set mobjVCConnectionHead = Nothing
   Set mobjVCConnectionCPP = Nothing
   
   Set mcmd = Nothing
   If mrst.State <> adStateClosed Then
      mrst.Close
   End If
   Set mrst = Nothing
   
   If mcnn.State <> adStateClosed Then
      mcnn.Close
   End If
   Set mcnn = Nothing
   Set mcolTables = Nothing
End Sub