doccodebrowser.dob

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

      Left            =   120
      Picture         =   "docCodeBrowser.dox":7AB2
      Top             =   480
      Width           =   4980
   End
End
Attribute VB_Name = "docCodeBrowser"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

'global object to retain a reference to the currently running instance of VB
Public VBInstance As VBE

' Variable auf den Designer bzw. Klassenmodul "Connect"
Public Connect As Connect

'add a commandbar button
Private mobjMCBCtl As CommandBarControl
Private WithEvents mobjCBEvts As CommandBarEvents
Attribute mobjCBEvts.VB_VarHelpID = -1

' Hack Combos
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function SetFocus Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long

'the classes to work with
' hide LnkWnds if mouse over
'Private Const THUNDER_FORM        As String = "ThunderForm"         ' show LnkWnds if mouse over
'Private Const WNDCLASS_DESKED_GSK As String = "wndclass_desked_gsk" ' show LnkWnds if mouse over
'Private Const DESIGNER_WINDOW     As String = "DesignerWindow"      ' show LnkWnds if mouse over
'Private Const MSO_COMMANDBAR      As String = "MsoCommandBar"
'Private Const VBA_IMMEDIATE       As String = "Immediate"

'search lst or combo
Private Declare Function SendMessagebyString Lib _
        "user32" Alias "SendMessageA" (ByVal hWnd As Long, _
        ByVal wMsg As Long, ByVal wParam As Long, _
        ByVal lParam As String) As Long
        
' Combo Box messages
Private Const CB_FINDSTRINGEXACT = &H158

' Stop Redraw
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hWndLock As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long

'execute txt files
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

' Working constants
Private LastKey As String
Private Const Vb_a = "a"
Private Const Vb_Backslash = "\"
Private Const Vb_lBracket = "("
Private Const Vb_rBrackett = ")"
Private Const Vb_Sep = "|"
Private Const Vb_Get = "[Get]"
Private Const Vb_Let = "[Let]"
Private Const Vb_Set = "[Set]"
'Private Const Vb_Proc = "[Prc]"
Private Const Vb_Gnrl = "General"
Private Const Vb_VBForm = "VBForm"
Private Const Vb_MSForm = "MSForm"
Private Const Vb_VBMDIForm = "VBMDIForm"
Private Const Vb_UserControl = "UserControl"
Private Const Vb_DocObject = "DocObject"
Private Const Vb_ActiveXDesigner = "ActiveXDesigner"
Private Const Vb_PropPage = "PropPage"
Private Const Vb_Set1 = "Set"
Private Const Vb_Let1 = "Let"
Private Const Vb_Get1 = "Get"
Private Const Vb_Subroutine = "Subroutine"
Private Const Vb_Project = "Project"
Private Const Vb_ClassModule = "ClassModule"
Private Const Vb_ResFile = "ResFile"
Private Const Vb_StdModule = "StdModule"
Private Const Vb_Dummy = " "
Private Const Vb_open = "open"
Private Const Vb_NewProc = "NewProc"
Private Const Vb_DummyTag = "Vb_Dummy"
Private Const Vb_MDIChild = "MDIChild"

'* variables for checking *
'lsthistory
Private intcolumnWidth(0 To 2) As Byte ' *** Dim this to number of columns in listbox. ***

Private LastMemberCount As Integer
Private LastMemberName As String
Private LastMemberType As Integer
Public bRefreshing As Boolean
Private LastProjectName As String
Private LastCodeModuleName As String
Private lngPosition As Long
Private LstHistSel As Long

Private Type NodeA
    aImage As Long
    aText As String
    aTag  As String
    aKey  As String
End Type

Private MbrNodes() As NodeA

Private Type NodeB
    aImage As Long
    aText As String
    aTag  As String
    aKey  As String
    aDummyKey As String
End Type

Private CmpNodes() As NodeB
Private arrHistory() As String
Private arrHitParade() As String
Private MouseEvent As CMouseEvent
Private StopClick As Boolean

Public Sub FS_ClickSelected(ParentKey As String)
On Error Resume Next

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

For Each NodeX In tvCodeBrowser.Nodes
    If NodeX.Selected Then
        StopClick = False
        tvCodeBrowser_NodeClick NodeX
        Exit Sub
    End If
Next



End Sub


Public Function H_BuildActiveKey() As String
    On Error GoTo GetActiveProcedure_Err

    Dim prjProject As VBProject
    Dim cpCodePane As CodePane

    Dim iStartLine As Long, iStartCol As Long, iEndline As Long, iEndCol As Long
    Dim sProc As String, vaTypes As Variant, sKey As String
    Dim i As Integer

    On Error Resume Next

    'Try to get the active project
100 Set prjProject = VBInstance.ActiveVBProject

    'If we couldn't get it, display a message and quit
102 If prjProject Is Nothing Then
        Exit Function
    Else
104     sKey = prjProject.Name & Vb_Sep
    End If

    'Try to find the active code pane
106 Set cpCodePane = VBInstance.ActiveCodePane

    'If we couldn't get it, display a message and quit
108 If cpCodePane Is Nothing Then
110     H_BuildActiveKey = sKey
        Exit Function
    Else
112     sKey = sKey & cpCodePane.CodeModule.Parent.Name & Vb_Sep
    End If

    'Check if the module contains any code
114 If Not fnHasCode(cpCodePane.CodeModule) Then
116     H_BuildActiveKey = sKey
        Exit Function
    End If

    'Get where the current selection is in the module
118 cpCodePane.GetSelection iStartLine, iStartCol, iEndline, iEndCol

    'Create an array of procedure types to check for
120 vaTypes = Array(vbext_pk_Proc, vbext_pk_Get, vbext_pk_Let, vbext_pk_Set)

122 sProc = vbNullString

    'Loop through the procedure type
124 For i = 1 To 4

        'Try to get the procedure name
126     sProc = cpCodePane.CodeModule.ProcOfLine(iStartLine, CLng(vaTypes(i)))

128     If sProc <> vbNullString Then
130         H_BuildActiveKey = sKey & sProc
            Exit Function
        End If
    Next

    Exit Function

GetActiveProcedure_Err:
132 MsgBox Err.Description & vbCrLf & _
            "程序在 CodeBrowser.modSubclass.H_BuildActiveKey " & _
            "错误行数 " & Erl & vbCrLf & Err.Number, vbCritical, "错误信息"
134 Resume Next
End Function
Public Sub EV_Timer2()

100 Timer2 = True
End Sub


Public Sub EV_Timer1()

100 Timer1 = True
End Sub

Public Function H_HasCode(cMod As CodeModule) As Boolean
    On Error GoTo eH
    Dim i As Long

100 For i = 1 To cMod.CountOfLines
'! Added $ to Trim$ for performance
102     If Not Trim$(cMod.Lines(i, 1)) = vbNullString Then
104         H_HasCode = True
            Exit Function
        End If
    Next
    Exit Function

eH:
106 MsgBox Err.Description & vbCrLf & _
            "程序 CodeBrowser.modSubclass.H_HasCode " & _
            "错误行 " & Erl & vbCrLf & Err.Number, vbCritical, "错误信息"
108 Resume Next
End Function
Public Function H_ActiveProcedureStartLine(FromLine As Long) As Long
    'general = -1
    'no code = -2
    'nocodepane = -3
    'no project = -4

    On Error GoTo eH
    Dim prjProject As VBProject
    Dim cpCodePane As CodePane

    Dim iStartLine As Long, iStartCol As Long, iEndline As Long, iEndCol As Long
    Dim sProc As String
    Dim i As Long

    'Try to get the active project
100 Set prjProject = VBInstance.ActiveVBProject

    'If we couldn't get it, display a message and quit
102 If prjProject Is Nothing Then
104     H_ActiveProcedureStartLine = -4
        Exit Function
    End If

    'Try to find the active code pane
106 Set cpCodePane = VBInstance.ActiveCodePane

    'If we couldn't get it, display a message and quit
108 If cpCodePane Is Nothing Then
110     H_ActiveProcedureStartLine = -3
        Exit Function
    End If

    'Check if the module contains any code
112 If Not H_HasCode(cpCodePane.CodeModule) Then
114     H_ActiveProcedureStartLine = -2
        Exit Function
    End If

    'Get where the current selection is in the module
116 cpCodePane.GetSelection iStartLine, iStartCol, iEndline, iEndCol

118 sProc = vbNullString

    'Loop through the procedure type
    On Error Resume Next
120 For i = 0 To 3

        'Try to get the procedure name
122     sProc = cpCodePane.CodeModule.ProcOfLine(FromLine, i)

124     If sProc <> vbNullString Then
            'If we got a procedure name, find its start and end lines and quit the loop
126         H_ActiveProcedureStartLine = cpCodePane.CodeModule.ProcStartLine(sProc, i)
            'iEndline = cpCodePane.CodeModule.ProcCountLines(sProc, CLng(vaTypes(i))) + iStartLine - 1
            Exit Function
        End If
    Next

128 H_ActiveProcedureStartLine = -1
    Exit Function

eH:
130 Select Case Err.Number
        'Case 9, 35
        '    Resume Next
    Case Else
132     MsgBox Err.Description & vbCrLf & _
                "程序 CodeBrowser.modSubclass.H_ActiveProcedureStartLine " & _
                "错误行 " & Erl & vbCrLf & Err.Number, vbCritical, "错误信息"
134     Err.Clear
136     Resume Next
    End Select
End Function

Public Function H_ActiveProcedureEndLine(FromLine As Long) As Long
    'general = -1
    'no code = -2
    'nocodepane = -3
    'no project = -4

    On Error GoTo eH
    Dim prjProject As VBProject
    Dim cpCodePane As CodePane

    Dim iStartLine As Long, iStartCol As Long, iEndline As Long, iEndCol As Long
    Dim sProc As String
    Dim i As Long

    'Try to get the active project
100 Set prjProject = VBInstance.ActiveVBProject

    'If we couldn't get it, display a message and quit
102 If prjProject Is Nothing Then
104     H_ActiveProcedureEndLine = -4
        Exit Function
    End If

    'Try to find the active code pane
106 Set cpCodePane = VBInstance.ActiveCodePane

    'If we couldn't get it, display a message and quit
108 If cpCodePane Is Nothing Then
110     H_ActiveProcedureEndLine = -3
        Exit Function
    End If

    'Check if the module contains any code
112 If Not H_HasCode(cpCodePane.CodeModule) Then
114     H_ActiveProcedureEndLine = -2
        Exit Function
    End If

    'Get where the current selection is in the module
116 cpCodePane.GetSelection iStartLine, iStartCol, iEndline, iEndCol

118 sProc = vbNullString

    'Loop through the procedure type
    On Error Resume Next
120 For i = 0 To 3

        'Try to get the procedure name
122     sProc = cpCodePane.CodeModule.ProcOfLine(FromLine, i)

124     If sProc <> vbNullString Then
            'If we got a procedure name, find its start and end lines and quit the loop
126         iStartLine = cpCodePane.CodeModule.ProcStartLine(sProc, i)
128         H_ActiveProcedureEndLine = cpCodePane.CodeModule.ProcCountLines(sProc, i) + iStartLine - 1
            Exit Function
        End If
    Next

130 H_ActiveProcedureEndLine = -1
    Exit Function

eH:
132 Select Case Err.Number
        'Case 9, 35
        '    Resume Next
    Case Else
134     MsgBox Err.Description & vbCrLf & _
                "程序 CodeBrowser.modSubclass.H_ActiveProcedureEndLine " & _
                "错误行 " & Erl & vbCrLf & Err.Number, vbCritical, "错误信息"
136     Err.Clear
138     Resume Next
    End Select
End Function

Public Sub L_ResetLists()
    On Error GoTo eH