Attribute VB_Name = "modVBSCAN"
Option Explicit

Global gsMAKName As String      ' full name of project mak file
Global gsMAKPath As String      ' path of project make file
Global gsModPath() As String    ' full path and name of module files
Global giModCnt As Integer      ' number of modules
Global gsSrch() As String       ' array of strings to search for
Global gsDtlView As String      ' Detail View
Global gNumHits As Long         ' number of mathing lines
Global giCase As Integer        ' ignore case flag
Global giCmnts As Integer       ' ignore comments flag
Global giStopScan As Integer    ' abort scanning
Global Const DEFAULT = 0        ' 0 - Default
Global Const HOURGLASS = 11     ' 11 - Hourglass
Global gsDocComment As String
Global gsDocFile As String
Global gsDocType As String

Public Sub Main()
gsDocComment = "'!d"
gsDocFile = "c:\temp\vbscan.htm"
gsDocType = "HTML"
frmVbScan.Show
End Sub
Function rdPrjFile(sFName As String) As Integer

    On Error GoTo rdPrjFile_err
    rdPrjFile = -1

    Dim inf As Double: inf = 1
    Dim sbuf$, c$, sExt$, l%, i%, rc%
    Dim sfullname As String
    Dim sshortName As String
    Dim fType As String
    Dim ol As Outline
    
    Set ol = frmVbScan.OL1
    ol.Clear

    ' add project
    
    giModCnt = 0
    Erase gsModPath
    giModCnt = giModCnt + 1
    
    Open sFName For Input As inf
    sbuf = ""
    Do While Not EOF(inf) And (giStopScan = 0)
        DoEvents
        c = Input(1, inf)
        If c <> Chr(10) Then
            sbuf = sbuf & c
        Else
            sExt = UCase(Left(Right(sbuf, 4), 3))
            If (sExt = "BAS" Or sExt = "FRM" Or sExt = "CLS" Or sExt = "CTL") Then
            
                Call cleanupNames(sbuf, sshortName, sfullname)
                
                ol.AddItem sshortName
                ol.Indent(ol.ListCount - 1) = 1
                fType = Word(sbuf, 1, "=")
                ol.List(ol.ListCount - 1) = fType & ": " & sshortName
                frmVbScan.Refresh

                ' save index of gsModPath in ItemData

                giModCnt = giModCnt + 1
                ReDim Preserve gsModPath(giModCnt)
                gsModPath(giModCnt) = sfullname
                ol.ItemData(ol.ListCount - 1) = giModCnt

                rc = rdMODFile(sfullname)
                If (rc <> 0) Then
                    rdPrjFile = 1
                    GoTo rdPrjFile_err
                End If
            End If
            sbuf = ""

        End If
    Loop ' while not EOF
                    
    rdPrjFile = 0
    
rdPrjFile_err:
   
    If Err <> 0 Then
        MsgBox ("Error [rdPrjFile] " & vbCrLf & Error$)
    End If
    
    Close inf

End Function

Private Sub cleanupNames(sbuf As String, sshortName As String, sfullname As String)
    Dim l As Integer
    Dim i As Integer

    l = Len(sbuf) - 1
    sbuf = Trim$(Left(sbuf, l)) ' get rid of CR
    
    i = InStr(sbuf, "=")
    If (i <> 0) Then sbuf = Trim$(Mid$(sbuf, i + 1))
    
    i = InStr(sbuf, ";")
    If (i <> 0) Then sbuf = Trim$(Mid$(sbuf, i + 1))
    
    l = Len(sbuf)
    i = RInStr(sbuf, "\")
    If (i = 0) Then
        sshortName = sbuf
        sfullname = gsMAKPath & sbuf
    Else
        sshortName = Trim$(Right(sbuf, l - i))
        sfullname = sbuf
    End If
End Sub

Function rdMODFile(sFName As String) As Integer

    On Error GoTo rdModFile_err
    rdMODFile = -1
    Dim inf As Double: inf = 2
    Dim sbuf$, c$, sExt$, l%, w$, rc%, w2$
    Dim ol As Outline
    Dim sn$
    Dim iNoComments%
    
    Set ol = frmVbScan.OL1

    Open sFName For Input As inf
    sbuf = ""
    sn = "General"
    Do While Not EOF(inf)
        c = Input(1, inf)
        If c <> Chr(10) Then
            ' keep adding characters until new line encountered
            sbuf = sbuf & c
        Else
            sbuf = Left$(sbuf, Len(sbuf) - 1)
            If Right$(sbuf, 1) <> "_" Then
                'Debug.Print sbuf
                w = Word(sbuf, 1)
                
                If w = "Public" Or w = "Private" Or w = "Friend" Then l = 2 Else l = 1
                
                w = Word(sbuf, l)
                
                Select Case w
                Case "Function", "Sub"
                    w = Left$(w, 3) & " " & Word(sbuf, l + 1)
                Case "Property"
                    w = Left$(w, 3) & " " & Word(sbuf, l + 1) & " " & Word(sbuf, l + 2)
                Case Else
                    l = 0
                End Select
                
                If l > 0 Then
                    l = InStr(w, "(")
                    If l > 0 Then w = Left$(w, l - 1)
                    'sn = w ' mej modified to show full function declaration
                    sn = sbuf
                End If
                If (giCmnts) Then
                    l = InStr(sbuf, "'")
                    If (l <> 0) Then sbuf = Left(sbuf, l)
                End If
                rc = ScanLine(sbuf, gsSrch())
                If (rc <> 0) Then
                    If (sn <> "") Then
                        ol.AddItem sn
                        ol.Indent(ol.ListCount - 1) = 2
                        sn = ""
                    End If
                    ol.AddItem TrimWS(sbuf)
                    ol.Indent(ol.ListCount - 1) = 3
                    gNumHits = gNumHits + 1
                End If
                sbuf = ""
            Else
                
                ' trim off line continuation character
                
                sbuf = Left$(sbuf, Len(sbuf) - 1)
            End If
            
        End If
    Loop ' while not EOF
    
    Set ol = Nothing
    

    rdMODFile = 0

rdModFile_err:
    If Err <> 0 Then
        If MsgBox("Error [rdModFile] " & sFName & " " & Error$, vbOKCancel) = vbCancel Then
            rdMODFile = 1
        Else
            rdMODFile = 0
        End If
    End If
    
    Close inf
    Exit Function
End Function

Function rdRoutine(sFName As String, sRtn As String) As Integer

    Debug.Print "rdRoutine: fname=" & sFName & " rtn=" & sRtn

    On Error GoTo rdRoutine_err
    rdRoutine = -1
    
    Dim inf As Double: inf = 2
    Dim sbuf$, c$, w$, rc%, l%
    
    Open sFName For Input As inf
    sbuf = ""
    Do While Not EOF(inf)
        c = Input(1, inf)
        If c <> Chr(10) Then
            sbuf = sbuf & c
        Else
            sbuf = Left(sbuf, Len(sbuf) - 1)
            
            w = Word(sbuf, 1)
            
            If w = "Public" Or w = "Private" Or w = "Friend" Then l = 2 Else l = 1
            
            w = Word(sbuf, l)
            
            Select Case w
            Case "Function", "Sub"
                w = Left$(w, 3) & " " & Word(sbuf, l + 1)
            Case "Property"
                w = Left$(w, 3) & " " & Word(sbuf, l + 1) & " " & Word(sbuf, l + 2)
            Case Else
                l = 0
            End Select
            
            If l > 0 Then
                l = InStr(w, "(")
                If l > 0 Then w = Left$(w, l - 1)
                
                If (sbuf = sRtn) Then
                    
                    If gsDtlView = "List" Then
                        rc = Rtn2Lst("End " & Left(w, 3), inf, sbuf)
                    Else
                        rc = Rtn2OL("End " & Left(w, 3), inf, sbuf)
                    End If
                    
                    If (rc <> 0) Then
                        GoTo rdRoutine_err
                    Else
                        Exit Do
                    End If
                End If
            End If
            sbuf = ""
        End If
    Loop ' while not EOF
    
    rdRoutine = 0

rdRoutine_end:
    Close inf
    Exit Function

rdRoutine_err:
    MsgBox "Error [rdRoutine] " & Error$ & " #" & Err
    GoTo rdRoutine_end
End Function

Function rdGeneral(sFName As String) As Integer

    On Error GoTo rdRoutine_err
    rdGeneral = -1
    
    Dim inf As Double: inf = 2
    Open sFName For Input As inf
    Dim rc As Integer
        
    If gsDtlView = "List" Then
        rc = Rtn2Lst("", inf, "")
    Else
        rc = Rtn2OL("", inf, "")
    End If
    
    rdGeneral = 0

rdRoutine_end:
    Close inf
    Exit Function

rdRoutine_err:
    MsgBox "Error [rdRoutine] " & Error$ & " #" & Err
    GoTo rdRoutine_end
End Function

Function RInStr(sSource As String, sSearch As String) As Integer
    Dim i, l As Integer
    l = Len(sSource)
    For i = l To 1 Step -1
        If Mid$(sSource, i, 1) = sSearch Then
            RInStr = i
            Exit Function
        End If
    Next
    RInStr = 0
    Exit Function
End Function

Function Rtn2Lst(sTerm As String, inf As Double, sRtnHdr As String) As Integer

    On Error GoTo Rtn2lst_err
    Rtn2Lst = -1
    
    Dim sbuf$, tbuf$, c$, w$, rc%, l%
    Dim Lst As ListBox
    Dim i%
    
    Set Lst = frmRtnLst.List1
    
    Lst.Clear
    If (Len(sRtnHdr)) Then Lst.AddItem sRtnHdr
    
    sbuf = ""
    Do While Not EOF(inf)
        c = Input(1, inf)
        If c <> Chr(10) Then
            sbuf = sbuf & c
        Else
            sbuf = Left(sbuf, Len(sbuf) - 1)
            tbuf = TrimWS(sbuf)
            If Len(tbuf) > 0 Then
                Lst.AddItem sbuf
                Lst.ItemData(Lst.ListCount - 1) = 0
                If (giCmnts) Then
                    l = InStr(tbuf, "'")
                    If (l <> 0) Then tbuf = Left(tbuf, l)
                End If
                rc = ScanLine(tbuf, gsSrch())
                If (rc <> 0) Then
                    Lst.ItemData(Lst.ListCount - 1) = 1
                    Lst.Selected(Lst.ListCount - 1) = 1
                End If
                If Len(sTerm) > 0 And Left(tbuf, 7) = sTerm Then Exit Do ' exit at end of routine
                sbuf = ""
            End If
        End If
    
    Loop ' while not EOF
    
    Rtn2Lst = 0

Rtn2Lst_end:
    Close inf
    Exit Function

Rtn2lst_err:
    MsgBox "Error [Rtn2Lst] " & Error$ & " #" & Err
    GoTo Rtn2Lst_end

End Function

Function Rtn2OL(sTerm As String, inf As Double, sRtnHdr As String) As Integer
    
    On Error GoTo Rtn2OL_err
    Rtn2OL = -1
    
    Dim sbuf$, c$, w$, i%, l%, tbuf$
    Dim ol As Outline
    Dim nest%
    
    Set ol = frmRtnOL.OL1
    ol.Clear
    nest = 1
    sbuf = ""
    If (Len(sRtnHdr)) Then ol.AddItem sRtnHdr
    Do While Not EOF(inf)
        c = Input(1, inf)
        If c <> Chr(10) Then
            sbuf = sbuf & c
        Else
            sbuf = Left(sbuf, Len(sbuf) - 1)
            sbuf = TrimWS(sbuf)
            If Len(sbuf) > 0 Then
                
                If Len(sTerm) > 0 And Left(sbuf, 7) = sTerm Then
                    ol.AddItem sbuf
                    ol.Indent(ol.ListCount - 1) = 1
                    Exit Do ' exit at end of routine
                End If
                
                w = Word(sbuf, 1)
    
                If (w = "End") Then w = w & " " & Word(sbuf, 2)
                
                ol.AddItem sbuf
                Select Case w
                Case "If", "While", "Do", "Select", "For"
                    ol.Indent(ol.ListCount - 1) = nest
                    i = 1
                    If (w = "If") Then ' check for same-line if
                        l = InStr(sbuf, "'")
                        If (l = 0) Then l = Len(sbuf) + 1
                        tbuf = Trim$(Left(sbuf, l - 1))
                        If Right(tbuf, 4) <> "Then" Then i = 0
                    End If
                    nest = nest + i
                Case "End If", "End Select", "Wend", "Loop", "Next"
                    ol.Indent(ol.ListCount - 1) = nest - 1
                    nest = nest - 1
                Case "ElseIf", "Else", "Case"
                    ol.Indent(ol.ListCount - 1) = nest - 1
                Case Else
                    ol.Indent(ol.ListCount - 1) = nest
                End Select
                
                sbuf = ""

            End If
        End If
    
    Loop ' while not EOF
    
    Rtn2OL = 0

Rtn2OL_end:
    Exit Function

Rtn2OL_err:
    
    MsgBox "Error [Rtn2OL] " & Error$ & " #" & Err
    GoTo Rtn2OL_end
End Function

Function SaveCSR(sFile As String) As Integer
    On Error GoTo SaveCSR_err
    SaveCSR = -1

    Dim oFile$


    oFile = sFile

    Dim i%, m%
    Dim out#: out = 1
    Dim TABc$: TABc = Chr(9)
    Dim ol As Outline
    
    Open oFile For Output As out

    Print #out, "VBScan Report for " & gsMAKName & " -- " & Now
    Print #out, String(80, "-")
    Print #out, ""
    Print #out, "Ignore Comments: "; IIf(giCmnts = 0, "No", "Yes")
    Print #out, "Ignore Case    : "; IIf(giCase = 0, "No", "Yes")
    Print #out, ""
    
    m = UBound(gsSrch)

    For i = 1 To m
        Print #out, "Search " & i & ": [" & gsSrch(i) & "]"
    Next
    Print #out, String(80, "-")


    Set ol = frmVbScan.OL1
    m = ol.ListCount
    For i = 0 To m - 1
        Print #out, String(ol.Indent(i) - 1, TABc) & ol.List(i)
    Next

    SaveCSR = 0

SaveCSR_end:
    On Error Resume Next
    Close out
    Exit Function

SaveCSR_err:
    MsgBox "Error [SaveCSR] " & Error$ & " #" & Err
    GoTo SaveCSR_end

End Function

Function MakeHtm(sFile As String) As Integer
    On Error GoTo MakeHtm_err
    MakeHtm = -1

    Dim ol As Outline
    
    '-------------------------------------------------------------------------------
    ' create and open a new htm file and save as the specified file name
    '-------------------------------------------------------------------------------

    Dim f As Long
    f = FreeFile
    Open sFile For Output As f

    '-------------------------------------------------------------------------------
    ' Add document header
    '-------------------------------------------------------------------------------

    Print #f, "<HTML>"
    Print #f, "<HEAD>"
    Print #f, "<TITLE>" & gsMAKName & "</TITLE>"
    Print #f, "</HEAD>"

    '-------------------------------------------------------------------------------
    ' Walk the outline adding the outline contents to the word doc.  Use Header styles
    ' for indent levels < 3.
    '-------------------------------------------------------------------------------
    
    Set ol = frmVbScan.OL1

    Dim sStyle As String
    Dim sText As String
    Dim iBgn As Integer
    Dim i As Integer
    
    For i = 0 To ol.ListCount - 1
    
        If ol.Indent(i) = 1 Then
            ol.Expand(i) = True
            ol.ListIndex = i
            ol.Refresh
        End If

    
        sStyle = "p>" ' default style is none
        
        sText = ol.List(i)
                
        If ol.Indent(i) < 3 Then
            sStyle = "H" & ol.Indent(i) & ">"
            If ol.Indent(i) = 1 Then sText = UCase(sText)
        Else
        
            ' clean up doc comment lines
            
            If sText = gsDocComment Then sText = ""   ' convert blank doc comments to blank line
        
            iBgn = InStr(1, sText, gsDocComment, vbTextCompare)
            If iBgn <> 0 Then
                
                If iBgn = 1 Then
                    
                    ' strip the comment off of begin-of-line comments
                
                    iBgn = Len(gsDocComment) + 1
                    sText = Trim$(Mid$(sText, iBgn))
                Else
                    
                    ' Cut the comment out of in-line comments and replace with a ":"
                    
                    sText = Left$(sText, iBgn - 1) & " : " & Mid$(sText, iBgn + Len(gsDocComment))
                End If
                
            End If
        End If
        
        'sText = sText & "<p>"
        
        'Debug.Print sStyle, sText
        
        If sStyle <> "" Then
            Print #f, "<" & sStyle & sText & "</" & sStyle
        Else
            Print #f, sText & vbCrLf
        End If
    
    Next

    MakeHtm = 0
    
    '-------------------------------------------------------------------------------
    ' End HTML Generation
    '-------------------------------------------------------------------------------
    
    Print #f, "</BODY>"
    Print #f, "</HTML>"

MakeHtm_err:
        
    Close f
    
    If Err Then Err.Raise Err.Number, "Error [MakeHtm] " & Err.Description

End Function

Function SaveRtnOL()
    On Error GoTo SaveRtnOL_err
    SaveRtnOL = -1

    Dim oFile$
    Dim CMD1 As CommonDialog
    Dim sRtn$: sRtn = Trim$(frmRtnOL.Caption)

    Set CMD1 = frmVbScan.CMD1
    
    CMD1.Filter = "VBScan Routine Files (*.CS1)|*.CS1"
    CMD1.DialogTitle = "Select Output File"
    CMD1.FilterIndex = 1
    CMD1.FileName = "VBSCAN.CS1"
    CMD1.CancelError = False
    CMD1.Action = 2
    If CMD1.FileName <> "" Then
         oFile = CMD1.FileName
    Else
        SaveRtnOL = 0
        Exit Function
    End If

    Dim i%, m%
    Dim out#: out = 1
    Dim TABc$: TABc = Chr(9)
    Dim ol As Outline
    
    Open oFile For Output As out

    Print #out, sRtn
    Print #out, "' "; Now
    Print #out, "'"; String(80, "-")
    Print #out, ""
    
    Set ol = frmRtnOL.OL1
    m = ol.ListCount
    For i = 0 To m - 1
        Print #out, String(ol.Indent(i) - 1, TABc) & ol.List(i)
    Next

    SaveRtnOL = 0

SaveRtnOL_end:
    On Error Resume Next
    Close out
    Exit Function

SaveRtnOL_err:
    MsgBox "Error [SaveRtnOL] " & Error$ & " #" & Err
    GoTo SaveRtnOL_end
End Function

Function ScanLine(sSource As String, sSrch() As String) As Integer
    
    On Error GoTo ScanLine_err
    ScanLine = 0
    
    Dim i%
    Dim m%
    
    m = UBound(sSrch)

    For i = 1 To m
        If InStr(1, sSource, sSrch(i), giCase) <> 0 Then
            ScanLine = 1
            Exit Function
        End If
    Next

    Exit Function

ScanLine_err:
    MsgBox "Error [ScanLine] " & Error$ & " #" & Err
    Exit Function

End Function

Function TrimWS(s_In As String) As String
' trim leading and trailing (tabs and spaces)

    TrimWS = ""
    
    Dim l%, i%
    Dim SOut
    Dim c$
    Dim TABc$: TABc = Chr(9)

    SOut = Trim$(s_In)

    l = Len(SOut)
    If (l = 0) Then Exit Function
    
    For i = 1 To l
        c = Left(SOut, 1)
        If c = TABc Or c = " " Then
            SOut = Right(SOut, l - 1)
            l = l - 1
        End If
    Next
    For i = l To 1
        c = Right(SOut, 1)
        If c = TABc Or c = " " Then
            SOut = Left(SOut, l - 1)
            l = l - 1
        End If
    Next
    TrimWS = SOut
End Function

Function Word(ss As String, i As Integer, Optional delim As String = " ") As String
' Parse a blank delimeted string
' ss = string to be parsed
' i = number of the word to be returned

' return the i'th word in string ss.  Words are delimited by blanks
' if i < 1 or i > number of words in ss, blank is returned

    On Error GoTo Word_err
    Word = ""

    Dim s$: s = Trim$(ss)
    Dim l%: l = Len(s)
    Dim c%: c = 0 ' word count
    Dim b%: b = 1 ' begining each parsed word
    Dim e%: e = 0 ' end of each parsed word
    
    If l = 0 Then Exit Function
    If i < 1 Then Exit Function
    
    Do While e <= l
        e = InStr(b, ss, delim)
        
        If e = 0 Then e = l + 1
        c = c + 1
        If (c = i) Then
            Word = Mid$(ss, b, e - b)
            Exit Function
        End If
        For b = e To l Step 1 ' skip white space
            If Mid$(ss, b, 1) <> " " Then Exit For
        Next
    Loop
    
    On Error GoTo 0
    Exit Function

Word_err:
    MsgBox "Error [Word] " & Error$ & " #" & Err
    Exit Function
End Function

