codelib.frm

用VB作的程序电子书

If Pic5.BackColor = 0 Then 'database dirty
    Msbox "The database is dirty and should be saved..." & vbCr & vbCr & "Save the Database ?", Title, mbYesNo, mbQuestion
    If MBReturn = 1 Then End
    SaveLib
End If
End
End Sub

Private Sub Form_Resize()
On Error Resume Next
CodeLib.Move (Screen.Width / 2) - (CodeLib.Width / 2), (Screen.Height / 2) - (CodeLib.Height / 2), 10590, 7065
End Sub

Private Sub List1_Click()
SSTab1.Tab = 0
Idx1 = List1.ListIndex
For xx = 0 To 2
Label1(xx).Caption = Label2.Caption & " " & List1.List(Idx1)
Text1(xx).Text = CLdata(xx + 2, List1.ItemData(Idx1))
Next xx
If CLdata(3, List1.ItemData(Idx1)) <> "" Then
Pic7.Visible = True
Label7.Visible = True
Else
Pic7.Visible = False
Label7.Visible = False
End If
If CLdata(4, List1.ItemData(Idx1)) <> "" Then
Pic8.Visible = True
Label8.Visible = True
Else
Pic8.Visible = False
Label8.Visible = False
End If
Text1(3).Text = Text1(0).Text 'copy to editbox
Label1(3).Caption = "Edit Code for: " & List1.List(Idx1)
Pic2.BackColor = RGB(192, 192, 192)
Pic3.BackColor = RGB(192, 192, 192)
Pic4.BackColor = RGB(192, 192, 192)

End Sub

Private Sub mnuCopyCode_Click()
If Text1(0).Text = "" Then
    Msbox "No Code selected", Title, mbOkonly, mbInfo
    Exit Sub
End If
Clipboard.Clear
Clipboard.SetText Text1(0).Text
Label5.Caption = "Clipboard filled with " & List1.List(Idx1)

End Sub

Private Sub mnuKillCode_Click()
If Text1(0).Text = "" Then
    Msbox "No Code selected", Title, mbOkonly, mbInfo
    Exit Sub
End If
Msbox "You want to delete the Code " & List1.List(Idx1) & " in the category " & Label2.Caption & vbCr & "Also the helpfile and notes will be deleted from the database..." & vbCr & vbCr & "Are you sure about this ?", Title, mbYesNo, mbQuestion
If MBReturn = 1 Then Exit Sub
KillEntry
End Sub

Private Sub mnuMoveCode_Click()
If Text1(0).Text = "" Then
Msbox "No Code selected...", Title, mbOkonly, mbInfo
Exit Sub
End If
Move1.Label1.Caption = "Move the selected Code:" & vbCr & List1.List(List1.ListIndex)
Move1.Show 1
End Sub

Private Sub mnuPrintCod_Click()
If Text1(0).Text = "" Then
    Msbox "No Code selected", Title, mbOkonly, mbInfo
    Exit Sub
End If
If SSTab1.Tab = 2 Or SSTab1.Tab = 3 Then
Msbox "No printing here...", Title, mbOkonly, mbInfo
Exit Sub
End If
If SSTab1.Tab = 1 And Text1(1).Text = "" Then
    Msbox "No Helpfile present...", Title, mbOkonly, mbInfo
    Exit Sub
End If
If SSTab1.Tab = 0 Then Msbox "Print Code of the " & List1.List(Idx1) & " ?", Title, mbYesNo, mbQuestion
If SSTab1.Tab = 1 Then Msbox "Print helpfile of the " & List1.List(Idx1) & " ?", Title, mbYesNo, mbQuestion
If MBReturn = 1 Then Exit Sub 'No selected
'OK ! Print !
Msbox "Turn on the printer...", Title, mbPrintNoWay, mbPrint
If MBReturn = 1 Then Exit Sub
Printer.FontSize = 10
Printer.Print
Printer.Print
Printer.CurrentX = 1000
Printer.Print Label1(SSTab1.Tab).Caption
Printer.Print
Printer.Print Text1(SSTab1.Tab).Text
Printer.EndDoc
End Sub

Private Sub mnuRenameCode_Click()
If Text1(0).Text = "" Then
Msbox "No Code selected...", Title, mbOkonly, mbInfo
Exit Sub
End If
key72:
InBox "Rename the Code: " & vbCr & CLdata(1, List1.ItemData(Idx1)), CLdata(1, List1.ItemData(Idx1)), Title
If IbReturn = "" Then Exit Sub 'exit
    For xx = 0 To 999
    If LCase(Trim(IbReturn)) = LCase(CLdata(1, xx)) Then
    Msbox "This Codename already exists !", Title, mbOkonly, mbCritical
    xx = 999
    GoTo key72
    End If
    Next xx
RenameCode
End Sub

Private Sub pic1_GotFocus()
Combo1.Text = "Category"
End Sub

Private Sub List1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    YPos = Y \ TH + List1.TopIndex
        If YPos < List1.ListCount Then
        Label4.Caption = "(" & CatIdx & ") " & List1.List(YPos)
        Else
        Label4.Caption = ""
        End If
End Sub

Private Sub Text1_LostFocus(Index As Integer)
If Index = 1 And Pic2.BackColor = 0 Then
Pic2.BackColor = RGB(192, 192, 192)
Pic5.BackColor = 0
    If CLdata(3, List1.ItemData(Idx1)) <> "" Then
    Pic7.Visible = True
    Label7.Visible = True
    Else
    Pic7.Visible = False
    Label7.Visible = False
    End If

Label6.Caption = "Database dirty"
CLdata(3, List1.ItemData(Idx1)) = Text1(1).Text
End If

If Index = 2 And Pic3.BackColor = 0 Then 'notes dirty
Pic3.BackColor = RGB(192, 192, 192)
Pic5.BackColor = 0
    If CLdata(4, List1.ItemData(Idx1)) <> "" Then
    Pic8.Visible = True
    Label8.Visible = True
    Else
    Pic8.Visible = False
    Label8.Visible = False
    End If
Label6.Caption = "Database dirty"
CLdata(4, List1.ItemData(Idx1)) = Text1(2).Text
End If

If Index = 3 And Pic4.BackColor = 0 Then 'Edit code dirty
Msbox "The Code has been changed !" & vbCr & vbCr & "Do you want to replace the actual Code with the new one ?" & vbCr & vbCr & "Note that the changed Code can not be tested !", Title, mbOKCancel, mbQuestion
Pic4.BackColor = RGB(192, 192, 192)
    If MBReturn = 1 Then 'cancel selected
    Text1(3).Text = CLdata(2, List1.ItemData(Idx1))
    Pic4.BackColor = RGB(192, 192, 192)
    Exit Sub
    End If
    'Ok ! Copy everything
    CLdata(2, List1.ItemData(Idx1)) = Text1(3).Text
    Text1(0).Text = Text1(3).Text
    Pic5.BackColor = 0
    Label6.Caption = "Database dirty"
End If

End Sub

Private Sub SSTab1_Click(PreviousTab As Integer)
T3D CodeLib, Label10, 3, T3dNone
Label10.Caption = " Lines of text: " & GetLineCount(Text1(SSTab1.Tab)) & " "
T3D CodeLib, Label10, 3, T3dRaiseRaise
Pic1.SetFocus
DoEvents
On Error Resume Next
If CLdata(3, List1.ItemData(Idx1)) <> "" Then
Pic7.Visible = True
Label7.Visible = True
Else
Pic7.Visible = False
Label7.Visible = False
End If
If CLdata(4, List1.ItemData(Idx1)) <> "" Then
Pic8.Visible = True
Label8.Visible = True
Else
Pic8.Visible = False
Label8.Visible = False
End If

If SSTab1.Tab <> 0 And Text1(0).Text = "" Then
SSTab1.Tab = 0
Msbox "Cannot acces Help, Notes or Edit !" & vbCr & "There's no Code selected !", Title, mbOkonly, mbInfo
End If
    
If SSTab1.Tab = 3 Then 'Edit code
Text1(3).SetFocus
End If

End Sub

Private Sub SSTab1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Label4.Tag <> "" Then Exit Sub
If SSTab1.Tab = 0 Then Label4.Caption = "View Code"
If SSTab1.Tab = 1 Then Label4.Caption = "View/Add/Edit Helpfiles"
If SSTab1.Tab = 2 Then Label4.Caption = "View/Add/Edit Notes"
If SSTab1.Tab = 3 Then Label4.Caption = "Edit Code"

End Sub

Private Sub Text1_Change(Index As Integer)
If Index = 1 Then Pic2.BackColor = 0
If Index = 2 Then Pic3.BackColor = 0
If Index = 3 Then Pic4.BackColor = 0
If Text1(0).Text = "" Then
Label10.Caption = ""
Else
Label10.Caption = " Lines of text: " & GetLineCount(Text1(Index)) & " "
End If
End Sub

Private Sub Text1_GotFocus(Index As Integer)
On Error Resume Next
If Index = 0 Then Pic1.SetFocus
End Sub

Private Sub Text1_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)

   Dim lRetVal As Long
    If Button = vbRightButton Then
        lRetVal = SendMessage(Me.hwnd, WM_RBUTTONDOWN, 0, 0)
  If Index <> 0 Then Exit Sub
  If Text1(0) = "" Then Exit Sub
       Call PopupMenu(mnuCode, 4)
    End If
End Sub

Private Sub Text1_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
If Label4.Tag <> "" Then Exit Sub
If Index = 0 Then Label4.Caption = "Code Window"
If Index = 1 Then Label4.Caption = "Help Window"
If Index = 2 Then Label4.Caption = "Notes Window"
If Index = 3 Then Label4.Caption = "Edit Code Window"
End Sub

Private Sub Toolbar1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Label4.Tag <> "" Then Exit Sub
Label4.Caption = ""
If X > 0 And X < 870 Then Label4.Caption = "Save Database"
If X > 885 And X < 1755 Then Label4.Caption = "Print Code/Helpfile"
If X > 1890 And X < 2760 Then Label4.Caption = "Copy to Clipboard"
If X > 2775 And X < 3645 Then Label4.Caption = "Remove Code/Help/Notes"
If X > 3660 And X < 4530 Then Label4.Caption = "Rename selected Code"
If X > 4545 And X < 5415 Then Label4.Caption = "Move selected Code"
If X > 5550 And X < 6420 Then Label4.Caption = "Add new Category"
If X > 6435 And X < 7305 Then Label4.Caption = "Rename selected Category"
If X > 7320 And X < 8190 Then Label4.Caption = "Remove selected Category"
If X > 8325 And X < 9195 Then Label4.Caption = "Search Code/Helpfiles"
If X > 9330 And X < 10200 Then Label4.Caption = "Help on the CodeLib"

End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Pic1.SetFocus
DoEvents
Select Case Button.Key

Case "key3" 'Code to clipboard
mnuCopyCode_Click
'---------------------
Case "key4" 'Delete code
mnuKillCode_Click
'---------------------
Case "key1" 'save database
If Pic5.BackColor <> 0 Then
Msbox "The database has not been changed, so there's no need to save it...", Title, mbOkonly, mbInfo
Exit Sub
End If
Msbox "Save the database ?", Title, mbYesNo, mbQuestion
If MBReturn = 1 Then Exit Sub 'No
SaveLib
Pic5.BackColor = RGB(192, 192, 192)
Label6.Caption = "Database clear"
'---------------------
Case "key2" 'print out code
mnuPrintCod_Click
'---------------------
Case "key5" 'new category
Cat1.Text1.Text = "New Category"
Cat1.Text1.SelLength = Len(Cat1.Text1.Text)
Cat1.Command1.Enabled = False
Cat1.Show 1
'---------------------
Case "key6" 'Rename category
If Label2.Caption = "" Then
Msbox "No category selected...", Title, mbOkonly, mbInfo
Exit Sub
End If
key62:
InBox "Rename the category: " & vbCr & Cat(CatIdx), Cat(CatIdx), Title
If IbReturn = "" Then Exit Sub 'exit
    For xx = 0 To 99
    If LCase(Trim(IbReturn)) = LCase(Cat(xx)) Then
    Msbox "This category already exists !", Title, mbOkonly, mbCritical
    xx = 99
    GoTo key62
    End If
    Next xx
Label2.Caption = Format(CatIdx, "00") & "  " & IbReturn
Cat(CatIdx) = IbReturn
'save categories
On Error GoTo SaveCat2
ff = FreeFile
Open App.Path & "\Data\Cat.ini" For Output As #ff
For xx = 0 To 99
If Cat(xx) = "" Then Exit For
Print #ff, Cat(xx)
Next xx
Close #ff
LoadCat
Exit Sub
SaveCat2:
Close #ff
Msbox "There's an error while" & vbCr & "saving the Category-data..." & vbCr & vbCr & "Error: " & Err & "  " & Err.Description, Title, mbOkonly, mbCritical
Exit Sub
'---------------------
Case "key7" 'rename code
mnuRenameCode_Click
'---------------------
Case "key8" 'Search code
Search.Show 1
'---------------------
Case "key10" 'Move code to another category
mnuMoveCode_Click
'---------------------
Case "key11" 'kill category
If Label2.Caption = "" Then
Msbox "No category selected...", Title, mbOkonly, mbInfo
Exit Sub
End If
For xx = 0 To 999
If CLdata(0, xx) = CatIdx And CLdata(1, xx) <> "" Then
Msbox "This Category '" & Cat(CatIdx) & "' is not empty. You can only remove empty Categories...", Title, mbOkonly, mbCritical
Exit Sub
End If
Next xx
Msbox "Are you sure to remove the selected Category '" & Cat(CatIdx) & "' ?", Title, mbYesNo, mbQuestion
If MBReturn = 1 Then Exit Sub 'No
Cat(CatIdx) = ""
'save categories
On Error GoTo SaveCat3
ff = FreeFile
Open App.Path & "\Data\Cat.ini" For Output As #ff
For xx = 0 To 99
'If Cat(xx) = "" Then Exit For
Print #ff, Cat(xx)
Next xx
Close #ff
LoadCat
Label2.Caption = ""
Label9.Caption = ""
Exit Sub
SaveCat3:
Close #ff
Msbox "There's an error while" & vbCr & "saving the Category-data..." & vbCr & vbCr & "Error: " & Err & "  " & Err.Description, Title, mbOkonly, mbCritical
Exit Sub
'---------------------
Case "key9" 'Helpfiles
HelpScreen.Show 1
End Select
End Sub