VB代码生成器

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
   Call SetCapture(Me.hWnd)
   With ProgressBar1
      .Visible = True
      .Top = TreeTable.Top
      .Left = TreeTable.Width
      .Width = txtCode.Left - TreeTable.Width ' + 60
      .Height = TreeTable.Height
      .ZOrder 0
   End With
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
   On Error Resume Next
   MousePointer = vbSizeWE
   
   If GetCapture = Me.hWnd And x > 0 And x < Me.Width Then
      ProgressBar1.Left = x - ProgressBar1.Width / 3 ' - 30
   End If
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
   On Error Resume Next
   Call ReleaseCapture
   If ProgressBar1.Left < 0 Then
      ProgressBar1.Left = 0
   End If
   TreeTable.Width = ProgressBar1.Left
   With txtCode
      .Left = ProgressBar1.Left + 50
      .Width = Me.ScaleWidth - .Left
   End With
   ProgressBar1.Visible = False
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
   Static s_strKeypress As String * 15
   Dim strKeypress As String
   
   s_strKeypress = Chr(KeyAscii) & s_strKeypress
   strKeypress = StrReverse(s_strKeypress)
   
   Select Case True
      Case Right(strKeypress, 8) = "Register"
         Dim strSerialNumber As String
         strSerialNumber = InputBox("请输入目标计算机机内码：", "获取注册序列号")
         strSerialNumber = CStr(CLng(Val(strSerialNumber)) Xor &H59421549 Xor 59421549)
         MsgBox "目标计算机《代码生成器》的注册序列号为:" & vbCrLf & vbCrLf & strSerialNumber, vbInformation, "注册序列号"
         Clipboard.Clear
         Clipboard.SetText strSerialNumber
      
      Case Right(strKeypress, 15) = "EncryptionFiles"
         If mblnProductRegister Then
            Set mfrmEncryptionFiles = New frmEncryptionFiles
            mfrmEncryptionFiles.Show vbModal
            Set mfrmEncryptionFiles = Nothing
         End If
      
      Case Right(strKeypress, 8) = "Password"
         Call LoginIn
         
      Case Else
   End Select
End Sub

Private Sub Form_Resize()
   On Error Resume Next
   
   With TreeTable
      .Left = 0
      .Top = Toolbar1.Height
      .Width = Me.ScaleWidth / 5
      .Height = Me.ScaleHeight - .Top - StatusBar1.Height
   End With
   
   With txtCode
      .Top = TreeTable.Top
      .Left = TreeTable.Left + TreeTable.Width + 50
      .Width = Me.ScaleWidth - .Left
      .Height = TreeTable.Height
   End With
   
'   StatusBar1.Panels("Status").Width = Me.ScaleWidth - 500
End Sub

Private Sub cmdDelete_Click()
   Dim lngErrNum As Long, strErrDescr As String

   If MsgBox("真的要清除树吗？", vbQuestion + vbYesNo) = vbNo Then Exit Sub
   
   If Not mobjGetDatabase.DeleteAllNode(TreeTable, lngErrNum, strErrDescr) Then
      Err.Raise lngErrNum, , strErrDescr
   End If
End Sub

Private Sub cmdDelNode_Click()
   mnuDelNode_Click
End Sub

Private Sub cmdNew_Click()
   Dim lngErrNum As Long, strErrDescr As String
   On Error GoTo cmdNewErr
   
   If Not mobjGetDatabase.GetDatabaseInfo(TreeTable, Me.hWnd, lngErrNum, strErrDescr) Then
      Err.Raise lngErrNum, , strErrDescr
   End If
   
   TreeTable.Nodes("M1Manager").Selected = True
   Call TreeTableNodeClick(Nothing)
   
   Exit Sub
cmdNewErr:
      MsgBox strErrDescr & ":" & lngErrNum
End Sub

Private Sub cmdSaveFile_Click()
   Dim lngErrNum As Long, strErrDescr As String
   On Error GoTo ErrHandle
   
   mlngVBVCCode = -1
   mfrmSaveFile.txtVbpFile = mstrDatabaseName
   mfrmSaveFile.Show vbModal
   
   If mlngVBVCCode = -1 Then Exit Sub
   
   Me.MousePointer = vbHourglass
   
   If mlngVBVCCode <> 1 Then
      mobjGetDatabase.FileFolder = mstrFilePath & "VBCode"
      If Dir(mstrFilePath & "VBCode", vbDirectory) = "" Then
         MkDir mstrFilePath & "VBCode"
      End If
      If mobjGetDatabase.SaveFileVB(TreeTable, mblnCreateLib, mblnCreateLibResource, mstrFileName, lngErrNum, strErrDescr) Then
         MsgBox "VB Code 文件保存完毕！", vbInformation, "VB Code"
      Else
         MsgBox lngErrNum & "# " & strErrDescr
      End If
   End If
   
   If mlngVBVCCode <> 0 Then
      mobjGetDatabase.FileFolder = mstrFilePath & "VCCode"
      If Dir(mstrFilePath & "VCCode", vbDirectory) = "" Then
         MkDir mstrFilePath & "VCCode"
      End If
      If mobjGetDatabase.SaveFileVC(TreeTable, mblnCreateLib, mblnCreateLibResource, mstrFileName, lngErrNum, strErrDescr) Then
         MsgBox "VC Code 文件保存完毕！", vbInformation, "VC Code"
      Else
         MsgBox lngErrNum & "# " & strErrDescr
      End If
   End If
   
   Me.MousePointer = vbDefault

   ShellExecute Me.hWnd, "Open", mstrFilePath, vbNullString, vbNullString, SW_MAXIMIZE
   Exit Sub
   
ErrHandle:
   MsgBox Err.Description
End Sub

Private Sub WriteSerialNumber(ByVal vlngSerialNumber As Long)
   On Error GoTo ErrHandle
   FileCopy mstrAppPath & App.EXEName & ".exe", mstrAppPath & "~" & App.EXEName & ".msh"

   Open mstrAppPath & "~" & App.EXEName & ".msh" For Binary Access Write As #1
      Put #1, LOF(1) - 4, vlngSerialNumber
   Close #1

   Exit Sub
ErrHandle:
End Sub

Private Function GetSerialNumber() As Long
   Dim lngSerialNumber As Long

   Open mstrAppPath & App.EXEName & ".exe" For Binary Access Read As #1
      Get #1, LOF(1) - 4, lngSerialNumber
   Close #1

   GetSerialNumber = lngSerialNumber
End Function

Private Sub ProductRegister()
   On Error GoTo ErrHandle
'   On Error Resume Next
   
   Dim objFSO As FileSystemObject
   Dim lngSerialNumber As Long, lngInput As Long, lngDriveSerialNumber As Long, strSerialNumber As String
   Set objFSO = New FileSystemObject
   lngDriveSerialNumber = objFSO.GetDrive("C:\").SerialNumber
   Set objFSO = Nothing
   
   lngSerialNumber = lngDriveSerialNumber Xor 59421549
   mblnProductRegister = False
   If lngSerialNumber = GetSerialNumber Then
      mblnProductRegister = True
   Else
      If (GetKeyState(vbKeyCapital) = 1 And _
         GetKeyState(vbKeyNumlock) = 1 And _
         GetKeyState(vbKeyScrollLock) = 1) Then '免注册
         mblnProductRegister = True
      Else '需注册
         strSerialNumber = CStr(lngDriveSerialNumber Xor &H59421549)
         lngInput = CLng(Val(InputBox("本机机内码为 " & strSerialNumber & "，请凭此机内码向作者索取产品注册序列号。" & vbCrLf & vbCrLf & "请输入产品注册序列号:", "产品注册", strSerialNumber)))
         
         If lngInput = lngSerialNumber Then
            mblnProductRegister = True
         End If
      End If
      
      If mblnProductRegister Then
         MsgBox "感谢您的注册！现在重新启动本系统。", vbInformation, "注册成功"
         Call WriteSerialNumber(lngSerialNumber)
         Call WriteBatAndReset
      End If
   End If
   
ErrHandle:
   If Err.Number <> 0 And Len(Err.Description) > 0 Then
      MsgBox "产品注册序列号输入错误!", vbExclamation, "注册出错"
      Call ShellExecute(0, "Open", "mailto:[e-mail]?Subject=索取《代码生成器》产品注册序列号(" & strSerialNumber & ")", 0, 0, 0)
   End If
   
   Me.Caption = "代码生成器" & IIf(mblnProductRegister, "", " [未注册]")
   mnuProductRegister.Visible = Not mblnProductRegister
   mnu_1.Visible = Not mblnProductRegister
End Sub

Private Sub LoginIn()
   On Error Resume Next
   
   Set mfrmLogin = New frmLogin
   mfrmLogin.LoginOnStart = True
   mintSucceeded = 0
   mfrmLogin.Show vbModal
   If mintSucceeded = 0 Then
      Set mfrmLogin = Nothing
      Unload Me
   ElseIf mintSucceeded = -1 Then
      Call WriteBatAndReset
   End If
   Set mfrmLogin = Nothing
End Sub

Private Sub Form_Load()
   On Error Resume Next
   
   mstrAppPath = App.Path
   mstrAppPath = IIf(Right(mstrAppPath, 1) = "\", mstrAppPath, mstrAppPath & "\")
   SetAttr mstrAppPath & "runbat.bat", vbNormal
   Kill mstrAppPath & "runbat.bat"
   SetAttr mstrAppPath & App.EXEName & ".msh", vbNormal
   
   mblnProductRegister = False
   Call ProductRegister
   Call LoginIn
   
   Set mobjGetDatabase = New clsGetDatabase
   Set mfrmSaveFile = New frmSaveFile
   mobjGetDatabase.FileFolder = "C:\"
   mblnWatchVB = True
   Toolbar1.Buttons("VBClass").Value = tbrPressed
   
   Dim NodeTemp As Node
   Set NodeTemp = mobjGetDatabase.AddNode(TreeTable, "M1Manager", "服务器数据库 【未指定】", Nothing, "Manager")
   NodeTemp.Expanded = True
   Call mobjGetDatabase.AddNode(TreeTable, "T2Table", "表", NodeTemp, "Table")
   Call mobjGetDatabase.AddNode(TreeTable, "V2View", "视图", NodeTemp, "View")
   Call mobjGetDatabase.AddNode(TreeTable, "P2Procedure", "存储过程", NodeTemp, "Procedure")
   
   txtCode.Text = vbCrLf & Space(8) & "选择一个数据库后，在左边栏选择一个""表""、""视图""或""存储过程""，这里将显示预览相应的代码。"
   TreeTable.Nodes("M1Manager").Selected = True
   Call TreeTableNodeClick(Nothing)
End Sub

Private Sub Form_Unload(Cancel As Integer)
   On Error Resume Next
   Set mobjGetDatabase = Nothing
   Unload mfrmSaveFile
   Set mfrmSaveFile = Nothing
   End
End Sub

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

Private Sub mfrmEncryptionFiles_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
   DoEvents
End Sub

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

Private Sub mfrmLogin_LoginSucceeded(ByVal vintSucceeded As Integer)
   mintSucceeded = vintSucceeded
End Sub

Private Sub mfrmSaveFile_CreateCodeFile(ByVal vlngCodeType As Long, ByVal vstrFilePath As String, ByVal vstrFileName As String, ByVal vblnCreateLib As Boolean, ByVal vblnCreateLibResource As Boolean)
   mlngVBVCCode = vlngCodeType
   mstrFilePath = vstrFilePath
   mstrFileName = vstrFileName
   mstrDatabaseName = vstrFileName
   mblnCreateLib = vblnCreateLib
   mblnCreateLibResource = IIf(mblnProductRegister, vblnCreateLibResource, False)
   Call TreeTableNodeClick(Nothing)
End Sub

Private Sub mfrmSaveFile_ReSet()
   Call WriteBatAndReset
End Sub

Private Sub WriteBatAndReset()
   Dim strBat As String
   Dim I As Long
'   strBat = "del " & App.EXEName & ".exe" & vbCrLf & _
'            "ren ~" & App.EXEName & ".exe" & " " & App.EXEName & ".exe" & vbCrLf & _
'            App.EXEName & ".exe"
   strBat = "@echo off" & vbCrLf
   For I = 0 To 800
      strBat = strBat & "echo 啊啊啊啊啊啊啊啊啊啊啊啊啊啊啊啊啊啊啊啊啊啊啊啊啊啊啊啊啊啊" & vbCrLf
   Next I
   strBat = strBat & "del " & App.EXEName & ".exe" & vbCrLf & _
                     "attrib ~" & App.EXEName & ".msh -h" & vbCrLf & _
                     "ren ~" & App.EXEName & ".msh" & " " & App.EXEName & ".exe" & vbCrLf & _
                     App.EXEName & ".exe"
            
   Open mstrAppPath & "runbat.bat" For Output As #1
      Print #1, strBat
   Close #1
   SetAttr mstrAppPath & "runbat.bat", vbHidden
'   DoEvents
   ShellExecute 0, "Open", "runbat.bat", vbNullString, mstrAppPath, SW_HIDE ' SW_MAXIMIZE '
   Unload Me
   End
End Sub

Private Sub mnuAbout_Click()
'   ShellAbout Me.hWnd, "代码生成器", "陈顺球", Me.Icon
   ShellAbout Me.hWnd, "代码生成器", "版权所有：陈顺球(LionCSQ) & 寻百安(XunBaian)", Me.Icon
End Sub

Private Sub mnuClear_Click()
   Call cmdDelete_Click
End Sub