Routines for crawling a folder, finding MS Office documents, and finding external references (links) in Excel, Powerpoint or Word documents

FindLinkedFiles.bas

Option Explicit
Const strLogPath As String = "C:\PathForLogFiles\"
Const crawlStart As String = "J:\StartingDirectoryPath"

'
Const MaskPP = "*.pp*"
Const MaskXL = "*.xl*"
Const MaskDoc = "*.doc*"


'Toggles for the types of documents to capture
Const DOC = True
Const PPT = True
Const XLS = True



Sub Run()
    Dim fso As FileSystemObject
    Dim fldStart As Folder
    Dim fld As Folder
    Dim fl As File
    Dim MaskPP As String
    Dim MaskXL As String
    Dim MaskDoc As String
    Dim fileLogger As Integer
    Dim linkLogger As Integer
    Dim DateNow As String
    Dim oFs As New FileSystemObject
    Dim ofileLogger As TextStream
    Dim olinkLogger As TextStream
    
    
    DateNow = Format(Now(), "yyyy-MM-dd_hh_mm")

    'fileLogger = 1   'FreeFile()
    'linkLogger = 2    'FreeFile()
    Set oFs = New FileSystemObject
    'Open strLogPath & DateNow & "_log_all_files_list.txt" For Output As #fileLogger
    'Open strLogPath & DateNow & "_log_all_file_links_list.txt" For Output As #linkLogger
    Set ofileLogger = oFs.CreateTextFile(strLogPath & DateNow & "_log_all_files_list.txt")
    Set olinkLogger = oFs.CreateTextFile(strLogPath & DateNow & "_log_all_file_links_list.txt")

    'Set fso = CreateObject("scripting.FileSystemObject") ' late binding
    Set fso = New FileSystemObject 'or use early binding (also replace Object types)

    Set fldStart = fso.GetFolder(crawlStart) ' <-- use your FileDialog code here


    'Debug.Print fldStart.Path & "\"
    ListFiles fldStart, ofileLogger, olinkLogger
    For Each fld In fldStart.SubFolders
        ListFiles fld, ofileLogger, olinkLogger
        ListFolders fld, ofileLogger, olinkLogger
    Next
 'Close #fileLogger
 'Close #linkLogger
 ofileLogger.Close
 olinkLogger.Close
 Set ofileLogger = Nothing
 Set olinkLogger = Nothing
 Set oFs = Nothing
 MsgBox ("Phew, that was extremely tough, but we finished  :)")

End Sub


Sub ListFolders(fldStart As Folder, ofileLogger As Object, olinkLogger As Object)
    Dim fld As Folder
    For Each fld In fldStart.SubFolders
        'Debug.Print fld.Path & "\"
        ListFiles fld, ofileLogger, olinkLogger
        ListFolders fld, ofileLogger, olinkLogger
    Next

End Sub

Sub ListFiles(fld As Folder, ofileLogger As Object, olinkLogger As Object)
    Dim fl As File
    Dim fpath As String
    For Each fl In fld.Files
        fpath = fld.Path & "\" & fl.Name
        If LCase(fl.Name) Like MaskXL And XLS = True Then
        Debug.Print fpath + " - " + Format(Now(), "yyyy-MM-dd_hh_mm")
            ofileLogger.WriteLine (Chr(34) & fpath & Chr(34))
            Call RunCodeOnAllXLSFiles(fpath, olinkLogger)
        ElseIf LCase(fl.Name) Like MaskPP And PPT = True Then
            ofileLogger.WriteLine (Chr(34) & fpath & Chr(34))
            Call RunCodeOnAllPPTFiles(fpath, olinkLogger)
        ElseIf LCase(fl.Name) Like MaskDoc And DOC = True Then
            ofileLogger.WriteLine (Chr(34) & fpath & Chr(34))
            Call RunCodeOnAllDocFiles(fpath, olinkLogger)
        End If
    Next
End Sub






Sub RunCodeOnAllXLSFiles(fpath, logger)
Dim wbOpen As Excel.Workbook
Dim wbNew As Excel.Workbook
Dim strExtension As String
Dim n As Integer
Dim xl As Excel.Application
Set xl = New Excel.Application

xl.ScreenUpdating = False
xl.DisplayAlerts = False
'xl.Calculation = xlCalculationManual
xl.DisplayAlerts = False
On Error Resume Next
    
        Set wbOpen = xl.Workbooks.Open(FileName:=fpath, UpdateLinks:=0, ReadOnly:=True, Password:="zzzzzz")
        If Err.Number > 0 Then
        wbOpen.Close False
        xl.DisplayAlerts = True
        xl.ScreenUpdating = True
        xl.DisplayAlerts = True
        xl.Calculation = xlCalculationAutomatic
        xl.Quit
        Set xl = Nothing
        Exit Sub
        End If
        avLinks = wbOpen.LinkSources(xlExcelLinks)
        If Not IsEmpty(avLinks) Then
            For nIndex = 1 To UBound(avLinks)
                logger.WriteLine (Chr(34) & wbOpen.FullName & Chr(34) & "," & Chr(34) & avLinks(nIndex) & Chr(34))
            Next nIndex
        Else
            logger.WriteLine (Chr(34) & wbOpen.FullName & Chr(34))
        End If

            
            wbOpen.Close savechanges:=False
xl.DisplayAlerts = True
xl.ScreenUpdating = True
xl.DisplayAlerts = True
xl.Calculation = xlCalculationAutomatic
xl.Quit
Set xl = Nothing
On Error GoTo 0
End Sub



Sub RunCodeOnAllPPTFiles(fpath, logger)
    Dim ppOpen As PowerPoint.Presentation
    Dim oSl As Object
    Dim oSh As Object
    Dim pp As PowerPoint.Application
    Set pp = New PowerPoint.Application

    pp.DisplayAlerts = ppAlertsNone

    On Error Resume Next
    Set ppOpen = pp.Presentations.Open(fpath, ReadOnly:=True, Untitled:=False, WithWindow:=False)

    For Each oSl In ppOpen.Slides

    If oSl.Shapes.Count > 0 Then
        For Each oSh In oSl.Shapes
            ' modify the following depending on what you want to
            ' convert
            Select Case oSh.Type
                Case msoChart
                    logger.WriteLine (Chr(34) & fpath & Chr(34) & "," & Chr(34) & oSh.LinkFormat.SourceFullName & Chr(34))
                Case msoEmbeddedOLEObject
                    logger.WriteLine (Chr(34) & fpath & Chr(34) & "," & Chr(34) & oSh.LinkFormat.SourceFullName & Chr(34))
                Case msoLinkedOLEObject
                    logger.WriteLine (Chr(34) & fpath & Chr(34) & "," & Chr(34) & oSh.LinkFormat.SourceFullName & Chr(34))
                Case Else

            End Select
        Next
    End If
    
    Next
    pp.DisplayAlerts = ppAlertsAll
    ppOpen.Close
    Set pp = Nothing

On Error GoTo 0
End Sub



Sub RunCodeOnAllDocFiles(fpath, logger)
    Dim wdOpen As Word.Document
    Dim oSl As Object
    Dim oSh As Object
    Dim wd As Word.Application
    Set wd = New Word.Application

    wd.ScreenUpdating = False
    wd.DisplayAlerts = wdAlertsNone
    On Error Resume Next
    Set wdOpen = wd.Documents.Open(fpath, ReadOnly:=True, Visible:=False)
        If Err.Number > 0 Then
        wdOpen.Close False
        wd.DisplayAlerts = wdAlertsAll
        wd.ScreenUpdating = True
        wd.Quit
        Set wd = Nothing
        Exit Sub
        End If
    If wdOpen.InlineShapes.Count > 0 Then
        For Each oSh In wdOpen.InlineShapes
            Select Case oSh.Type
                Case wdInlineShapeLinkedPicture
                    logger.WriteLine (Chr(34) & fpath & Chr(34) & "," & Chr(34) & oSh.LinkFormat.SourceFullName & Chr(34))
                Case wdInlineShapeEmbeddedOLEObject
                    logger.WriteLine (Chr(34) & fpath & Chr(34) & "," & Chr(34) & oSh.LinkFormat.SourceFullName & Chr(34))
                Case wdInlineShapeLinkedOLEObject
                    logger.WriteLine (Chr(34) & fpath & Chr(34) & "," & Chr(34) & oSh.LinkFormat.SourceFullName & Chr(34))
                Case Else

            End Select
        Next
    End If
    wd.DisplayAlerts = wdAlertsAll
    wd.ScreenUpdating = True
    wdOpen.Close False
    wd.Quit
    Set wd = Nothing

On Error GoTo 0
End Sub