Access Debug

VBA

Option Compare Database
Option Explicit
Public objExcel As Object
Private mnu1 As clsMnuEvnt
Private mnu2 As clsMnuEvnt
Private Sub testIn()
    
    Dim cb As CommandBar
    Dim ctl1 As CommandBarControl
    
    Set cb = Application.VBE.CommandBars("Code Window")
    Set mnu1 = New clsMnuEvnt
    Set ctl1 = mnu1.Init(cb, "JmpFunc", "JmpFunction", 1)
    
End Sub
Private Sub testOut()

    Dim ctl As CommandBarControl
    Dim cb As CommandBar
    For Each cb In Application.VBE.CommandBars
        If cb.Name = "Code Window" Then
            For Each ctl In cb.Controls
                If ctl.Caption = "JmpFunc" Then
                    ctl.Delete
                End If
            Next
        End If
    Next

End Sub
Sub testAddMenuControl()
    AddMenuControl
    'DelMenuControl
End Sub
Private Sub AddMenuControl(Optional strMenuName As String = "VBEMenu")
    
    Dim cb As CommandBar
    Dim ctl1 As CommandBarControl
    
    Set cb = Application.VBE.CommandBars.Add(strMenuName, msoBarTop, , True)
    Set mnu2 = New clsMnuEvnt
    Set ctl1 = mnu2.Init(cb, "Debug", "InsertDebugCode")
    cb.Visible = True

End Sub
Private Sub DelMenuControl(Optional strMenuName As String = "VBEMenu")
    
    Dim ctl As CommandBarControl
    Dim cb As CommandBar
    For Each cb In Application.VBE.CommandBars
        If cb.Name = strMenuName Then
            cb.Delete
        End If
    Next
End Sub
Public Sub JmpFunction()
    
    Dim strFunc As String
    Dim strLine As String
    Dim lngRwSt As Long
    Dim lngClSt As Long
    Dim lngRwEd As Long
    Dim lngClEd As Long
    Dim lngST As Long
    Dim lngED As Long
    
    Application.VBE.ActiveCodePane.GetSelection lngRwSt, lngClSt, lngRwEd, lngClEd
    strLine = Application.VBE.ActiveCodePane.CodeModule.Lines(lngRwSt, 1)
    
    lngST = lngClSt
    Do While lngST > 0
        If Mid(strLine, lngST, 1) = "." Or _
           Mid(strLine, lngST, 1) = " " Or _
           Mid(strLine, lngST, 1) = ")" Or _
           Mid(strLine, lngST, 1) = "(" Then
           Exit Do
        End If
        lngST = lngST - 1
    Loop
    
    lngED = lngClSt
    Do While lngED < Len(strLine)
        If Mid(strLine, lngED, 1) = "." Or _
           Mid(strLine, lngED, 1) = " " Or _
           Mid(strLine, lngED, 1) = ")" Or _
           Mid(strLine, lngED, 1) = "(" Then
           Exit Do
        End If
        lngED = lngED + 1
    Loop
    
    JumpToFunction Mid(strLine, lngST + 1, lngED - lngST)
    
End Sub
Private Sub JumpToFunction(strFunction As String)

    Dim vbComp As VBComponent
    Dim strProc As String
    Dim strOld As String
    Dim i As Long
    
    For Each vbComp In Application.VBE.ActiveVBProject.VBComponents
        With vbComp.CodeModule
            For i = 1 To .CountOfLines
                strProc = .ProcOfLine(i, VBIDE.vbext_pk_Proc)
                If strOld <> strProc Then
                    strOld = strProc
                    Debug.Print strOld
                End If
                If strFunction = strProc Then
                    Debug.Print vbComp.Name & " " & i
                    vbComp.CodeModule.CodePane.Window.SetFocus
                    vbComp.CodeModule.CodePane.SetSelection i, 1, i, 1
                    vbComp.CodeModule.CodePane.TopLine = i
                    Exit Sub
                End If
            Next i
        End With
    Next

End Sub
Public Sub InsertDebugCode()
    
    Dim wbk As Object
    Dim vbComp As VBComponent
    Dim strProc As String
    Dim i As Long
    Dim lngLines As Long
    
    Set objExcel = CreateObject("Excel.Application")
    objExcel.Visible = True
    Set wbk = objExcel.Workbooks.Add
    For Each vbComp In Application.VBE.ActiveVBProject.VBComponents
        lngLines = vbComp.CodeModule.CountOfLines
        For i = 1 To lngLines
            If strProc <> vbComp.CodeModule.ProcOfLine(i, vbext_pk_Proc) Then
                If strProc <> "" Then
                    vbComp.CodeModule.InsertLines i - 2, "    '-------------------------------------for Debug-------------------------------------" & vbCrLf & _
                                                         "    InsertDebugToExcel """ & wbk.Name & """,""" & vbComp.Name & """," & i & ",""" & strProc & """," & "strSQL" & vbCrLf & _
                                                         "    '-------------------------------------for Debug-------------------------------------"
                    i = i + 3
                    lngLines = lngLines + 3
                End If
                strProc = vbComp.CodeModule.ProcOfLine(i, vbext_pk_Proc)
            End If
        Next i
        vbComp.CodeModule.InsertLines lngLines - 1, "    '-------------------------------------for Debug-------------------------------------" & vbCrLf & _
                                                    "    InsertDebugToExcel """ & wbk.Name & """,""" & vbComp.Name & """," & i & ",""" & strProc & """," & "strSQL" & vbCrLf & _
                                                    "    '-------------------------------------for Debug-------------------------------------"
    Next
    
End Sub
Public Sub InsertDebugToExcel(wbkName As String, strVbComp As String, lngLine As Long, strProc As String, strSQL As String)
        
    Dim wbk As Object
    Dim i As Long
    i = 2
    
    If objExcel Is Nothing Then
        Exit Sub
    Else
        If objExcel.Workbooks(wbkName) Is Nothing Then
            Exit Sub
        End If
    End If
    Set wbk = objExcel.Workbooks(wbkName)
    With wbk.Worksheets(1)
        Do
            If .Cells(i, 1).Value = "" Then
                .Cells(i, 1).Value = strVbComp
                .Cells(i, 2).Value = lngLine
                .Cells(i, 3).Value = strProc
                .Cells(i, 4).Value = strSQL
                Exit Sub
            Else
                i = i + 1
            End If
        Loop
    End With
    
    
    
End Sub