VB代码生成器

Private Sub mnuCreateCode_Click()
   On Error GoTo ErrHandle
   
   If TreeTable.Nodes("M1Manager").Text = "服务器数据库 【未指定】" Then
      Call cmdNew_Click
   End If
   If TreeTable.Nodes("M1Manager").Text <> "服务器数据库 【未指定】" Then
      Call cmdSaveFile_Click
   End If
   
ErrHandle:
End Sub

Private Sub mnuDatabase_Click()
   Call Toolbar1_ButtonClick(Toolbar1.Buttons("Database"))
End Sub

Private Sub mnuDelNode_Click()
   If MsgBox("真的要删除该节点吗？", vbQuestion + vbYesNo) = vbNo Then Exit Sub
   
   If Not TreeTable.SelectedItem Is Nothing Then
      TreeTable.Nodes.Remove TreeTable.SelectedItem.Key
   End If
End Sub

Private Sub mnuExit_Click()
   Unload Me
End Sub

Private Sub mnuProductRegister_Click()
   Call ProductRegister
End Sub

Private Sub mobjGetDatabase_GetDatabaseName(ByVal vstrDatabaseName As String)
   mstrDatabaseName = vstrDatabaseName
End Sub

Private Sub mobjGetDatabase_SaveProgressEnd()
   ProgressBar1.Visible = False
End Sub

Private Sub mobjGetDatabase_SaveProgressMax(ByVal vlngMax As Long)
   With ProgressBar1
      .Left = 0
      .Top = TreeTable.Height + Toolbar1.Height ' + 30
      .Width = Me.ScaleWidth + 100
      .Height = StatusBar1.Height ' - 30
      .Visible = True
      .ZOrder 0
      .Value = 0
      .Max = vlngMax
   End With
End Sub

Private Sub mobjGetDatabase_SaveProgressValue(ByVal vlngValue As Long)
   ProgressBar1.Value = vlngValue
End Sub

Private Sub StatusBar1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
   MousePointer = vbDefault
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
   DoEvents
   Select Case Button.Key
      Case "Database"
         Call cmdNew_Click
      Case "CreateCode"
         Call mnuCreateCode_Click
      Case "VBClass"
         mblnWatchVB = True
         Call TreeTableNodeClick(Nothing)
      Case "VCCPP"
         mblnWatchVB = False
         Call TreeTableNodeClick(Nothing)
      Case "FormatCode"

         Call TreeTableNodeClick(Nothing)
      Case "Delete"
         Call mnuDelNode_Click
      Case "ClearTree"
         Call cmdDelete_Click
      Case "About"
         Call mnuAbout_Click
      Case "Exit"
         Unload Me
      Case Else
   End Select
End Sub

Private Sub Toolbar1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
   MousePointer = vbDefault
End Sub

Private Sub TreeTable_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
   MousePointer = vbDefault
End Sub

Private Sub TreeTable_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
   If Button = vbRightButton Then
      PopupMenu mnuOperat
   End If
End Sub

Private Sub TreeTable_NodeClick(ByVal Node As MSComctlLib.Node)
   If mintNodeIndex = Node.Index Then Exit Sub
   mintNodeIndex = Node.Index
   
   Call TreeTableNodeClick(Node)
End Sub

Private Sub TreeTableNodeClick(Optional ByVal Node As MSComctlLib.Node = Nothing)
   Dim strCode As String, lngLenth As Long
   Dim strNodeKey As String
   Dim strNewProjectName As String
   MousePointer = vbHourglass
   
   If Node Is Nothing Then
      Set Node = TreeTable.SelectedItem
      If Node Is Nothing Then Exit Sub
   End If
   
   strNewProjectName = IIf(Len(mstrDatabaseName) = 0, "[NewProject]", mstrDatabaseName)
   
   lngLenth = 0
   strNodeKey = Node.Key
   If Mid(strNodeKey, 2, 1) = "3" Then
      If mblnWatchVB Then
         If Left(strNodeKey, 1) = "T" Or Left(strNodeKey, 1) = "V" Then
            strCode = "Option Explicit" & vbCrLf & vbCrLf
            strCode = strCode & mobjGetDatabase.GetStructString(Node.Text)
            strCode = strCode & mobjGetDatabase.GetTableString(strNewProjectName, Node.Text, True)
         Else
            strCode = mobjGetDatabase.GetProcedureString(strNewProjectName, Node.Text)
            lngLenth = Len(strCode)
         End If
      Else
         If Left(strNodeKey, 1) = "T" Or Left(strNodeKey, 1) = "V" Then
            strCode = mobjGetDatabase.GetVCHeadString(strNewProjectName, Node.Text)
            strCode = strCode & mobjGetDatabase.GetVCCppString(strNewProjectName, Node.Text)
         Else
            strCode = mobjGetDatabase.GetConnectionHead(strNewProjectName)
            strCode = strCode & mobjGetDatabase.GetConnectionHeadProc(strNewProjectName, Node.Text)
            strCode = strCode & mobjGetDatabase.GetConnectionHeadTail & vbCrLf & vbCrLf
            
            strCode = strCode & mobjGetDatabase.GetConnectionCPP(strNewProjectName)
            strCode = strCode & mobjGetDatabase.GetConnectionCPPProc(Node.Text)
            lngLenth = Len(strCode)
         End If
      End If
   ElseIf Mid(strNodeKey, 2, 1) = "1" Then
      If mblnWatchVB Then
         strCode = mobjGetDatabase.GetProcedureString(strNewProjectName, , True)
      Else
         strCode = mobjGetDatabase.GetConnectionHead(strNewProjectName)
         strCode = strCode & mobjGetDatabase.GetConnectionHeadTail
         strCode = strCode & mobjGetDatabase.GetConnectionCPP(strNewProjectName)
      End If
   Else
      strCode = vbCrLf & Space(8) & "选择一个数据库后，在左边栏选择一个""表""、""视图""或""存储过程""，这里将显示预览相应的代码。"
   End If
   
   StatusBar1.Panels("Status").Text = Node.FullPath & "  → 【" & IIf(mblnWatchVB, "VB", "VC") & " Code 预览】"
   Call FormatRichTextBox(strCode)

   MousePointer = vbDefault
End Sub

Private Sub FormatRichTextBox(ByVal vstrCode As String)
   On Error Resume Next
   
   With RichTextBox1
      If Toolbar1.Buttons("FormatCode").Value = tbrPressed Then
         With ProgressBar1
            .Left = 0
            .Top = TreeTable.Height + Toolbar1.Height ' + 30
            .Width = Me.ScaleWidth + 100
            .Height = StatusBar1.Height ' - 30
            .Visible = True
            .ZOrder 0
            .Value = 0
            .Max = 82
         End With
         
         .Text = ""
         .Text = vstrCode
         mlngCodeLen = LenB(vstrCode)
         
         If mblnWatchVB Then
            Call FormatCodeVC
            Call FormatCodeVB
         Else
            Call FormatCodeVB
            Call FormatCodeVC
         End If
      
         ProgressBar1.Visible = False
         
      Else
         .Text = ""
         .Text = vstrCode
      End If
   
      .SelStart = 1
      .SelLength = Len(.Text)
      .SelIndent = 200
      txtCode.TextRTF = .TextRTF
   End With
End Sub

Private Sub FormatCodeVC()
   Call FormatCode("static")
   Call FormatCode("Const")
   Call FormatCode("CString")
   Call FormatCode("char")
   Call FormatCode("float")
   Call FormatCode("COleDateTime")
   Call FormatCode("bool")
   Call FormatCode("short")
   Call FormatCode("int")
   Call FormatCode("void")
   Call FormatCode("VARIANT")
   Call FormatCode("class")
   Call FormatCode("return")
   Call FormatCode("__stdcall")
   Call FormatCode("#endif")
   Call FormatCode("typedef")
   Call FormatCode("struct")
   Call FormatCode("virtual")
   Call FormatCode("#include")
   Call FormatCode("#ifndef")
   Call FormatCode("#define")
   Call FormatCode("#ifdef")
   Call FormatCode("#undef")
   Call FormatCode("#pragma once")
   Call FormatCode("#if")
   Call FormatCode("defined")
   Call FormatCode("__uuidof")
   Call FormatCode("try")
   Call FormatCode("catch")
   Call FormatNotes("//")
End Sub

Private Sub FormatCodeVB()
   Call FormatCode("Explicit")
   Call FormatCode("Call")
   Call FormatCode("Public")
   Call FormatCode("Private")
   Call FormatCode("Sub")
   Call FormatCode("End")
   Call FormatCode("Function")
   Call FormatCode("Dim")
   Call FormatCode("ReDim")
   Call FormatCode("Option")
   Call FormatCode("if")
   Call FormatCode("ByVal")
   Call FormatCode("ByRef")
   Call FormatCode("As")
   Call FormatCode("String")
   Call FormatCode("Long")
   Call FormatCode("Boolean")
   Call FormatCode("Integer")
   Call FormatCode("Single")
   Call FormatCode("Date")
   Call FormatCode("Variant")
   Call FormatCode("Double")
   Call FormatCode("Byte")
   Call FormatCode("Currency")
   Call FormatCode("Nothing")
   Call FormatCode("With")
   Call FormatCode("If")
   Call FormatCode("Then")
   Call FormatCode("Else")
   Call FormatCode("Select")
   Call FormatCode("Case")
   Call FormatCode("Optional")
   Call FormatCode("Set")
   Call FormatCode("Get")
   Call FormatCode("Let")
   Call FormatCode("Property")
   Call FormatCode("Exit")
   Call FormatCode("New")
   Call FormatCode("For")
   Call FormatCode("Next")
   Call FormatCode("False")
   Call FormatCode("True")
   Call FormatCode("Step")
   Call FormatCode("To")
   Call FormatCode("GoTo")
   Call FormatCode("Error")
   Call FormatCode("On")
   Call FormatCode("And")
   Call FormatCode("CStr(")
   Call FormatCode("Not")
   Call FormatCode("Empty")
   Call FormatCode("Type")
End Sub

Private Sub FormatNotes(ByVal vstrKey As String)
   Dim lngPlace As Long, lngVbcrlf As Long
   Dim lngKeyCount As Long
   lngKeyCount = Len(vstrKey)
   With RichTextBox1
      .SelStart = 0
      Do While lngPlace <> -1
            lngPlace = .Find(vstrKey, , mlngCodeLen - lngVbcrlf, rtfWholeWord)
            If lngPlace <> -1 Then
               .SelStart = lngPlace + 2
               lngVbcrlf = .Find(vbCrLf, , mlngCodeLen - lngPlace)
               .SelStart = lngPlace
               .SelLength = lngVbcrlf - lngPlace
               .SelColor = &H8000&
               .SelStart = lngVbcrlf
            End If
   '      DoEvents
      Loop
   End With
   ProgressBar1.Value = ProgressBar1.Value + 1
End Sub

Private Sub FormatCode(ByVal vstrKey As String)
   Dim lngPlace As Long, lngVbcrlf As Long
   Dim lngKeyCount As Long
   lngKeyCount = Len(vstrKey)
   With RichTextBox1
      .SelStart = 0
      Do While lngPlace <> -1
            lngPlace = .Find(vstrKey, , mlngCodeLen, rtfWholeWord)
            If lngPlace <> -1 Then
               .SelColor = vbBlue
               .SelStart = lngPlace + lngKeyCount
            End If
   '      DoEvents
      Loop
   End With
   ProgressBar1.Value = ProgressBar1.Value + 1
End Sub

Private Sub txtCode_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
   MousePointer = vbDefault
End Sub

'Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
'   Dim strSerialNumber As String
'
'   If KeyCode = vbKeyR And _
'      (Shift And vbCtrlMask) > 0 And _
'      (Shift And vbAltMask) > 0 Then
'      strSerialNumber = InputBox("请输入目标计算机机内码：", "获取注册序列号")
'      strSerialNumber = CStr(CLng(Val(strSerialNumber)) Xor &H59421549 Xor 59421549)
'      MsgBox "目标计算机《代码生成器》的注册序列号为:" & vbCrLf & vbCrLf & strSerialNumber, vbInformation, "注册序列号"
'      Clipboard.Clear
'      Clipboard.SetText strSerialNumber
'   End If
'End Sub