Excel hyperlink identification stop workbook contains links dialog box

Question

Hello, I am having a problem at the moment with some VBA code. I want to select a folder and then interrogate the folder and all sub folders to find Excel Workbooks. For each workbook I want to find if there are links to other workbooks and so I search for hyperlinks. Then Add a sheet to the calling workbook which records the information when each link is found. Because of the large amount of files I want this to be a process that runs without message boxes. A message box pops up as some files are hit that 'This workbook contains links to one or more sources that maybe unsafe. If you trust the links, update them to get the latest data. Otherwise you can keep working with the data you have'. I'd also like to be able to change Hyperlinks through the code as a next phase. Any help is much appreciated. Many thanks, Paul The code: - Sub Button1_Click() Dim FileSystem As Object Dim strHostFolder As String Dim FldPicker As FileDialog Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual Application.DisplayAlerts = False Call CreateHyperLinksSheet 'Paul S: Store Selected File Path from dialog box Set FldPicker = Application.FileDialog(msoFileDialogFolderPicker) With FldPicker .Title = "Select Calvin Folder" .AllowMultiSelect = False If .Show <> -1 Then GoTo NextCode strHostFolder = .SelectedItems(1) & "\" End With 'Paul S: On cancel goto end NextCode: If strHostFolder = "" Then GoTo ResetSettings Set FileSystem = CreateObject("Scripting.FileSystemObject") DoFolder FileSystem.GetFolder(strHostFolder) ResetSettings: Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub Sub CreateHyperLinksSheet() Dim newWS As Worksheet Dim ws As Worksheet 'Paul S: Look for HyperLinks Sheet and delete For Each ws In ThisWorkbook.Worksheets If ws.Name = "HyperLinks" Then Application.DisplayAlerts = False ws.Delete End If Next ws 'Paul S: Add HyperLinks Sheet and Titles Set newWS = ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count)) newWS.Name = "HyperLinks" With ThisWorkbook.Sheets("HyperLinks").Cells(Rows.Count, 1).End(xlUp) .Offset(0, 0) = "Sheet Text" .Offset(0, 1) = "Cell Ref" .Offset(0, 2) = "Link to Address" .Offset(0, 3) = "Workbook Path" .Offset(0, 4) = "Workbook Name" .Offset(0, 5) = "Sheet Name" End With Worksheets("HyperLinks").Columns("A").ColumnWidth = 40 Worksheets("HyperLinks").Columns("B").ColumnWidth = 8 Worksheets("HyperLinks").Columns("C").ColumnWidth = 40 Worksheets("HyperLinks").Columns("D").ColumnWidth = 90 Worksheets("HyperLinks").Columns("E").ColumnWidth = 60 Worksheets("HyperLinks").Columns("F").ColumnWidth = 15 End Sub Sub DoFolder(Folder) Dim strFile As String Dim strExtension As String Dim SubFolder Dim wb As Workbook Dim strPath As String 'Paul S: Excel format file extension plus wildcard strExtension = ".xls" For Each SubFolder In Folder.SubFolders DoFolder SubFolder Next Dim File For Each File In Folder.Files 'Paul S: Set String to equal folder plus wildcard plus each xls format plus wildcard If InStr(File, "xls") Then 'Paul S: For Each File In Folder 'Do While File <> "" 'Paul S: Set Workbook object Set wb = Workbooks.Open(Filename:=File) DoEvents Call IdentifyHyperLinks(wb) 'Paul S: Close Workbook wb.Close SaveChanges:=False DoEvents 'Paul S: Next wb please ' strFile = Dir ' Loop End If Next End Sub Private Sub IdentifyHyperLinks(wb As Workbook) Dim ws As Worksheet Dim Lhyper As Long Dim rngLink As Range Application.DisplayAlerts = False On Error Resume Next On Error GoTo 0 'Application.DisplayAlerts = True For Each ws In Worksheets For Lhyper = 1 To ws.UsedRange.Hyperlinks.Count Set rngLink = ws.Hyperlinks(Lhyper).Range rngLink.Copy With ThisWorkbook.Sheets("HyperLinks").Cells(Rows.Count, 1).End(xlUp) .Offset(1, 0).PasteSpecial .Offset(1, 1) = rngLink.Address .Offset(1, 2) = ws.Hyperlinks(Lhyper).Address .Offset(1, 3) = wb.Path .Offset(1, 4) = wb.Name .Offset(1, 5) = rngLink.Worksheet.Name End With Application.CutCopyMode = False Next Lhyper Next ws End Sub Public Function CheckHyperlink(ByVal strUrl As String) As Boolean Dim oHttp As New MSXML2.XMLHTTP60 On Error GoTo ErrorHandler oHttp.Open "HEAD", strUrl, False oHttp.send If Not oHttp.Status = 200 Then CheckHyperlink = False Else CheckHyperlink = True Exit Function ErrorHandler: CheckHyperlink = False End Function

Answer 1

Could you elaborate please?