VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsVBPSrcReporter"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' clsVBPSrcReporter: Report Source Code for all modules referenced by a VBP file
Option Explicit

Public Event status(ByVal msg As String)

Public Function header() As String
    header = "VBPPATH" & vbTab & "VBPNAME" & vbTab & "MODNAME" & vbTab & "MODTIME" & vbTab & "MODTYPE" & vbTab & "LINENUM" & vbTab & "LINETYPE" & vbTab & "LINETEXT"
End Function

Public Sub processFile(fil As Scripting.File, rpt As Scripting.TextStream)
    
    Const FUNC_NAME$ = "processFile"
    On Error GoTo errorHandler
    
    Dim filpath As String: filpath = fil.ParentFolder.Path
    Dim filname As String: filname = fil.name
    Dim modtype As String
    Dim modname As String
    Dim modpath As String
    
    Dim fileSys As FileSystemObject
    Set fileSys = New FileSystemObject
    
    Dim txtfil As Scripting.TextStream
    Set txtfil = openInputText(fil.Path, fileSys)
    
    Dim l As Long
    l = 1
    
    Dim s As String
    s = txtfil.ReadAll()
    
    Dim arr() As String
    arr = Split(s, vbCrLf)
    
    Dim v As Variant
    For Each v In arr
        
        modtype = ""
        Dim sLine As String
        sLine = LCase$(v)
        
        If ( _
        sLine Like "form=*.frm" Or _
        sLine Like "class=*.cls" Or _
        sLine Like "module=*.bas" Or _
        sLine Like "usercontrol=*.ctl" Or _
        sLine Like "propertypage=*.pag") _
        Then
        
            sLine = v
            
            Dim j As Integer
            Dim i As Integer
            
            i = InStr(sLine, "=") + 1
            
            modtype = Left$(sLine, i - 2)
            
            sLine = Trim$(Mid$(sLine, i)) ' object name; path
            
            j = InStrRev(sLine, ";")
            
            If j = 0 Then j = 1 Else j = j + 1
            
            sLine = Trim$(Mid$(sLine, j)) ' object path
            
            j = InStrRev(sLine, "\")
            
            If j = 0 Then j = 1 Else j = j + 1
            
            modname = Trim$(Mid$(sLine, j)) ' file name
            
            If j = 1 Then
                modpath = filpath & "\" & modname
            Else
                modpath = sLine
            End If
            
            Call addLines(rpt, filpath, filname, modpath, modname, modtype)
      
        Else
            
          Call writeRpt(rpt, _
            filpath & vbTab & _
            fil.name & vbTab & _
            fil.name & vbTab & _
            fil.DateLastModified & vbTab & _
            "Project" & vbTab & _
            l & vbTab & _
            "PRJ" & vbTab & _
            v & vbCrLf)
            
            l = l + 1
            
        End If
    
    Next v
    
errorHandler:
    
    If Not txtfil Is Nothing Then txtfil.Close
    Set fileSys = Nothing
    Set txtfil = Nothing
    
    If Err Then _
        Err.Raise Err.Number, Description:=TypeName(Me) & "::" & FUNC_NAME$ & " " & _
        vbCrLf & "[" & fil.Path & "]" & _
        vbCrLf & Err.Description
        
End Sub

Private Sub addLines(rpt As Scripting.TextStream, vbppath As String, vbpname As String, modpath As String, modname As String, modtype As String)
    Const FUNC_NAME$ = "addLines"
    On Error GoTo errorHandler
    
    
    Dim fileSys As FileSystemObject
    Set fileSys = New FileSystemObject
    
    '----------------------------------------------------
    ' open the module
    '----------------------------------------------------
    
    Dim txtfil As Scripting.TextStream
    Set txtfil = openInputText(modpath, fileSys)
    
    '----------------------------------------------------
    ' parse the module into an array of lines
    '----------------------------------------------------
    
    Dim s As String
    s = txtfil.ReadAll()
    
    Dim arr() As String
    arr = Split(s, vbCrLf)
    
    '----------------------------------------------------
    ' default the line type for forms/ctls to GUI since
    ' the GUI spec is always at the top of the form/ctl.
    '----------------------------------------------------
    
    Dim linetype As String
    
    If modtype = "Form" Or modtype = "UserControl" Then
        linetype = "GUI"
    Else
        linetype = "COD"
    End If
    
    '----------------------------------------------------
    ' get modified date
    '----------------------------------------------------
    
    Dim LastModDate As Date
    Dim fil As Scripting.File
    Set fil = fileSys.GetFile(modpath)
    LastModDate = fil.DateLastModified
    
    '----------------------------------------------------
    ' process each line
    '----------------------------------------------------
    
    Dim l As Long
    l = 1
    
    Dim v As Variant
    For Each v In arr
            
        Dim sLine As String
        sLine = Replace$(v, vbTab, "    ")
        
        Dim trimmedLine As String
        trimmedLine = Trim$(sLine)

        
        Dim sType As String
        If Left$(trimmedLine, 1) = "'" Then
            sType = "CMN"
        ElseIf Len(trimmedLine) = 0 Then
            sType = "BLN"
        Else
            sType = linetype
        End If
                
        Call writeRpt(rpt, _
        vbppath & vbTab & _
        vbpname & vbTab & _
        modname & vbTab & _
        LastModDate & vbTab & _
        modtype & vbTab & _
        l & vbTab & _
        sType & vbTab & _
        sLine & vbCrLf)
        
        l = l + 1
        
        If linetype = "GUI" Then
            If sLine = "End" Then linetype = "COD"
        End If
    
    Next v

errorHandler:
    
    If Not txtfil Is Nothing Then txtfil.Close
    Set fileSys = Nothing
    Set fil = Nothing
    Set txtfil = Nothing
    
    If Err Then
    
        Call writeRpt(rpt, _
        vbppath & vbTab & _
        vbpname & vbTab & _
        modname & vbTab & _
        Now() & vbTab & _
        modtype & vbTab & _
        l & vbTab & _
        "ERR" & vbTab & _
        modpath & ":" & Err.Description & vbCrLf)
    End If
    
End Sub

