frmcodelib.frm

vb控件代码大全

'
    ExportCodeItems
End Sub

Private Sub mnuImport_Click()
'
' Import a list of codeitems at the selected Node
'
    ImportCodeItems
End Sub

Private Sub mnuOpenDatabase_Click()
'
' Open a different VBCodeLibrary Database
'
    SelectDataBase
End Sub

Private Sub mnuRename_Click()
'
' Change the Label - remember, we only allow 50 Characters
'
    tvCodeItems.StartLabelEdit
End Sub

Private Sub mnuSettings_Click()
'
' Show Application settings
'
    ShowSettings
End Sub

Private Sub mnuViewBookMarks_Click()
'
' View the Bookmarks control
'
    ShowBookmarks Not (mbShowBookmarks)
    mnuViewBookMarks.Checked = mbShowBookmarks
End Sub

Private Sub picSysBar_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
'
' Here's where we handle the Icon Tray Messages
'
    Dim lMsg As Long
    Static bInHere As Boolean
    
    On Error GoTo vbErrorHandler
    
    lMsg = x / Screen.TwipsPerPixelX
    
    If bInHere Then Exit Sub
    
    bInHere = True
    Select Case lMsg
        Case WM_LBUTTONDBLCLK:
'
' On Mouse DoubleClick - Restore the window
'
            On Error Resume Next
            Me.Show
            
            If Me.WindowState = vbMinimized Then
                Me.WindowState = vbDefault
            End If
            Me.ZOrder
    End Select
    
    bInHere = False
    
    Exit Sub
    
vbErrorHandler:
    MsgBox Err.Number & " " & Err.Description & "  " & Err.Source & " frmCodeLib::picSysBar_MouseMove", , App.ProductName
End Sub


Private Sub tbTools_ButtonClick(ByVal Button As ComctlLib.Button)
'
' Handle a toolbar button click
'
On Error GoTo vbErrorHandler

    Dim oNodeTarget As Node
    
    Select Case UCase$(Button.Tag)
        Case "OPENDB"
            SelectDataBase
        Case "PRINT", "FIND"
            MsgBox "This will be implemented in a later version", vbInformation, App.ProductName
                        
        Case "NEW"
            AddCode
        Case "VIEWBOOKMARKS"
            ShowBookmarks Not (mbShowBookmarks)
            
        Case "BOOKMARK"
            AddBookMark
            
        Case "DELETE"
            DeleteCodeItem
        
        Case "PREVIOUS"
            Set oNodeTarget = tvCodeItems.SelectedItem.Previous
            If Not (oNodeTarget Is Nothing) Then
                Set tvCodeItems.SelectedItem = oNodeTarget
                SelectCodeItem oNodeTarget.Key
            Else
                Set oNodeTarget = tvCodeItems.SelectedItem.Parent
                If Not (oNodeTarget Is Nothing) Then
                    Set tvCodeItems.SelectedItem = oNodeTarget
                    SelectCodeItem oNodeTarget.Key
                End If
            End If
        
        Case "NEXT"
            SendMessageLong tvCodeItems.hwnd, TVM_SELECTITEM, TVGN_NEXT, 0&
            Set oNodeTarget = tvCodeItems.SelectedItem.Next
            If Not (oNodeTarget Is Nothing) Then
                Set tvCodeItems.SelectedItem = oNodeTarget
                SelectCodeItem oNodeTarget.Key
            Else
                Set oNodeTarget = tvCodeItems.SelectedItem.Child
                If Not (oNodeTarget Is Nothing) Then
                    Set tvCodeItems.SelectedItem = oNodeTarget
                    SelectCodeItem oNodeTarget.Key
                End If

            End If
        
        Case "SETTINGS"
            ShowSettings
            
    End Select
    

    Exit Sub

vbErrorHandler:
    MsgBox Err.Number & " " & Err.Description & " " & Err.Source, "frmCodeLib::tbTools_ButtonClick", , App.ProductName

End Sub

Private Sub DeleteCodeItem()

On Error GoTo vbErrorHandler
 
    Dim sKey As String
    Dim oNode As Node
    Dim sMessage As String
    Dim iDO As IDataObject
    Dim oCodeItem As CCodeItem
    Dim oParentNode As Node
    Dim oWait As CWaitCursor
    
    Set oNode = tvCodeItems.SelectedItem
    
    sKey = oNode.Key
    
    If sKey = "ROOT" Then Exit Sub
        
    If oNode Is Nothing Then
        MsgBox "No Selected Record", , App.ProductName
        Exit Sub
    End If
    
    sMessage = "Delete selected Code "
    
    If oNode.Children > 0 Then
        sMessage = sMessage & "and all child records ?"
    Else
        sMessage = sMessage & "?"
    End If
    
    If MsgBox(sMessage, vbYesNo + vbExclamation, "Delete Code Record") = vbNo Then
        Exit Sub
    End If
    
    Set oParentNode = oNode.Parent
    
    Set oWait = New CWaitCursor
    oWait.SetCursor
    
    BeginTrans
    
    RecursiveDeleteCode oNode
    
    CommitTrans
    
    tvCodeItems.Nodes.Remove sKey
    
    ctlBookMarkList.Initialise mDB
    
    SelectCodeItem tvCodeItems.SelectedItem.Key
    
    If oParentNode.Children = 0 Then
       oParentNode.Expanded = False
        If Not oParentNode.Key = "ROOT" Then
            oParentNode.Image = "CHILD"
        End If
        
    End If
    
    Set oWait = Nothing
    
    Exit Sub

vbErrorHandler:
    Set oWait = Nothing
    
    Rollback
    MsgBox Err.Number & " " & Err.Description & " " & Err.Source & " frmCodeLib::DeleteCodeItem", , App.ProductName

End Sub

Private Sub tmrDragTimer_Timer()
    Dim nHitNode As Node
    Static lCount As Long
'
' This timer has two functions :
'
' 1 - It will scroll the TreeView when the user is dragging
'
' 2 - It will auto-expand a node when the user drags over it for more than
'     half a second.
'
' Both pieces of code stolen from the MDSN.
'

    If mnDragNode Is Nothing Then
        tmrDragTimer.Enabled = False
        Exit Sub
    End If
    
    lCount = lCount + 1
    If lCount > 10 Then
    
        Set nHitNode = tvCodeItems.DropHighlight
        If nHitNode Is Nothing Then Exit Sub
        
        If nHitNode.Expanded = False Then
            nHitNode.Expanded = True
        End If
        lCount = 0
    End If
    
    If miScrollDir <> 0 Then
        If miScrollDir = -1 Then
            SendMessageLong tvCodeItems.hwnd, WM_VSCROLL, 0, 0
        Else
            SendMessageLong tvCodeItems.hwnd, WM_VSCROLL, 1, 0
        End If
    End If
    
    
End Sub

Private Sub tvCodeItems_AfterLabelEdit(Cancel As Integer, NewString As String)
    Dim iDO As IDataObject
    Dim oCodeItem As CCodeItem
    Dim sKey As String

On Error GoTo vbErrorHandler

    If Len(NewString) = 0 Then
        MsgBox "You must enter some text for a description", vbInformation, App.ProductName
        Cancel = True
        Exit Sub
    End If
    
    Set iDO = New CCodeItem
    Set oCodeItem = iDO
    
    sKey = tvCodeItems.SelectedItem.Key
    sKey = Right$(sKey, Len(sKey) - 1)
    
    iDO.Initialise mDB, sKey
    oCodeItem.Description = NewString
    StatusBar1.Panels(1).Text = NewString
    
    iDO.Commit
    
    SelectCodeItem tvCodeItems.SelectedItem.Key
    
    Exit Sub

vbErrorHandler:

    MsgBox Err.Number & " " & Err.Description & " " & Err.Source & "frmCodeLib::tvCodeItems_AfterLabelEdit", , App.ProductName

End Sub

Private Sub tvCodeItems_BeforeLabelEdit(Cancel As Integer)
    Dim lEditHWND As Long
'
' Limit the text entry size to 50 characters (as defined in our database
'
    
'
' Get the handle of the Edit Box on the treeview
'
    lEditHWND = SendMessageLong(tvCodeItems.hwnd, TVM_GETEDITCONTROL, 0, 0)
'
' Now limit the size to 50 characters
'
    If lEditHWND > 0 Then
        SendMessageLong lEditHWND, EM_LIMITTEXT, 50, 0
    End If
    
End Sub

Private Sub tvCodeItems_Collapse(ByVal Node As ComctlLib.Node)
    If Not Node.Key = "ROOT" Then
        Node.Image = "FOLDER"
    End If
    StatusBar1.Panels(1).Text = Node.Text
End Sub

Private Sub tvCodeItems_Expand(ByVal Node As ComctlLib.Node)
    If Not Node.Key = "ROOT" Then
        Node.ExpandedImage = "OPENFOLDER"
    End If
    StatusBar1.Panels(1).Text = Node.Text
End Sub

Private Sub tvCodeItems_KeyUp(KeyCode As Integer, Shift As Integer)
'
' Check for Delete Key pressed (Delete) and Insert (addNew)
'
    If tvCodeItems.SelectedItem.Key <> "ROOT" Then
        If KeyCode = vbKeyDelete Then
            DeleteCodeItem
            Exit Sub
        End If
    End If
    
    If KeyCode = vbKeyInsert Then
        AddCode
    End If
    
End Sub

Private Sub tvCodeItems_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Set mnDragNode = tvCodeItems.HitTest(x, y)
End Sub

Private Sub tvCodeItems_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If mnDragNode Is Nothing Then Exit Sub
    
    If Button = vbLeftButton Then
        If mnDragNode.Key <> "ROOT" Then
'
' Start Dragging !
'
            Set tvCodeItems.SelectedItem = mnDragNode
            tmrDragTimer.Interval = 100
            tmrDragTimer.Enabled = True
            tvCodeItems.OLEDrag
        End If
    Else
        Set mnDragNode = Nothing
    End If
    
End Sub

Private Sub tvCodeItems_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim sKey As String
    Dim bIsRoot As Boolean
'
' Show Popup Menu
'
   
    If Button = vbRightButton Then
        bIsRoot = (StrComp(tvCodeItems.SelectedItem.Key, "ROOT", vbTextCompare) = 0)
        mnuRename.Enabled = Not (bIsRoot)
        mnuDeleteCode.Enabled = Not (bIsRoot)
        mnuBookMark.Enabled = Not (bIsRoot)
        PopupMenu mnuEdit
    End If
    
End Sub

Private Sub tvCodeItems_NodeClick(ByVal Node As ComctlLib.Node)
    SelectCodeItem Node.Key
End Sub

Private Sub DoToolBarLogic()
    Dim nNode As Node
    
    Set nNode = tvCodeItems.SelectedItem

    If nNode.Key = "ROOT" Then
        tbTools.Buttons("DELETE").Enabled = False
        tbTools.Buttons("BOOKMARK").Enabled = False
    Else
        tbTools.Buttons("DELETE").Enabled = True
        tbTools.Buttons("BOOKMARK").Enabled = True
    End If
    
End Sub

Private Sub InitControls()
'
' Make Toolbar Flat-Style
'

    Dim lStyle As Long
    Dim hToolbar As Long
    
    hToolbar = FindWindowEx(tbTools.hwnd, 0&, "ToolbarWindow32", vbNullString)
    
    lStyle = SendMessageLong(hToolbar, TB_GETSTYLE, 0&, 0&)
    
    If lStyle And TBSTYLE_FLAT Then
    '
    ' It's already flat
    '
    Else
        lStyle = lStyle Or TBSTYLE_FLAT
    End If
    
    SendMessageLong hToolbar, TB_SETSTYLE, 0, lStyle
    tbTools.Refresh
'
' Setup Track Select on the TreeView
'
    lStyle = GetWindowLong(tvCodeItems.hwnd, GWL_STYLE)
    
    lStyle = lStyle Or TVS_TRACKSELECT
    
    SetWindowLong tvCodeItems.hwnd, GWL_STYLE, lStyle
    
End Sub

Private Sub SelectCodeItem(ByVal sNodeKey As String)
    Dim iDO As IDataObject
    Dim sKey As String
    Dim oCodeItem As CCodeItem
'
' Select the relevant code item into our controls
'
    DoToolBarLogic
    
    If sNodeKey = "ROOT" Then
        ctlCodeItemDetails.Initialise mDB, Nothing
    Else
        Set iDO = New CCodeItem
        sKey = Right$(sNodeKey, Len(sNodeKey) - 1)
        iDO.Initialise mDB, sKey
        Set oCodeItem = iDO
        
'
' Setup our code window control
'
        StatusBar1.Panels(1).Text = oCodeItem.Description
        Set oCodeItem = Nothing
        
        ctlCodeItemDetails.Initialise mDB, iDO
'
' Setup our Bookmark list control
'
        ctlBookMarkList.FindBookmark tvCodeItems.SelectedItem.Text
        Set iDO = Nothing
    End If
    
End Sub

Private Sub GetLastDBName()
    Dim sDefaultDB As String
    Dim sDBName As String
'
' Get previously opened database name
'
    
    sDefaultDB = App.Path & "\" & DEFAULTDB
    
    sDBName = GetSetting("VBCodeLib", "Settings", "LastDB")
    
    If Len(sDBName) = 0 Then
        sDBName = sDefaultDB
        SaveSetting "VBCodeLib", "Settings", "LastDB", sDBName