frmcodelib.frm

vb控件代码大全

        .Width = 150
        .ZOrder
    End With
    
    With tvCodeItems
        .Move ScaleLeft, tbTools.Height, x, Me.ScaleHeight - (StatusBar1.Height + tbTools.Height + lHeightOffSet)
    End With
    
    With ctlCodeItemDetails
        .Move x + 25, tvCodeItems.Top, Me.ScaleWidth - (tvCodeItems.Width + 50), tvCodeItems.Height
    End With
    
    If mbShowBookmarks Then
        With ctlBookMarkList
            .Move ScaleLeft, tvCodeItems.Top + tvCodeItems.Height, ScaleWidth, lHeightOffSet
        End With
    End If
   
    imgSplitter.Top = tvCodeItems.Top
    imgSplitter.Height = tvCodeItems.Height

End Sub

Private Sub ShowBookmarks(ByVal bShow As Boolean)
'
' Show / hide bookmarks
'
    mbShowBookmarks = bShow
    ctlBookMarkList.Visible = mbShowBookmarks
    Form_Resize
    mnuViewBookMarks.Checked = mbShowBookmarks
    tbTools.Buttons("VIEWBOOKMARKS").Value = IIf(mbShowBookmarks, tbrPressed, tbrUnpressed)
End Sub

Private Function SetupDBConnection() As Boolean
'
' Setup Database Connection
'
' This routine will also update any previous versions of the
' database to the new required version !
'

    Dim bValidDatabase As Boolean
    
    On Error GoTo vbErrorHandler
    
    If Not (mDB Is Nothing) Then
        mDB.Close
        Set mDB = Nothing
    End If
    
    If Len(msDBFileName) = 0 Then
        SelectDataBase
    End If
    
    If Len(msDBFileName) > 0 Then
        Set mDB = Workspaces(0).OpenDatabase(msDBFileName)
    '
    ' Here's where we setup the Version Specific Tables if they don't exist
    '
        SetupVersionTable
        SetupCodeFilesTable
            
        SetupDBConnection = True
    End If
    
    Exit Function


vbErrorHandler:
    MsgBox Err.Number & " " & Err.Description & " " & Err.Source
    
End Function

Private Sub SelectDataBase()
    Dim sDBName As String
    
    sDBName = GetFileName(eOpenFileName, "", "Select a CodeLibrary Database", "VBCodeLibrary Files|*.mdb" & vbNullChar & vbNullChar)
    
    If Len(sDBName) = 0 Then
    '
    ' No Change
    '
        Exit Sub
    End If
    
    DoUnload
    SaveSetting "VBCodeLib", "Settings", "LastDB", sDBName
    
    msDBFileName = sDBName
    If SetupDBConnection = True Then
        ClearTreeView
        FillTree
        ctlBookMarkList.Initialise mDB
        EnableControls True
    Else
    
    ' Disable appropriate controls
    
        EnableControls False
        
    End If
    
End Sub

Private Function GetFileName(ByVal DialogType As eGetFileDialog, _
        ByRef sFilename As String, _
        ByVal sDialogTitle As String, _
        Optional sFilter As String) As String
    
    On Error GoTo vbErrorHandler
    
    If Len(sFilter) = 0 Then
        sFilter = "All Files|*.*"
    End If
    
    If Len(CommonDialog1.InitDir) = 0 Then
        CommonDialog1.InitDir = App.Path
    End If
    
    CommonDialog1.CancelError = True
    CommonDialog1.DialogTitle = sDialogTitle
    
    If Len(sFilename) > 0 Then
        CommonDialog1.filename = sFilename
    Else
        CommonDialog1.filename = ""
    End If
    If Len(sFilter) > 0 Then
        CommonDialog1.Filter = sFilter
    Else
        CommonDialog1.Filter = ""
    End If
    
    CommonDialog1.Flags = cdlOFNExplorer + cdlOFNHideReadOnly
    
    If DialogType = eOpenFileName Then
        CommonDialog1.ShowOpen
    Else
        CommonDialog1.Flags = CommonDialog1.Flags + cdlOFNOverwritePrompt
        CommonDialog1.ShowSave
    End If
    sFilename = CommonDialog1.filename
    
    If Len(sFilename) > 0 Then
        GetFileName = sFilename
    End If
    Exit Function
    
vbErrorHandler:
    If Err.Number = 32755 Then
        GetFileName = ""
        Exit Function
    Else
        MsgBox Err.Number & " " & Err.Source & " " & Err.Description, vbCritical, App.ProductName
    End If
    
End Function

Private Sub SetupVersionTable()
    Dim oRS As Recordset
    Dim fldField As Field
    Dim tblVersion As TableDef
    Dim sDBVersion As String
'
' Make sure that the user has the CodeDBVersion Table
'
' This will be used for future Backwards Compatibility
'

    On Error GoTo vbErrorHandler
    
    Set oRS = mDB.OpenRecordset("select version from CodeDBVersion")
    
    If oRS.EOF And oRS.BOF Then
        oRS.AddNew
        oRS.Fields("version").Value = App.Major & "." & App.Minor & "." & App.Revision
        oRS.Update
        oRS.Bookmark = oRS.LastModified
    End If
    
    sDBVersion = oRS.Fields("version")
    
    Me.Caption = "VBCodeLibrary Tool (" & msDBFileName & " - DB Version " & sDBVersion & ")"
    oRS.Close
    
    Exit Sub

vbErrorHandler:
    
    If Err.Number = 3078 Then
    '
    ' Add in the CodeDBVersion Table
    '
        Set tblVersion = New TableDef
        Set fldField = New Field
        
        Set tblVersion = mDB.CreateTableDef("CodeDBVersion")
        
        tblVersion.Fields.Append tblVersion.CreateField("Version", dbText)
        mDB.TableDefs.Append tblVersion
        
        Set oRS = mDB.OpenRecordset("CodeDBVersion")
        oRS.AddNew
        oRS.Fields("version").Value = App.Major & "." & App.Minor & "." & App.Revision
        oRS.Update
        oRS.Close
        
        Resume
        
    ElseIf Err.Number = 0 Then
    
    
    End If
    
End Sub

Private Sub SetupCodeFilesTable()
    Dim oRS As Recordset
    Dim tblCodeFiles As TableDef
    Dim fldField As Field
    
'
' Make sure that the database contains the CodeFiles Table
'
' If it doesn't, then create it inside the database.
'
' This ensures that the user can continue using their existing database.
'
'

    On Error GoTo vbErrorHandler
    
    Set oRS = mDB.OpenRecordset("codefiles")
    oRS.Close
    
    Exit Sub

vbErrorHandler:
    
    If Err.Number = 3078 Then
    '
    ' Add in the CodeFiles Table
    '
        
        Set tblCodeFiles = mDB.CreateTableDef("CodeFiles")
        
        tblCodeFiles.Fields.Append tblCodeFiles.CreateField("ID", dbLong)
        tblCodeFiles.Fields("ID").Attributes = dbAutoIncrField
        tblCodeFiles.Fields.Append tblCodeFiles.CreateField("CodeID", dbLong)
        tblCodeFiles.Fields.Append tblCodeFiles.CreateField("Description", dbText, 50)
        tblCodeFiles.Fields.Append tblCodeFiles.CreateField("File", dbLongBinary)
        tblCodeFiles.Fields.Append tblCodeFiles.CreateField("OrigDateTime", dbDate)
        tblCodeFiles.Fields.Append tblCodeFiles.CreateField("DateAdded", dbDate)
        
        mDB.TableDefs.Append tblCodeFiles
        
        Resume
        
    ElseIf Err.Number = 0 Then
    
    
    End If

End Sub

Private Sub ImportCodeItems()
'
' This routine imports items in the VCL file into the Database
'
    Dim nNode As Node
    Dim iFile As Integer
    Dim sUseFileName As String
    Dim oCodeItem As CCodeItem
    Dim iDO As IDataObject
    Dim lCount As Long
    Dim oImport As ImportData
    Dim sParentKey As String
    Dim sTopParentKey As String
    Dim oColl As Collection
    Dim oWait As CWaitCursor
    Dim lNumCodeItems As Long
    Dim sTmp As String
    
    Dim oHeader As FileHeader
    
On Error GoTo vbErrorHandler
'
' Get selected Node
'
    Set nNode = tvCodeItems.SelectedItem
'
' If No Node Selected (very unlikely) then exit
'
    If nNode Is Nothing Then Exit Sub
    
'
' Get Import File Name
'
    sUseFileName = GetFileName(eOpenFileName, "", "Import Data From File :", "VBCodeLibrary Export|*.vcl")
'
' If no name selected then quit
'
    If Len(sUseFileName) = 0 Then Exit Sub
    
'
' Get FileHandle
'
    iFile = FreeFile
    
'
' Get Top Parent Key
'
    If nNode.Key = "ROOT" Then
        sTopParentKey = "0"
    Else
        sTopParentKey = Right$(nNode.Key, Len(nNode.Key) - 1)
    End If
'
' Set Cursor to HourGlass
'
    Set oWait = New CWaitCursor
    oWait.SetCursor
'
' Setup Our Collection Internally
'
    Set oColl = New Collection
    
'
' Place all of the Import into a Transaction for Speed & rollback opportunity
'
    BeginTrans
    
'
' Open the file
'
    Open sUseFileName For Binary Access Read As iFile
    
    lCount = 1
    
    Get #iFile, , oHeader
    
    prgBar.Min = 1
    prgBar.Max = oHeader.lNumberOfRecords '+ 5
    
    StatusBar1.Panels(1).Text = "Importing Items...."
    DoEvents
    ShowProgressInStatusBar True
'
' Now loop through the records in the file
'
    For lCount = 1 To oHeader.lNumberOfRecords
        
'
' Get each record until empty
'
        Get #iFile, , oImport
        
        If oImport.sName = "" Then Exit For
        
'
' Create a new CodeItem for the record
'
        Set iDO = New CCodeItem
        Set oCodeItem = iDO
        iDO.Initialise mDB
        
'
' Setup the CodeItems values
'
        oCodeItem.Code = oImport.sStoredCode
        oCodeItem.Description = oImport.sName
        oCodeItem.Example = oImport.sUsage
        oCodeItem.Notes = oImport.sNotes
'
' If this is the first one, then set it's parent to the selected Node database key
'
        If lCount = 1 Then
            oCodeItem.ParentKey = sTopParentKey
        End If
'
' Write the new record away
'
        iDO.Commit
'
' Now build up our key object for recreating the Tree Structure
'
'        Set oKeys = New CImportKey
'        oKeys.sNewID = iDO.Key
'        oKeys.sOldID = oImport.sOriginalID
    
'
' Add it to the collection - indexed by Original Key
'
    '    oColl.Add oKeys, oKeys.sOldID
        oColl.Add iDO.Key, oImport.sOriginalID
        
        
'
' If we're not on the first item to be imported, restructure the items
'
        If lCount > 1 Then
            sParentKey = oImport.sParentID
                    
            If Len(sParentKey) > 0 And sParentKey <> "0" Then
                oCodeItem.ParentKey = oColl.Item(sParentKey) '.sNewID
            Else
                oCodeItem.ParentKey = sTopParentKey
            End If
            iDO.Commit
        End If
        Set iDO = Nothing
        Set oCodeItem = Nothing
        prgBar.Value = lCount
        sParentKey = ""
    Next
    
'
' Close the file
'
    Close iFile
'
' Commit all of our database work
'
    ShowProgressInStatusBar False
    StatusBar1.Panels(1).Text = ""
    CommitTrans
'
' Fill the tree with all records from the database
'
    FillTree
'
' Now, get the original Node that was the TopParent, and make sure
' that it's expanded, and visible
'
    If Len(sTopParentKey) > 0 And sTopParentKey <> "0" Then
        Set nNode = tvCodeItems.Nodes("C" & sTopParentKey)
        Set tvCodeItems.SelectedItem = nNode
        nNode.Expanded = True
        nNode.EnsureVisible
    End If
'
' Restore the cursor
'
    Set oWait = Nothing
    
'
' Notify the User of success
'
    MsgBox "Successfully imported " & lCount - 1 & " Code snippets.", vbInformation, App.ProductName
    
    Exit Sub

vbErrorHandler:
'
' Restore the cursor
'
    Set oWait = Nothing
'
' Rollback the database work
'
    Rollback
    ShowProgressInStatusBar False
    StatusBar1.Panels(1).Text = ""
    MsgBox Err.Number & " " & Err.Description & " " & Err.Source & vbCrLf & vbCrLf & "frmCodeLib::ImportCodeItems"

End Sub

Private Sub ExportCodeItems()
    Dim nNode As Node
    Dim iFile As Integer
    Dim sUseFileName As String
    Dim oWait As CWaitCursor
    Dim lNumToExport As Long
    Dim oHeader As FileHeader
    
'
' Here's where we export the items to a