frmcodelib.frm

vb控件代码大全

    End If
    
    If Len(Dir$(sDBName)) > 0 Then
        msDBFileName = sDBName
    Else
        msDBFileName = ""
    End If

End Sub

Private Sub DoStartUp()
'
' Get settings
'
    Dim sDBName As String
    

    Me.Left = GetSetting("VBCodeLib", "Settings", "MainLeft", 2055)
    Me.Top = GetSetting("VBCodeLib", "Settings", "MainTop", 2175)
    Me.Width = GetSetting("VBCodeLib", "Settings", "MainWidth", 11000)
    Me.Height = GetSetting("VBCodeLib", "Settings", "MainHeight", 6210)
    tvCodeItems.Width = GetSetting("VBCodeLib", "Settings", "TreeWidth", 3270)
    mbShowBookmarks = GetSetting("VBCodeLib", "Settings", "ViewBookMarks", True)
'
' Turn off delete & bookmark tools
'
    tbTools.Buttons("DELETE").Enabled = False
    tbTools.Buttons("BOOKMARK").Enabled = False
            
'
' Check that the user wants to backup the database
' at startup
'
    If Not (moSettings.BackupDatabaseAtStart) Then
        Exit Sub
    End If
    
    sDBName = App.Path & "\codebackup.mdb"
'
' Kill the backup if it already exists
'
    If Len(Dir$(sDBName)) > 0 Then
        Kill sDBName
    End If
    
    If Len(msDBFileName) = 0 Then
        MsgBox "Cannot find the last opened database : " & msDBFileName, vbInformation, App.ProductName
    Else
        DBEngine.CompactDatabase msDBFileName, sDBName
    End If
    
    
    Exit Sub

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

End Sub

Private Sub DoUnload()
    Dim sBackupName As String
    Dim sDBName As String
    
    On Error GoTo vbErrorHandler
'
' Save settings if required
'
    If moSettings.SaveFormLayout Then
        If Me.WindowState <> vbMinimized Then
            SaveSetting "VBCodeLib", "Settings", "MainLeft", Me.Left
            SaveSetting "VBCodeLib", "Settings", "MainTop", Me.Top
            SaveSetting "VBCodeLib", "Settings", "MainWidth", Me.Width
            SaveSetting "VBCodeLib", "Settings", "MainHeight", Me.Height
            SaveSetting "VBCodeLib", "Settings", "TreeWidth", tvCodeItems.Width
        End If
        SaveSetting "VBCodeLib", "Settings", "ViewBookMarks", mbShowBookmarks
    End If
    
    ctlBookMarkList.Terminate
    ctlCodeItemDetails.Terminate
'
' Check if we want to compact the database
'
    If Not (moSettings.CompactDatabaseOnExit) Then
        Exit Sub
    End If
'
' Compact it now !
'
    sDBName = msDBFileName
    sBackupName = App.Path & "\dbbackup.mdb"
'
' Check if the temporary backup database already exists
'
    If Len(Dir$(sBackupName)) > 0 Then
        Kill sBackupName
    End If
'
' Here's where we compact the database - first copying
' it to a temporary db
'
    If Not (mDB Is Nothing) Then
        mDB.Close
        Set mDB = Nothing
    End If
    
    If Len(sDBName) > 0 Then
        DBEngine.CompactDatabase sDBName, sBackupName
'
' Now we remove the database
'
        Kill sDBName
'
' Now we compact the temporary DB back into our original
' database
'
        DBEngine.CompactDatabase sBackupName, sDBName
'
' And Kill the backup !
'
        Kill sBackupName
    End If
    Exit Sub
    
vbErrorHandler:
    MsgBox Err.Number & " " & Err.Description & " " & Err.Source & " frmCodeLib::DoUnload", , App.ProductName
    
End Sub

Private Sub RecursiveDeleteCode(nNode As Node)
'
' Recursively Delete Node Items
'
    Dim nNodeChild As Node
    Dim iIndex As Integer
    Dim iDO As IDataObject
    Dim sKey As String
    
    Set iDO = New CCodeItem
    sKey = nNode.Key
    sKey = Right$(sKey, Len(sKey) - 1)
'
' Delete affected data object - we could have done this all through Access, but
' this is intended to show recursion through TreeView Nodes
'

    iDO.Initialise mDB, sKey
    iDO.Delete
    iDO.Commit
    Set iDO = Nothing
    
    Set nNodeChild = nNode.Child
    
    ' Now walk through the current parent node's children
    Do While Not (nNodeChild Is Nothing)
    
    ' If the current child node has it's own children...
        RecursiveDeleteCode nNodeChild
    ' Get the current child node's next sibling
        Set nNodeChild = nNodeChild.Next
    Loop
End Sub


Private Sub SetupSysTrayIcon()
    On Error GoTo vbErrorHandler
'
' Setup the System Tray Icon
'
    Dim tTrayStuff As NOTIFYICONDATA
    
    With tTrayStuff
        .cbSize = Len(tTrayStuff)
        .hwnd = picSysBar.hwnd
        .uId = 1&
        .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
        .uCallBackMessage = WM_MOUSEMOVE
        .hIcon = Me.Icon
        .szTip = "VBCodeLibrary Tool" & vbNullChar
        Shell_NotifyIcon NIM_ADD, tTrayStuff
    End With
 
    Exit Sub

vbErrorHandler:
    MsgBox Err.Number & "  " & Err.Description & " " & Err.Source & "::frmBrowser_SetupSysTrayIcon", , App.ProductName
End Sub


Private Sub KillSysTrayIcon()
    Dim t As NOTIFYICONDATA
'
' Kill the icon in the system tray
'
    With t
        .cbSize = Len(t)
        .hwnd = picSysBar.hwnd
        .uId = 1&
    End With
    
    Shell_NotifyIcon NIM_DELETE, t

End Sub


Private Sub BoldTreeNode(nNode As Node)
'
' Make a tree node bold
'
' Many thanks to VBNet for this code
'

On Error GoTo vbErrorHandler

    Dim TVI As TVITEM
    Dim lRet As Long
    Dim hItemTV As Long
    Dim lHwnd As Long
    
    Set tvCodeItems.SelectedItem = nNode
    
    lHwnd = tvCodeItems.hwnd
    hItemTV = SendMessageLong(lHwnd, TVM_GETNEXTITEM, TVGN_CARET, 0&)
    
    If hItemTV > 0 Then
        With TVI
            .hItem = hItemTV
            .mask = TVIF_STATE
            .stateMask = TVIS_BOLD
            lRet = SendMessageAny(lHwnd, TVM_GETITEM, 0&, TVI)
            .State = TVIS_BOLD
        End With
        lRet = SendMessageAny(lHwnd, TVM_SETITEM, 0&, TVI)
    End If
    
    Exit Sub

vbErrorHandler:
    MsgBox Err.Number & " " & Err.Description & " " & Err.Source, , "frmCodeLib::BoldTreeNode"

End Sub

Private Sub ShowSettings()

On Error GoTo vbErrorHandler
'
' Show the Settings Dialog and update any settings
'
    Dim frmOpt As frmOptions
    
    Set frmOpt = New frmOptions
    Load frmOpt
    
    With frmOpt
        .Initialise moSettings
        .Show vbModal, Me
    End With
    Unload frmOpt
'
' Clear the form from memory
'
    Set frmOpt = Nothing

    Exit Sub

vbErrorHandler:
    MsgBox Err.Number & " " & Err.Description & " " & Err.Source, , "frmCodeLib::ShowSettings"

End Sub

Private Sub tvCodeItems_OLECompleteDrag(Effect As Long)
    Screen.MousePointer = vbDefault
    tmrDragTimer.Enabled = False
End Sub

Private Sub tvCodeItems_OLEDragDrop(Data As ComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
'
' Handle the dragging and-a dropping of treeview nodes here
'
    Dim sTmpStr As String
    Dim iDO As IDataObject
    Dim oTargetNode As Node
    Dim sParentKey As String
    Dim sKey As String
    Dim oCodeItem As CCodeItem
    Dim oOldParentNode As Node
    
    On Error Resume Next
'
' Check whether the clipboard data is in our special defined format
'
    sTmpStr = Data.GetFormat(miClipBoardFormat)
    
    If Err Or sTmpStr = "False" Then    ' it's not, so don't allow dropping
        Set mnDragNode = Nothing
        Set tvCodeItems.DropHighlight = Nothing
        Err.Clear
        Effect = vbDropEffectNone
        Exit Sub
    End If
    
    On Error GoTo vbErrorHandler
    
    If mnDragNode Is Nothing Then
        Set mnDragNode = Nothing
        Set tvCodeItems.DropHighlight = Nothing
        Effect = vbDropEffectNone
        Exit Sub
    End If
    
    Set oTargetNode = tvCodeItems.DropHighlight

'
    If oTargetNode Is Nothing Then
        Set mnDragNode = Nothing
        Set tvCodeItems.DropHighlight = Nothing
        Effect = vbDropEffectNone
        Exit Sub
    End If
  
    Set oOldParentNode = mnDragNode.Parent
   
        
    Set mnDragNode.Parent = oTargetNode
    
'
' Here's where we handle the drop - don't forget that we have to reparent
' our data objects to point to the new data object (or 0 if root)
'
    sParentKey = oTargetNode.Key

    If sParentKey = "ROOT" Then
        sParentKey = "0"
    Else
        sParentKey = Right$(sParentKey, Len(sParentKey) - 1)
    End If

    sKey = mnDragNode.Key
    sKey = Right$(sKey, Len(sKey) - 1)

'
' Initialise the dataobject and set it's new parent key
'
    Set iDO = New CCodeItem
    iDO.Initialise mDB, sKey
    Set oCodeItem = iDO
    oCodeItem.ParentKey = sParentKey
    iDO.Commit
    Set iDO = Nothing
    Set oCodeItem = Nothing

    Set tvCodeItems.DropHighlight = Nothing

    Set mnDragNode = Nothing
    tmrDragTimer.Enabled = False
    If oTargetNode.Key <> "ROOT" Then
        oTargetNode.ExpandedImage = "OPENFOLDER"
    End If
    If oOldParentNode.Children <= 1 And oOldParentNode.Key <> oTargetNode.Key Then
        If oOldParentNode.Key <> "ROOT" Then
            oOldParentNode.ExpandedImage = "CHILD"
            oOldParentNode.Image = "CHILD"
        End If
    End If
    
    
    
    Exit Sub

vbErrorHandler:
    
    Set mnDragNode = Nothing
    Set tvCodeItems.DropHighlight = Nothing
'
' This will more than likely be 'would cause a loop' or whatever
'
    MsgBox Err.Description, , App.ProductName
    Effect = vbDropEffectNone
    
End Sub

Private Sub tvCodeItems_OLEDragOver(Data As ComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single, State As Integer)
        
    Dim sTmpStr As String
    Dim nTargetNode As Node
    On Error Resume Next
'
' First check that we allow this type of data to be dropped here
'
    sTmpStr = Data.GetFormat(miClipBoardFormat)
    
    If Err Or sTmpStr = "False" Then
        Err.Clear
        Effect = vbDropEffectNone
        Exit Sub
    End If
        
    Set nTargetNode = tvCodeItems.HitTest(x, y)
    If nTargetNode Is Nothing Then
        Set tvCodeItems.DropHighlight = Nothing
        Exit Sub
    End If

    If nTargetNode.Key = mnDragNode.Key Then
        Set tvCodeItems.DropHighlight = Nothing
        Effect = vbDropEffectNone
    Else
        Set tvCodeItems.DropHighlight = nTargetNode
    End If
    If y > 0 And y < 300 Then
        miScrollDir = -1
    ElseIf (y < tvCodeItems.Height) And y > (tvCodeItems.Height - 500) Then
        miScrollDir = 1
    Else
        miScrollDir = 0
    End If
    
End Sub

Private Sub tvCodeItems_OLEStartDrag(Data As ComctlLib.DataObject, AllowedEffects As Long)
    Dim byt() As Byte
'
' Place the key of the dragged item into the clipboard in our own format
' declared in GetClipboardFormat api
'
    AllowedEffects = vbDropEffectMove
    byt = mnDragNode.Key
    
    Data.SetData byt, miClipBoardFormat
    
    
End Sub

Private Sub ClearTreeView()
'
' Very fast Clearing of treeview control
'
' Thanks to Brad Martinez for discovering this .
'
    Dim lHwnd As Long
    Dim hItem As Long
    
    lHwnd = tvCodeItems.hwnd
    
    TreeRedraw tvCodeItems.hwnd, False
    
    
    Do
        hItem = SendMessageLong(lHwnd, TVM_GETNEXTITEM, TVGN_ROOT, &O0)
        If hItem > 0 Then
            SendMessageLong lHwnd, TVM_DELETEITEM, &O0, hItem
        Else
            Exit Do
        End If
    Loop
    
    TreeRedraw tvCodeItems.hwnd, True

End Sub

Private Sub SizeControls(ByVal x As Long)
    On Error Resume Next
'
' Size all controls based on the splitter bar, and whether we're
' showing the Bookmarks control
'
    Dim lHeightOffSet As Long
   
    'set the width
    If x < 1500 Then x = 1500
    If x > (Me.Width - 1500) Then x = Me.Width - 1500
    
    If mbShowBookmarks Then
        ctlBookMarkList.Height = Me.ScaleHeight * (2 / 8)
        lHeightOffSet = ctlBookMarkList.Height
    Else
        lHeightOffSet = 0
    End If
    
    With imgSplitter
        .Left = x