Extract Hyperlinks from selected Outlook emails to a Excel Spreadsheet - excel

Question

I found this VBA Outlook code that meets my purpose in theory. objHyperlink seems to return Nothing when I debug.
The outputs are always empty and during debug I get
Runtime error: "13" and Type mismatch
at the line - For Each objHyperlink In objMailDocument.Hyperlinks
Dim objExcelApp As Excel.Application
Dim objExcelWorkbook As Excel.Workbook
Dim objExcelWorksheet As Excel.Worksheet
Sub ExportAllHyperlinksInMultipleEmailsToExcel()
Dim objSelection As Selection
Dim objMail As MailItem
Dim objMailDocument As Document
Dim objHyperlink As Hyperlink
Dim i As Long
Set objSelection = Outlook.Application.ActiveExplorer.Selection
If Not (objSelection Is Nothing) Then
Set objExcelApp = CreateObject("Excel.Application")
Set objExcelWorkbook = objExcelApp.Workbooks.Add
Set objExcelWorksheet = objExcelWorkbook.Sheets(1)
objExcelApp.Visible = True
objExcelWorkbook.Activate
With objExcelWorksheet
.Cells(1, 1) = "Email"
.Cells(1, 2) = "Text"
.Cells(1, 3) = "Link"
.Cells(1, 4) = "Source"
End With
i = 0
For Each objMail In objSelection
Set objMailDocument = objMail.GetInspector.WordEditor
If objMailDocument.Hyperlinks.Count > 0 Then <- Correct # of links shown here
For Each objHyperlink In objMailDocument.Hyperlinks <- Debug highlights this
If InStr(objHyperlink.Address, "www.") > 0 Then
i = i + 1
Call ExportToExcel(i, objMail, objHyperlink)
End If
Next
End If
objMail.Close olDiscard
Next
objExcelWorksheet.Columns("A:D").AutoFit
End If
End Sub
Sub ExportToExcel(n As Long, objCurrentMail As MailItem, objCurrentHyperlink As Hyperlink)
Dim nLastRow As Integer
nLastRow = objExcelWorksheet.Range("A" & objExcelWorksheet.Rows.Count).End(xlUp).Row + 1
objExcelWorksheet.Range("A" & nLastRow) = n
objExcelWorksheet.Range("B" & nLastRow) = objCurrentHyperlink.TextToDisplay
objExcelWorksheet.Range("C" & nLastRow) = objCurrentHyperlink.Address
objExcelWorksheet.Range("D" & nLastRow) = objCurrentMail.Subject
End Sub

Answer 1

Thanks to #CDP1802 for pointing out a couple of changes to try. This does work with the following code:
Dim objExcelApp As Excel.Application
Dim objExcelWorkbook As Excel.Workbook
Dim objExcelWorksheet As Excel.Worksheet
Sub ExportAllHyperlinksInMultipleEmailsToExcel()
Dim objSelection As Selection
Dim objMail As MailItem
Dim objMailDocument As Word.Document << Added Word. here
Dim objHyperlink As Word.Hyperlink << Added Word. here
Dim i As Long
Set objSelection = Outlook.Application.ActiveExplorer.Selection
If Not (objSelection Is Nothing) Then
Set objExcelApp = CreateObject("Excel.Application")
Set objExcelWorkbook = objExcelApp.Workbooks.Add
Set objExcelWorksheet = objExcelWorkbook.Sheets(1)
objExcelApp.Visible = True
objExcelWorkbook.Activate
With objExcelWorksheet
.Cells(1, 1) = "Email"
.Cells(1, 2) = "Text"
.Cells(1, 3) = "Link"
.Cells(1, 4) = "Source"
End With
i = 0
For Each objMail In objSelection
Set objMailDocument = objMail.GetInspector.WordEditor
If objMailDocument.Hyperlinks.Count > 0 Then
For Each objHyperlink In objMailDocument.Hyperlinks
If InStr(objHyperlink.Address, "www.") > 0 Then
i = i + 1
Call ExportToExcel(i, objMail, objHyperlink)
End If
Next
End If
objMail.Close olDiscard
Next
objExcelWorksheet.Columns("A:D").AutoFit
End If
End Sub
Sub ExportToExcel(n As Long, objCurrentMail As MailItem, objCurrentHyperlink As Word.Hyperlink) << Added Word. here
Dim nLastRow As Integer
nLastRow = objExcelWorksheet.Range("A" & objExcelWorksheet.Rows.Count).End(xlUp).Row + 1
objExcelWorksheet.Range("A" & nLastRow) = n
objExcelWorksheet.Range("B" & nLastRow) = objCurrentHyperlink.TextToDisplay
objExcelWorksheet.Range("C" & nLastRow) = objCurrentHyperlink.Address
objExcelWorksheet.Range("D" & nLastRow) = objCurrentMail.Subject
End Sub