doccodebrowser.dob

vb资源管理器增强型 vb资源管理器增强型

        'call the general section in the module
        'tvCodeBrowser.Nodes(LastProjectName & Vb_Sep & LastCodeModuleName & Vb_Sep).Selected = True
250     tvCodeBrowser_NodeClick tvCodeBrowser.Nodes(LastProjectName & _
                Vb_Sep & LastCodeModuleName & Vb_Sep)
252     StopClick = False

        'fill the module with fresh members
254     M_RefreshMembers VBInstance.VBProjects.VBE.ActiveVBProject.Name & Vb_Sep, _
                VBInstance.ActiveCodePane.VBE.SelectedVBComponent.Name

        'recall the starting procedure
256     If Not SaveKey = vbNullString Then
258         StopClick = False
260         tvCodeBrowser_NodeClick tvCodeBrowser.Nodes(SaveKey)
        End If

262     If bControlChange Then 'notifies about added, renamed or deleted control.
264         bControlChange = False
266         H_ShowDesigner
        End If

268     FreezeMDIClient False
270     DoEvents
272     bRefreshing = False
274     L_ResetLists
        Exit Sub
eH:
326 Select Case Err.Number
    Case 35605 'Das Steuerelement dieses Elementes wurde geloescht
328     Resume Next
330 Case 35602      'Schlussel is in der Auflistung nicht eindeutig
332     MsgBox Err.Description & vbCrLf & Err.Number & vbCrLf & _
                "程序 CodeBrowser.docCodeBrowser.M_RefreshActiveModule " & _
                "错误行 " & Erl, vbCritical, "错误信息"
334 Case 35601      'Element not found
336     Resume Next
338 Case 91        'Objekt Variable oder With-Block Variable nicht festgelegt
340     FreezeMDIClient False
344 Case Else
348     MsgBox Err.Description & vbCrLf & Err.Number & vbCrLf & _
                "程序 CodeBrowser.docCodeBrowser.M_RefreshActiveModule " & _
                "错误行 " & Erl, vbCritical, "错误信息"
    End Select
End Sub


Private Function H_CheckForMembers(objModule As CodeModule) As Boolean
    '<EhHeader>
    On Error GoTo H_CheckForMembers_Err
    '</EhHeader>
    Const Vb_EndSub = "End Sub"
    Const Vb_EndFunction = "End Function"
    Const Vb_EndProperty = "End Property"

100 H_CheckForMembers = objModule.Find(Vb_EndSub, 1, 1, objModule.CountOfLines, 70, False, True, True)
102 If Not H_CheckForMembers Then H_CheckForMembers = objModule.Find(Vb_EndFunction, 1, 1, objModule.CountOfLines, 12, False, True, True)
104 If Not H_CheckForMembers Then H_CheckForMembers = objModule.Find(Vb_EndProperty, 1, 1, objModule.CountOfLines, 11, False, True, True)
    '<EhFooter>
    Exit Function

H_CheckForMembers_Err:
    MsgBox Err.Description & vbCrLf & _
            "程序 CodeBrowser.docCodeBrowser.H_CheckForMembers " & _
            "错误行 " & Erl, vbCritical, "错误信息"
    Resume Next
    '</EhFooter>
End Function

Function H_IsNewThing() As Boolean
    On Error GoTo eH
    Dim objCodeModule As CodeModule, objCodePane As CodePane
    Dim ProcKind&, startLine&, startCol&, endLine&, endCol&
    Dim MemberName$, ProjectName$, CodePaneName$
    Static OldActiveProject$
    Static OldActiveCodePane$
    Static OldActiveProcedure$

100 ProjectName = VBInstance.ActiveVBProject.Name
    'CodePaneName = VBInstance.ActiveCodePane.Window.Caption
102 CodePaneName = VBInstance.ActiveCodePane.CodeModule.Name
104 Set objCodePane = VBInstance.ActiveCodePane
106 If objCodePane Is Nothing Then Exit Function

108 Set objCodeModule = VBInstance.ActiveCodePane.CodeModule

    'Get the current selection
110 objCodeModule.CodePane.GetSelection startLine, startCol, endLine, endCol

    'Get procedure name at the line where the cursor is located
112 MemberName = objCodeModule.ProcOfLine(startLine, ProcKind)

114 Select Case ProcKind
    Case vbext_pk_Get
116     MemberName = MemberName & Vb_Get
118 Case vbext_pk_Let
120     MemberName = MemberName & Vb_Let
122 Case vbext_pk_Set
124     MemberName = MemberName & Vb_Set
    End Select

126 If Not ProjectName = OldActiveProject Or _
            Not CodePaneName = OldActiveCodePane Or _
            Not MemberName = OldActiveProcedure Then
128     OldActiveProject = ProjectName
130     OldActiveCodePane = CodePaneName
132     OldActiveProcedure = MemberName
134     H_IsNewThing = True
    End If

    Exit Function
eH:
136 Select Case Err.Number
    Case 91 'Objekt Variable oder With-Block Variable nicht festgelegt: by loading
138     Err.Clear
140 Case Else
142     MsgBox Err.Description & vbCrLf & _
                "程序 CodeBrowser.docCodeBrowser.H_IsNewThing " & _
                "错误行 " & Erl & vbCrLf & Err.Number, vbCritical, "错误信息"
144     Resume Next
    End Select
End Function

Function H_NodeKeyFromListArr(LstIndex As Long) As String
    Dim strTemp As String 'Used to take apart selected row in listbox.
    ' Loop through number of columns.
    Dim sKey$  ', sTmp$
    On Error GoTo eH

    'prepare
100 sKey = arrHistory(2, LstIndex) & Vb_Sep & _
            arrHistory(1, LstIndex) & Vb_Sep

102 strTemp = arrHistory(0, LstIndex)
    'MsgBox sKey & " " & strTemp
104 If Not strTemp = vbNullString Then
106     If Not strTemp = Vb_Gnrl Then
108         sKey = sKey & strTemp
        End If
    End If

110 H_NodeKeyFromListArr = sKey
    Exit Function
eH:
112 MsgBox Err.Description & vbCrLf & _
            "程序 CodeBrowser.docCodeBrowser.H_NodeKeyFromListArr " & _
            "错误行 " & Erl, vbCritical, "错误信息"
End Function

Function H_ModuleKeyFromListArr(LstIndex As Long) As String
    Dim strTemp As String 'Used to take apart selected row in listbox.
    ' Loop through number of columns.
    Dim sKey$  ', sTmp$
    On Error GoTo eH

    'prepare
100 sKey = arrHistory(2, LstIndex) & Vb_Sep & _
            arrHistory(1, LstIndex) & Vb_Sep

110 H_ModuleKeyFromListArr = sKey
    Exit Function
eH:
112 MsgBox Err.Description & vbCrLf & _
            "程序 CodeBrowser.docCodeBrowser.H_ModuleKeyFromListArr " & _
            "错误行 " & Erl, vbCritical, "错误信息"
End Function

'Private Function NoDuplicatesInList(lst As ListBox, str As String) As Boolean
''<EhHeader>
'On Error GoTo NoDuplicatesInList_Err
''</EhHeader>
'Dim tf As Boolean
'Dim X As Integer
'NoDuplicatesInList = False
'
'For X = 0 To lst.ListCount - 1
'    If lst.List(X) <> str Then
'        tf = False
'    Else
'        tf = True
'        Exit For
'    End If
'Next X
'
'
'If tf = False And str <> "" Then
'    NoDuplicatesInList = False
'Else
'    NoDuplicatesInList = True
'End If
'
''<EhFooter>
'Exit Function
'
'NoDuplicatesInList_Err:
'MsgBox Err.Description & vbCrLf & _
 '        "程序 CodeBrowser.docCodeBrowser.NoDuplicatesInList " & _
 '        "错误行 " & Erl, vbCritical, "错误信息"
'Resume Next
''</EhFooter>
'End Function



'Public Sub H_GetPaneCombos()
''<EhHeader>
'On Error GoTo H_GetPaneCombos_Err
''</EhHeader>
'Dim tmpHwnd&, tmpHwnd1&, wRct As RECT, wRct1 As RECT
''On Error GoTo eH
'
'hWndCodePane = FindWindowEx(hWndMDIClient, 0, VBA_WINDOW, vbNullString)
'
'If hWndCodePane Then
'    tmpHwnd = FindWindowEx(hWndCodePane, 0, VBA_COMBOBOX, vbNullString)
'    If tmpHwnd Then
'        GetWindowRect tmpHwnd, wRct
'        tmpHwnd1 = FindWindowEx(hWndCodePane, tmpHwnd, VBA_COMBOBOX, vbNullString)
'
'        If tmpHwnd1 Then
'            GetWindowRect tmpHwnd1, wRct1
'            If wRct.Left > wRct1.Left Then
'                hWndCmbRight = tmpHwnd
'                hWndCmbLeft = tmpHwnd1
'            Else
'                hWndCmbRight = tmpHwnd1
'                hWndCmbLeft = tmpHwnd
'            End If
'        End If
'    End If
'End If
'
'
'Exit Sub
'eH:
'On Error GoTo H_GetPaneCombos_Err
''<EhFooter>
'Exit Sub
'
'H_GetPaneCombos_Err:
'MsgBox Err.Description & vbCrLf & _
 '        "程序 CodeBrowser.docCodeBrowser.H_GetPaneCombos " & _
 '        "错误行 " & Erl
'Resume Next
''</EhFooter>
'End Sub

Public Sub EV_DeleteFromKey(sKey As String)
    On Error GoTo eH

100 tvCodeBrowser.Nodes.Remove (sKey)

    Exit Sub
eH:
102 Select Case Err.Number
    Case 35601 'Element not found
104     Err.Clear
106 Case Else
108     MsgBox Err.Description & vbCrLf & Err.Number & vbCrLf & _
                "程序 CodeBrowser.docCodeBrowser.EV_DeleteFromKey " & _
                "错误行 " & Erl & vbCrLf & _
                "sKey: " & sKey, vbCritical, "错误信息"
    End Select
End Sub

Public Sub H_DeleteTree()
    On Error GoTo eH

100 tvCodeBrowser.Nodes.Clear
    Exit Sub
eH:
102 MsgBox Err.Description & vbCrLf & _
            "程序 CodeBrowser.docCodeBrowser.H_DeleteTree " & _
            "错误行 " & Erl, vbCritical, "错误信息"
104 Resume Next
End Sub


'Public Sub EV_AddNewProject(objProj As VBIDE.VBProject)
''<EhHeader>
'On Error GoTo EV_AddNewProject_Err
''</EhHeader>
'Dim objModule As CodeModule, objComp As VBComponent, objMbr As Member
'Dim sTmp$, i&, j&, ProjectKey$
''On Error GoTo eH
'
'
''SoftBttn(1).Enabled = False
'
'sTmp = Vb_lBracket & Right$(objProj.FileName, LenB(objProj.FileName) / 2 - InStrRev(objProj.FileName, Vb_Backslash)) & Vb_rBrackett
'ProjectKey = objProj.Name & Vb_Sep
'
'With tvCodeBrowser.Nodes.Add(, tvwFirst, _
 '            ProjectKey, _
 '            objProj.Name & sTmp)
'    Select Case objProj.Type
'    Case vbext_pt_ActiveXControl
'        .Image = 3
'    Case vbext_pt_ActiveXDll
'        .Image = 7
'    Case vbext_pt_ActiveXExe
'        .Image = 11
'    Case vbext_pt_StandardExe
'        .Image = 6
'    Case Else                               'who knows? :)
'        .Image = 10
'    End Select
'
'    .Tag = Vb_Project
'    .Sorted = True
'End With
'
'ReDim CmpNodes(objProj.VBComponents.Count)
'
''Cycle through all open components in each project
'For Each objComp In objProj.VBComponents
'    i = i + 1
'
'    Select Case objComp.Type
'    Case vbext_ct_StdModule
'        Set objModule = objComp.CodeModule
'        sTmp = Vb_lBracket & Right$(objComp.FileNames(1), LenB(objComp.FileNames(1)) / 2 - InStrRev(objComp.FileNames(1), Vb_Backslash)) & Vb_rBrackett
'
'        With CmpNodes(i)
'            .aKey = ProjectKey & objComp.Name & Vb_Sep
'            .aText = objModule.Name & sTmp
'            .aImage = 18
'            .aTag = Vb_StdModule
'            'Procedures, Events, etc.
'            If H_CheckForMembers(objModule) = True Then
'                k = k + 1
'                .aDummyKey = Vb_a & Str$(k)
'            End If
'        End With
'
'
'    Case vbext_ct_ClassModule
'        Set objModule = objComp.CodeModule
'        sTmp = Vb_lBracket & Right$(objComp.FileNames(1), LenB(objComp.FileNames(1)) / 2 - InStrRev(objComp.FileNames(1), Vb_Backslash)) & Vb_rBrackett
'
'        With CmpNodes(i)
'            .aKey = ProjectKey & objComp.Name & Vb_Sep
'            .aText = objModule.Name & sTmp
'            .aImage = 13
'            .aTag = Vb_ClassModule
'            'Procedures, Events, etc.
'            If H_CheckForMembers(objModule) = True Then
'                k = k + 1
'                .aDummyKey = Vb_a & Str$(k)
'            End If
'        End With
'    Case vbext_ct_VBForm
'        Set objModule = objComp.CodeModule
'        sTmp = Vb_lBracket & Right$(objComp.FileNames(1), LenB(objComp.FileNames(1)) / 2 - InStrRev(objComp.FileNames(1), Vb_Backslash)) & Vb_rBrackett
'
'        With CmpNodes(i)
'            .aKey = ProjectKey & objComp.Name & Vb_Sep
'            .aText = objModule.Name & sTmp
'
'            Select Case objModule.Parent.Properties(Vb_MDIChild).Value
'            Case False
'                .aImage = 14
'            Case True
'                .aImage = 30
'            End Select
'
'            .aTag = Vb_VBForm
'            'Procedures, Events, etc.
'            If H_CheckForMembers(objModule) = True Then
'                k = k + 1
'                .aDummyKey = Vb_a & Str$(k)
'            End If
'        End With
'    Case vbext_ct_MSForm
'        Set objModule = objComp.CodeModule
'        sTmp = Vb_lBracket & Right$(objComp.FileNames(1), LenB(objComp.FileNames(1)) / 2 - InStrRev(objComp.FileNames(1), Vb_Backslash)) & Vb_rBrackett
'
'        With CmpNodes(i)
'            .aKey = ProjectKey & objComp.Name & Vb_Sep
'            .aImage = 14
'            .aTag = Vb_MSForm
'            'Procedures, Events, etc.
'            If H_CheckForMembers(objModule) = True Then
'                k = k + 1
'                .aDummyKey = Vb_a & Str$(k)
'            End If
'        End With
'    Case vbext_ct_VBMDIForm
'        Set objModule = objComp.CodeModule
'        sTmp = Vb_lBracket & Right$(objComp.FileNames(1), LenB(objComp.FileNames(1)) / 2 - InStrRev(objComp.FileNames(1), Vb_Backslash)) & Vb_rBrackett