VBCommons/dev/DevTools.bas

Attribute VB_Name = "DevTools"
'================ Developer Tools =============
' Shared module version: 20220811
' Depends on: ex_WinAPI
' Required reference: Scripting, VBIDE
Option Private Module
Option Explicit

Private Const TEST_SUITE_MASK = "s_*"
Private Const TEST_NAME_MASK = "t_*"
Private Const COMPILATION_DELAY As Long = 250 ' ms

Public Function CompileVBProject(target As VBIDE.VBProject) As Boolean
  Const CONTROL_ID_COMPILE = 578
  Const MSGBOX_CLASS_ID As String = "#32770"
  Const MSGBOX_NAME As String = "Microsoft Visual Basic for Applications"
  Const WINDOW_MESSAGE_CLOSE As Long = &H10
  
  target.VBE.MainWindow.Visible = True
  With target.VBComponents(1).CodeModule
    Call .CodePane.Show
    Call .InsertLines(1, "123")
    Call .DeleteLines(1, 1)
  End With
  
  Dim btnCompile As CommandBarControl: Set btnCompile = target.VBE.CommandBars.FindControl(ID:=CONTROL_ID_COMPILE)
  If Not btnCompile.Enabled Then
    CompileVBProject = False
    Exit Function
  End If
  
  Call btnCompile.Execute
  
  Call Sleep(COMPILATION_DELAY)
  
  Dim nHwnd&: nHwnd = FindWindow(MSGBOX_CLASS_ID, MSGBOX_NAME)
  CompileVBProject = nHwnd = 0
  If Not CompileVBProject Then _
    Call PostMessage(nHwnd, WINDOW_MESSAGE_CLOSE, 0&, 0&)
End Function

Public Function UpdateVersionStamp(target As VBIDE.VBProject, sVersion$) As Boolean
  UpdateVersionStamp = False
  
  On Error Resume Next
  Dim iModule As VBComponent: Set iModule = target.VBComponents("Main")
  If iModule Is Nothing Then _
    Exit Function
  
  Dim iCode As CodeModule: Set iCode = iModule.CodeModule
  
  Dim nLineStart&: nLineStart = 1
  Dim nLineEnd&: nLineEnd = iCode.CountOfLines
  
  Dim nColumnStart&: nColumnStart = 1
  Dim nColumnEnd&: nColumnEnd = 255
  
  If Not iCode.Find("Public Const PRODUCT_VERSION", nLineStart, nColumnStart, nLineEnd, nColumnEnd) Then _
    Exit Function
  Call iCode.ReplaceLine(nLineEnd, "Public Const PRODUCT_VERSION = """ & sVersion & """")
  
  UpdateVersionStamp = True
End Function

Public Function PrepareSkeletonFor(target As Object)
  On Error Resume Next
  Call target.Application.Run("'" & target.Name & "'" & "!Dev_PrepareSkeleton")
End Function

Public Function ExtractProperties(sLines() As String, ByRef nCurrent&, ByRef oSink As Scripting.Dictionary)
  ExtractProperties = False
  
  Do While nCurrent <= UBound(sLines, 1)
    Dim sLine$: sLine = sLines(nCurrent)
    nCurrent = nCurrent + 1
    If sLine Like "%%*" Then _
      Exit Do
      
    Dim nSeparator&: nSeparator = VBA.InStr(1, sLine, "=")
    If nSeparator = 0 Then _
      GoTo NEXT_LINE
    If VBA.Left(sLine, 1) = "#" Then _
      GoTo NEXT_LINE
    
    Dim sKey$: sKey = VBA.Trim(VBA.Left(sLine, nSeparator - 1))
    Dim sValue$: sValue = VBA.Trim(Right(sLine, VBA.Len(sLine) - nSeparator))
    If oSink.Exists(sKey) Then _
      Exit Function
    Call oSink.Add(sKey, sValue)
NEXT_LINE:
  Loop
  
  ExtractProperties = True
End Function

Public Function Dev_CountPublicAPI(target As VBIDE.CodeModule) As Long
  Dim nLine&
  For nLine = 1 To target.CountOfLines Step 1
    If InStr(1, target.Lines(nLine, 1), "Public") <> 0 Then _
      Dev_CountPublicAPI = Dev_CountPublicAPI + 1
  Next nLine
End Function

Public Function Dev_ScanFunctions(target As VBIDE.CodeModule) As Collection ' of CDS_InfoFunction
  Dim cResult As New Collection

  Dim currentFunc As CDS_InfoFunction
  Dim lastFunc As New CDS_InfoFunction
  Dim nLine&
  For nLine = 1 To target.CountOfLines Step 1
    Set currentFunc = ExtractProcedure(target, nLine)
    If lastFunc.name_ <> currentFunc.name_ And currentFunc.name_ <> vbNullString Then
      currentFunc.isPublic_ = IsPublicFunc(target, currentFunc)
      Call cResult.Add(currentFunc)
    End If
    Set lastFunc = currentFunc
  Next nLine
  
  Set Dev_ScanFunctions = cResult
End Function

Public Function Dev_ScanTests(target As VBIDE.VBProject, ByRef cTestsDB As Scripting.Dictionary) As Long
  Dim nCount&: nCount = 0
  Dim aComponent As VBIDE.VBComponent
  Dim iComponents As VBIDE.VBComponents: Set iComponents = target.VBComponents
  Dim tests As Collection
  For Each aComponent In iComponents
    If aComponent.Type <> vbext_ct_ClassModule Then _
      GoTo NEXT_COMPONENT
    If Not aComponent.Name Like TEST_SUITE_MASK Then _
      GoTo NEXT_COMPONENT

    Set tests = New Collection
    Dim funcs As Collection: Set funcs = Dev_ScanFunctions(aComponent.CodeModule)
    Dim aFunc As CDS_InfoFunction
    For Each aFunc In funcs
      If aFunc.name_ Like TEST_NAME_MASK And aFunc.isPublic_ Then _
        Call tests.Add(aFunc.name_)
    Next aFunc

    If tests.Count > 0 Then
      Call cTestsDB.Add(aComponent.Name, tests)
      nCount = nCount + tests.Count
    End If
NEXT_COMPONENT:
  Next aComponent

  Set iComponents = Nothing
  Set aComponent = Nothing

  Dev_ScanTests = nCount
End Function

Public Function Dev_RemoveDebugCode(target As VBIDE.VBProject)
  Dim selectedComps As New Collection
  Dim aComponent As VBIDE.VBComponent
  For Each aComponent In target.VBComponents
    If Dev_IsTestingModule(aComponent.Name) Then _
      Call selectedComps.Add(aComponent)
  Next aComponent
  
  For Each aComponent In selectedComps
    Call target.VBComponents.Remove(aComponent)
  Next aComponent
End Function

Public Function Dev_IsTestingModule(sName$) As Boolean
  Dev_IsTestingModule = True
  
  If sName Like TEST_SUITE_MASK Then _
    Exit Function
  If sName Like "DevHelper*" Then _
    Exit Function
  If sName Like "DevTester*" Then _
    Exit Function
  If sName Like "DevTesterUI*" Then _
    Exit Function
  If sName Like "API_MockInteraction*" Then _
    Exit Function
  
  Dev_IsTestingModule = False
End Function

' =====
Private Function ExtractProcedure(target As VBIDE.CodeModule, nLine&) As CDS_InfoFunction
  Set ExtractProcedure = New CDS_InfoFunction
  ExtractProcedure.name_ = target.ProcOfLine(nLine, ExtractProcedure.type_)
End Function

Private Function IsPublicFunc(target As VBIDE.CodeModule, func As CDS_InfoFunction) As Boolean
  Dim nStart&: nStart = target.ProcBodyLine(func.name_, func.type_)
  Dim sTxt$: sTxt = target.Lines(nStart, 1)
  IsPublicFunc = InStr(1, sTxt, "Private") = 0
End Function