VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsScanControl"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Public Event status(ByVal msg As String)

Public txtFolderFilter As String
Public txtFilFilter As String
Public txtContentFilter As String
Public txtSaveTo As String
Public txtRootPath As String
Public optRpt As String
Public mfoldercnt As Boolean
Public chkNoCase As Boolean

Dim comReporter As clsCOMReporter
Attribute comReporter.VB_VarHelpID = -1
Dim vbpRefReporter As clsVBPRefReporter
Attribute vbpRefReporter.VB_VarHelpID = -1
Dim vbpBinReporter As clsVBPBinReporter
Attribute vbpBinReporter.VB_VarHelpID = -1
Dim vbpModReporter As clsVBPModReporter
Attribute vbpModReporter.VB_VarHelpID = -1
Dim vbpSrcReporter As clsVBPSrcReporter
Attribute vbpSrcReporter.VB_VarHelpID = -1
Dim vbpCntReporter As clsVBPCntReporter
Attribute vbpCntReporter.VB_VarHelpID = -1
Dim dirLister As clsDirList
Attribute dirLister.VB_VarHelpID = -1
Dim filHandler As Object

' XML Config file constants
'
Const CFG_XMLDOC As String = "ScanTool"
Const CFG_ROOTPATH = "RootPath"
Const CFG_SAVETO = "SaveTo"
Const CFG_REPORT_MODE = "ReportMode"
Const CFG_FOLDER_FILTER = "FolderFilter"
Const CFG_FILE_FILTER = "FileFilter"
Const CFG_IGNORE_CASE = "IgnoreCase"
Const CFG_CONTENT_FILTER = "ContentFilter"
Const CFG_IGNORE_CASE_TRUE = "true"
Const CFG_IGNORE_CASE_FALSE = "false"

Public Sub runReport()
    Const FUNC_NAME$ = "runReport"
    On Error GoTo errorHandler
    
    Call report
    
    Call setStatus(optRpt & " report successfully written to " & txtSaveTo)
    
errorHandler:

    If Err Then _
        Call setStatus("Completed with error " & _
            TypeName(Me) & "::" & FUNC_NAME$ & " " & vbCrLf & Err.Description)
End Sub

Private Sub report()
    Const FUNC_NAME$ = "report"
    On Error GoTo errorHandler

    If txtRootPath = "" Then Err.Raise 17, "Please set a root path"
    
    Call setFileProcessor
    
    Dim fso As Scripting.FileSystemObject
    Set fso = New Scripting.FileSystemObject
    
    Dim fld As Scripting.Folder
    Set fld = fso.GetFolder(txtRootPath)
    
    Dim rpt As Scripting.TextStream
    Set rpt = openOutputText(txtSaveTo, fso)
    
    Dim dirPats() As String
    dirPats = Split(LCase$(txtFolderFilter), ",")
    
    Dim filPats() As String
    filPats = Split(LCase$(txtFilFilter), ",")
    
    If mfoldercnt Then
        Call rpt.WriteLine("PATH" & vbTab & "SUBFOLDERS" & vbTab & "FILES" & vbTab & "SIZE")
        Call reportFolder(fld, rpt, dirPats, filPats)
    Else
        Call rpt.WriteLine(filHandler.header())
        Call reportFolder(fld, rpt, dirPats, filPats)
    End If
    
    rpt.Close

errorHandler:

    Set fso = Nothing
    Set rpt = Nothing
    Set fld = Nothing
    
    If Err Then Err.Raise Err.Number, Description:=TypeName(Me) & "::" & FUNC_NAME$ & " " & vbCrLf & Err.Description

End Sub

Private Sub reportFolder(fld As Scripting.Folder, rpt As Scripting.TextStream, dirPats() As String, filPats() As String)
    Const FUNC_NAME$ = "reportFolder"
    On Error GoTo errorHandler
    
    Dim i As Integer
    Dim filPatCnt As Integer: filPatCnt = UBound(filPats)
    Dim dirPatCnt As Integer: dirPatCnt = UBound(dirPats)
    
    Dim fldpath As String: fldpath = LCase$(fld.Path) & "\"
    Call setStatus(fldpath)
    
    Dim scanDir As Boolean
    For i = 0 To dirPatCnt
        scanDir = fldpath Like dirPats(i)
        If scanDir Then Exit For
    Next i
    
    If scanDir Then
    
        Dim filCnt As Long
        filCnt = 0
        Dim filSiz As Double
        filSiz = 0
        Dim fil As Scripting.File
        
        For Each fil In fld.Files
            
            Dim filname As String: filname = LCase$(fil.name)
            
            Dim scanFil As Boolean
            For i = 0 To filPatCnt
                scanFil = filname Like filPats(i)
                If scanFil Then Exit For
            Next i
            
            If scanFil Then
                
                Call setStatus(fil.Path)
                
                If mfoldercnt Then
                    filCnt = filCnt + 1
                    filSiz = filSiz + fil.Size
                Else
                    Call filHandler.processFile(fil, rpt)
                End If
            
            End If
        
        Next
        
        If mfoldercnt Then
        
            Call writeRpt(rpt, _
            fld.Path & vbTab & _
            fld.SubFolders.Count & vbTab & _
            filCnt & vbTab & _
            filSiz & vbCrLf)
        End If
    
    End If
    
    ' recurse through all subfolders
    
    Dim subfld As Folder
    For Each subfld In fld.SubFolders
        Call reportFolder(subfld, rpt, dirPats, filPats)
    Next
    
errorHandler:
    
    Set subfld = Nothing
    Set fil = Nothing
    
    If Err Then _
        Err.Raise Err.Number, Description:=TypeName(Me) & "::" & FUNC_NAME$ & " " & vbCrLf & Err.Description
End Sub


Private Sub setStatus(msg As String)
   RaiseEvent status(msg)
End Sub

Public Sub setParms()
    
    Select Case optRpt
    Case "DirList"
        txtFolderFilter = "*"
        txtFilFilter = "*"
        txtContentFilter = ""
    Case "COMGuid"
        txtFolderFilter = "*"
        txtFilFilter = "*.ocx,*.exe,*.dll,*.olb,*.tlb"
    Case "VBPRef"
        txtFolderFilter = "*"
        txtFilFilter = "*.vbp"
    Case "VBPBin"
        txtFolderFilter = "*"
        txtFilFilter = "*.vbp"
    Case "VBPMod"
        txtFolderFilter = "*"
        txtFilFilter = "*.vbp"
    Case "VBPSource"
        txtFolderFilter = "*"
        txtFilFilter = "*.vbp"
    Case "VBPCount"
        txtFolderFilter = "*"
        txtFilFilter = "*.vbp"
    Case "FolderCnt"
        txtFolderFilter = "*"
        txtFilFilter = "*"
    Case Else
        Err.Raise Number:=17, Description:="Unknown mode " & optRpt
    End Select
    
    txtSaveTo = optRpt & ".tdf"
    
End Sub

Public Sub setFileProcessor()
    mfoldercnt = False
    Select Case optRpt
    Case "DirList"
        Set dirLister = New clsDirList
        dirLister.contentFilter = txtContentFilter
        dirLister.noCase = chkNoCase
        Set filHandler = dirLister
    Case "COMGuid"
        Set comReporter = New clsCOMReporter
        Set filHandler = comReporter
    Case "VBPRef"
        Set vbpRefReporter = New clsVBPRefReporter
        Set filHandler = vbpRefReporter
    Case "VBPBin"
        Set vbpBinReporter = New clsVBPBinReporter
        Set filHandler = vbpBinReporter
    Case "VBPMod"
        Set vbpModReporter = New clsVBPModReporter
        Set filHandler = vbpModReporter
    Case "VBPSource"
        Set vbpSrcReporter = New clsVBPSrcReporter
        Set filHandler = vbpSrcReporter
    Case "VBPCount"
        Set vbpCntReporter = New clsVBPCntReporter
        Set filHandler = vbpCntReporter
    Case "FolderCnt"
        mfoldercnt = True
    End Select
End Sub


Public Function Show() As String
Dim rpt As String
rpt = rpt & "optRpt           = [" & optRpt & "]" & vbCrLf
rpt = rpt & "txtFolderFilter  = [" & txtFolderFilter & "]" & vbCrLf
rpt = rpt & "txtFilFilter     = [" & txtFilFilter & "]" & vbCrLf
rpt = rpt & "txtContentFilter = [" & txtContentFilter & "]" & vbCrLf
rpt = rpt & "txtSaveTo        = [" & txtSaveTo & "]" & vbCrLf
rpt = rpt & "txtRootPath      = [" & txtRootPath & "]" & vbCrLf
rpt = rpt & "mfoldercnt       = [" & mfoldercnt & "]" & vbCrLf
rpt = rpt & "chkNoCase        = [" & chkNoCase & "]" & vbCrLf
Show = rpt
End Function
 
Public Sub loadScantoolConfig(filename As String)
    Const FUNC_NAME$ = "loadScantoolConfig"
    On Error GoTo errorHandler
    
    Dim domConfig As DOMDocument60
    Set domConfig = New DOMDocument60
    
    If domConfig.Load(filename) = False Then
        Err.Raise 17, Source:=TypeName(Me), Description:="Unable to load XML documentt: " & filename
    End If
        
    
    Debug.Print domConfig.xml
        
    Me.txtSaveTo = readNode(domConfig, "//" & CFG_XMLDOC & "//" & CFG_SAVETO)
    Me.txtRootPath = readNode(domConfig, "//" & CFG_XMLDOC & "//" & CFG_ROOTPATH)
    Me.txtFilFilter = readNode(domConfig, "//" & CFG_XMLDOC & "//" & CFG_FILE_FILTER)
    Me.txtFolderFilter = readNode(domConfig, "//" & CFG_XMLDOC & "//" & CFG_FOLDER_FILTER)
    Me.txtContentFilter = readNode(domConfig, "//" & CFG_XMLDOC & "//" & CFG_CONTENT_FILTER)
    Me.optRpt = readNode(domConfig, "//" & CFG_XMLDOC & "//" & CFG_REPORT_MODE)
    Me.chkNoCase = readNode(domConfig, "//" & CFG_XMLDOC & "//" & CFG_CONTENT_FILTER & "//@" & CFG_IGNORE_CASE) = CFG_IGNORE_CASE_TRUE

errorHandler:

    Set domConfig = Nothing
    
    If Err Then _
            Err.Raise Number:=Err.Number, Description:=TypeName(Me) & "::" & FUNC_NAME$ & " " & vbCrLf & Err.Description
End Sub


Public Sub saveScantoolConfig(filename As String)
    Const FUNC_NAME$ = "saveScantoolConfig"
    On Error GoTo errorHandler
    
    Dim domConfig As DOMDocument60
    Set domConfig = New DOMDocument60
    
    Dim elmRoot As IXMLDOMElement
    
    Set elmRoot = domConfig.createElement(CFG_XMLDOC)
    domConfig.appendChild elmRoot
    
    Dim elmParam As IXMLDOMElement
    
    Set elmParam = writeTextNode(elmRoot, CFG_ROOTPATH, txtRootPath)
    Set elmParam = writeTextNode(elmRoot, CFG_REPORT_MODE, optRpt)
    Set elmParam = writeTextNode(elmRoot, CFG_SAVETO, txtSaveTo)
    Set elmParam = writeTextNode(elmRoot, CFG_FILE_FILTER, txtFilFilter)
    Set elmParam = writeTextNode(elmRoot, CFG_FOLDER_FILTER, txtFolderFilter)
    Set elmParam = writeTextNode(elmRoot, CFG_CONTENT_FILTER, txtContentFilter)
    elmParam.setAttribute CFG_IGNORE_CASE, IIf(chkNoCase, CFG_IGNORE_CASE_TRUE, CFG_IGNORE_CASE_FALSE)
    
    Debug.Print domConfig.xml
    
    Call domConfig.save(filename)
        
errorHandler:

    Set domConfig = Nothing
    
    If Err Then _
            Err.Raise Number:=Err.Number, Description:=TypeName(Me) & "::" & FUNC_NAME$ & " " & vbCrLf & Err.Description
End Sub


