doccodebrowser.dob

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

    Dim i&, PrjName$, CodeModuleName$, ProcName$, Pos&, IsNotStopped As Boolean
    Dim objCodeModule As CodeModule
    Dim NodeKey$, PropInList$, k&, ArrTmp() As String
    Const Vb_Mark = "'"

100 IsNotStopped = ProcessMsg
102 If ProcessMsg = True Then ProcessMsg = False

    'clean arrHistory & LstHistory
104 If LstHistory.ListCount > 0 Then
106     ReDim ArrTmp(0 To 2, 0 To LstHistory.ListCount - 1)

108     For i = 0 To LstHistory.ListCount - 1
110         ProcName = arrHistory(0, i)

112         If Not ProcName = Vb_Gnrl Then
114             Pos = InStr(ProcName, Vb_lBracket)

116             If Pos > 0 Then
118                 PropInList = ProcName
120                 ProcName = Left$(ProcName, Pos - 1)
'! Added $ to Mid$ for performance
122                 PropInList = Mid$(PropInList, Pos, 5)
                End If
            End If

124         CodeModuleName = arrHistory(1, i)
126         PrjName = arrHistory(2, i)

            'If ProcName = Vb_Gnrl Then ProcName = vbNullString
128         NodeKey = PrjName & Vb_Sep & CodeModuleName & Vb_Sep & ProcName
130         If Len(PropInList) > 0 Then NodeKey = NodeKey & PropInList

132         If tvCodeBrowser.Nodes(NodeKey) Is Nothing Then
                'mark list the entry for deletion
134             LstHistory.List(i) = Vb_Mark
            Else
136             ArrTmp(2, k) = arrHistory(2, i)
138             ArrTmp(1, k) = arrHistory(1, i)
140             ArrTmp(0, k) = arrHistory(0, i)
142             k = k + 1
            End If
144     Next i

Reiterate:
146     For i = 0 To LstHistory.ListCount - 1   'UBound(arrHistory, 2) - 1
148         If LstHistory.List(i) = Vb_Mark Then  'arrHistory(2, i) = Vb_Mark Then
150             LstHistory.RemoveItem i
152             GoTo Reiterate
            End If
        Next

154     If LstHistory.ListCount > 0 Then
156         ReDim arrHistory(0 To 2, 0 To LstHistory.ListCount - 1)
158         ReDim Preserve ArrTmp(0 To 2, 0 To LstHistory.ListCount - 1)
        End If

160     For i = 0 To UBound(arrHistory, 2)
162         arrHistory(0, i) = ArrTmp(0, i)
164         arrHistory(1, i) = ArrTmp(1, i)
166         arrHistory(2, i) = ArrTmp(2, i)
168     Next i

170     LstHistSel = UBound(arrHistory, 2)
172     If LstHistory.ListCount > 0 Then LstHistory.Selected(LstHistSel) = True
    End If

    'clean arrHitParade & LstHits
174 k = 0

176 If LstHits.ListCount > 0 Then

178     ReDim ArrTmp(0 To 2, 0 To LstHits.ListCount - 1)

180     For i = 0 To UBound(arrHitParade, 2) - 1
182         ProcName = arrHitParade(0, i)

184         If Not ProcName = Vb_Gnrl Then
186             Pos = InStr(ProcName, Vb_lBracket)

188             If Pos > 0 Then
190                 PropInList = ProcName
192                 ProcName = Left$(ProcName, Pos - 1)
'! Added $ to Mid$ for performance
194                 PropInList = Mid$(PropInList, Pos, 5)
                End If
            End If

196         CodeModuleName = arrHitParade(1, i)
198         PrjName = arrHitParade(2, i)

200         If ProcName = Vb_Gnrl Then ProcName = vbNullString
202         NodeKey = PrjName & Vb_Sep & CodeModuleName & Vb_Sep & ProcName
204         If Len(PropInList) > 0 Then NodeKey = NodeKey & PropInList

206         If tvCodeBrowser.Nodes(NodeKey) Is Nothing Then
                'mark list the entry for deletion

208             LstHits.List(i) = Vb_Mark '& LstHits.List(i)
            Else
210             ArrTmp(2, k) = arrHitParade(2, i)
212             ArrTmp(1, k) = arrHitParade(1, i)
214             ArrTmp(0, k) = arrHitParade(0, i)
216             k = k + 1
            End If

218     Next i

        'clean list
Reiterate1:
220     For i = 0 To LstHits.ListCount - 1
            'If Left$(LstHits.List(i), 1) = Vb_Mark Then

222         If LstHits.List(i) = Vb_Mark Then
224             LstHits.RemoveItem i
226             GoTo Reiterate1
            End If
        Next

228     If LstHits.ListCount > 0 Then
230         ReDim arrHitParade(0 To 2, 0 To LstHits.ListCount - 1)
232         ReDim Preserve ArrTmp(0 To 2, 0 To LstHits.ListCount - 1)
        End If

234     For i = 0 To UBound(arrHistory, 2)
236         arrHitParade(0, i) = ArrTmp(0, i)
238         arrHitParade(1, i) = ArrTmp(1, i)
240         arrHitParade(2, i) = ArrTmp(2, i)
242     Next i
    End If

244 If LstHistory.ListCount > 0 Then
246     Set objCodeModule = VBInstance.VBProjects(arrHistory(2, UBound(arrHistory, 2))).VBComponents(arrHistory(1, UBound(arrHistory, 2))).CodeModule


248     LastMemberCount = objCodeModule.Members.Count
250     LastMemberName = arrHistory(0, UBound(arrHistory, 2))     'should be always different

252     Select Case PropInList
        Case vbNullString
254         LastMemberType = 0
256     Case Vb_Get
258         LastMemberType = 3
260     Case Vb_Let
262         LastMemberType = 1
264     Case Vb_Set
266         LastMemberType = 2
        End Select

268     LastCodeModuleName = arrHistory(1, UBound(arrHistory, 2))
270     LastProjectName = arrHistory(2, UBound(arrHistory, 2))
272     LastKey = LastProjectName & Vb_Sep & LastCodeModuleName & Vb_Sep & LastMemberName
274     If Len(PropInList) > 0 Then LastKey = LastKey & PropInList
    End If
276 If (ProcessMsg = False) And (IsNotStopped = True) Then ProcessMsg = True
    Exit Sub

eH:
278 Select Case Err.Number
    Case 35601  'element not found
280     Err.Clear
282     Resume Next
284 Case -2147418113 'automatisierung fehler
286     Err.Clear
288     Resume Next
290 Case 9     'Index ausserhalb des gueltigen Bereichs
'! Added $ to Str$ for performance
'! Added $ to Str$ for performance
'! Added $ to Str$ for performance
292     MsgBox Err.Description & vbCrLf & Err.Number & vbCrLf & _
                "程序 CodeBrowser.docCodeBrowser.L_ResetLists " & _
                "错误行 " & Erl & vbCrLf & _
                "i = " & Str$(i) & vbCrLf & _
                "k = " & Str$(k) & vbCrLf & _
                "List Member: " & LstHistory.List(i) & vbCrLf & _
                "LstHits.List(i) = " & LstHits.List(i) & vbCrLf & _
                "LstHits.ListCount = " & LstHits.ListCount & vbCrLf & _
                arrHitParade(0, k) & vbCrLf & _
                arrHitParade(1, k) & vbCrLf & _
                arrHitParade(2, k) & vbCrLf & _
                "ubound " & Str$(UBound(arrHitParade, 2)), vbCritical, "错误信息"
294     If (ProcessMsg = False) And (IsNotStopped = True) Then ProcessMsg = True

296 Case Else
'! Added $ to Str$ for performance
'! Added $ to Str$ for performance
'! Added $ to Str$ for performance
298     MsgBox Err.Description & vbCrLf & Err.Number & vbCrLf & _
                "程序 CodeBrowser.docCodeBrowser.L_ResetLists " & _
                "错误行 " & Erl & vbCrLf & _
                "i = " & Str$(i) & vbCrLf & _
                "k = " & Str$(k) & vbCrLf & _
                "List Member: " & LstHistory.List(i) & vbCrLf & _
                "LstHits.List(i) = " & LstHits.List(i) & vbCrLf & _
                "LstHits.ListCount = " & LstHits.ListCount & vbCrLf & _
                arrHitParade(0, k) & vbCrLf & _
                arrHitParade(1, k) & vbCrLf & _
                arrHitParade(2, k) & vbCrLf & _
                "ubound " & Str$(UBound(arrHitParade, 2)), vbCritical, "错误信息"
300     Resume Next
302     If (ProcessMsg = False) And (IsNotStopped = True) Then ProcessMsg = True
    End Select

End Sub

Sub M_RefreshMembers(ParentKey As String, VBComponentName As String)
    On Error GoTo eH
    Dim NodeX As Node, NodeY As Node, HasChildren As Boolean

100 LockWindowUpdate GetDesktopWindow
102 If ProcessMsg = True Then ProcessMsg = False

104 If tvCodeBrowser.Nodes.Count Then
        'delete node children
106     Set NodeX = tvCodeBrowser.Nodes(ParentKey & VBComponentName & Vb_Sep)

108     Do While NodeX.Children
110         Set NodeY = NodeX.Child
112         tvCodeBrowser.Nodes.Remove (NodeY.Index)
114         If HasChildren = False Then HasChildren = True
        Loop

116     If HasChildren Then
118         k = k + 1
120         tvCodeBrowser.Nodes.Add NodeX.key, _
                    tvwChild, _
                    Vb_a & Str$(k), _
                    Vb_Dummy
122         If Not bRefreshing Then NodeX.Selected = True
124         StopClick = False
126         tvCodeBrowser_NodeClick NodeX
        End If

        End If
        
    If IsLoading = -1 Then

        IsLoading = 0
130     DoEvents
132     Timer2 = True
134     L_ResetListByNewStart
        
    End If
LockWindowUpdate 0
128     If ProcessMsg = False Then ProcessMsg = True
    Exit Sub
eH:
Select Case Err.Number
    Case 35601 'Element not found
        If ProcessMsg = False Then ProcessMsg = True
        LockWindowUpdate 0
    Case 91 'Object variable or With block not set
    Resume Next
Case Else
 If ProcessMsg = False Then ProcessMsg = True
 MsgBox Err.Description & vbCrLf & _
            "程序 CodeBrowser.docCodeBrowser.M_RefreshMembers " & _
            "错误行 " & Erl & vbCrLf & Err.Number, vbCritical, "错误信息"
 Resume Next
 End Select
End Sub


Public Sub EV_NodeNewText(sKey As String, NewText As String)
    On Error GoTo eH

100 If Not tvCodeBrowser.Nodes(sKey).Text = NewText Then _
            tvCodeBrowser.Nodes(sKey).Text = NewText

    Exit Sub
eH:
Select Case Err.Number
    Case 35603 'invalid key, by saving a new component.
        Resume Next
    Case Else
102 MsgBox Err.Description & vbCrLf & _
            "程序 CodeBrowser.docCodeBrowser.EV_NodeNewText " & _
            "错误行 " & Erl & vbCrLf & Err.Number, vbCritical, "错误信息"
104 Resume Next
End Select
End Sub

Public Function H_SearchTree(ParentKey As String, NodeKey As String) As Boolean
    '<EhHeader>
    On Error GoTo H_SearchTree_Err
    '</EhHeader>
    Dim NodeX As Node
100 Set NodeX = tvCodeBrowser.Nodes(ParentKey).Child

102 For Each NodeX In tvCodeBrowser.Nodes
104     If NodeKey = NodeX.key Then
106         H_SearchTree = True
            Exit Function
        End If
    Next

    '<EhFooter>
    Exit Function

H_SearchTree_Err:
    MsgBox Err.Description & vbCrLf & _
            "程序 CodeBrowser.docCodeBrowser.H_SearchTree " & _
            "错误行 " & Erl, vbCritical, "错误信息"
    Resume Next
    '</EhFooter>
End Function
Public Sub Ev_ResClean(ParentKey As String, NewText As String)
    On Error GoTo eH
    Dim NodeX As Node

100 Set NodeX = tvCodeBrowser.Nodes(ParentKey).Child

102 For Each NodeX In tvCodeBrowser.Nodes
104     If NodeX.Tag = Vb_ResFile Then

106         If Not NodeX.Text = NewText Then
                On Error Resume Next
108             tvCodeBrowser.Nodes.Remove NodeX.Index
            End If
        End If
    Next

110 For Each NodeX In tvCodeBrowser.Nodes
112     If NodeX.Tag = Vb_ResFile Then
114         NodeX.Image = 8
        End If
    Next

    Exit Sub
eH:
116 MsgBox Err.Description & vbCrLf & _
            "程序 CodeBrowser.docCodeBrowser.Ev_ResClean " & _
            "错误行 " & Erl, vbCritical, "错误信息"
118 Resume Next
End Sub
Public Function H_SearchNodeText(ParentKey As String, NodeText As String) As String


    Dim NodeX As Node
100 Set NodeX = tvCodeBrowser.Nodes(ParentKey).Child

102 For Each NodeX In tvCodeBrowser.Nodes
104     If InStr(NodeX.Text, NodeText) Then
106         H_SearchNodeText = NodeX.key
            Exit Function
        End If
    Next

End Function
Public Sub H_ShowDesigner()
    '<EhHeader>
    On Error GoTo H_ShowDesigner_Err
    '</EhHeader>
    Dim NodeX As Node, strProject$, strCodeModule$, objComp As VBComponent

100 Set NodeX = tvCodeBrowser.SelectedItem
102 If NodeX Is Nothing Then Exit Sub
104 strProject = H_NodeKeyToPrjName(NodeX.key)
106 strCodeModule = H_NodeKeyToCodeModName(NodeX.key)

108 If LenB(strProject) > 0 And LenB(strCodeModule) > 0 Then
110     Set objComp = VBInstance.VBProjects(strProject).VBComponents(strCodeModule)

112     If Not objComp.DesignerWindow Is Nothing Then
114         objComp.DesignerWindow.Visible = True
116         objComp.DesignerWindow.SetFocus
        End If
    End If
    '<EhFooter>
    Exit Sub

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

Public Sub M_RefreshActiveModule()
        On Error GoTo eH
        Dim SaveKey As String
        
240     DoEvents
242     bRefreshing = True
244     SaveKey = LastKey
246     FreezeMDIClient True
248     StopClick = False