Extract hyperlinks

[rockmonk]

Hello

I am trying to extract all document hyperlinks after the linked words and images
I found the following macro on the internet. It works perfect with linked words, but not with the linked images. Is there any idea about it?
Thank you

Here is the macro:

Sub extraxtHyperlinks()

Dim oRange As Word.Range
Dim oField As Field
Dim link As Variant


With ActiveDocument
.Range.AutoFormat
For Each oRange In .StoryRanges
For Each oField In oRange.Fields
If oField.Type = wdFieldHyperlink Then
For Each link In oField.Result.Hyperlinks
oField.Select
Selection.InsertAfter link.Address
Next link
End If
Next oField
Set oRange = oRange.NextStoryRange
Next oRange
End With
End Sub

[gmayor]

Can you provide a link to an example document, so we can see what you are trying to do?

[gmaxey]

You existing code doesn't perform a comprehensive search. While a sample as Graham suggests would be helpful, this may do:


Sub extraxtHyperlinks()
Dim oRng As Word.Range, oRngResult As Range
Dim oFld As Field
Dim oHyperlink As Hyperlink
Dim oILS As InlineShape
Dim lngJunk As Long
Dim oShp As Shape

With ActiveDocument
'Fix the skipped blank Header/Footer problem
lngJunk = .Sections(1).Headers(1).Range.StoryType
.Range.AutoFormat
For Each oRng In .StoryRanges
Do
For Each oFld In oRng.Fields
If oFld.Type = wdFieldHyperlink Then
For Each oHyperlink In oFld.Result.Hyperlinks
Set oRngResult = oFld.Result
oRngResult.Collapse wdCollapseEnd
oRngResult.Move wdCharacter, 1
oRngResult.InsertAfter " " & oHyperlink.Address
Next oHyperlink
End If
Next oFld
'If you mean a picture that contains a hyperlink to other content then:
For Each oILS In oRng.InlineShapes
On Error Resume Next
'If you mean a picture that contains a hyperlink to other content then:
oILS.Range.InsertAfter " " & oILS.Hyperlink.Address
'If you mean a picture that is linked to its source then"
oILS.Range.InsertAfter " " & oILS.LinkFormat.SourceFullName
Next
'If you want a complete comprehensive search includig the text range of shapes in headers and footer then:
' On Error Resume Next
' Select Case rngStory.StoryType
' Case 6, 7, 8, 9, 10, 11
' If rngStory.ShapeRange.Count > 0 Then
' For Each oShp In rngStory.ShapeRange
' If oShp.TextFrame.HasText Then
' For Each oFld In oShp.TextFrame.TextRange.Fields
' 'And so on.
' Next oFld
' End If
' Next
' End If
' Case Else
' 'Do Nothing
' End Select
' On Error GoTo 0
'Get next linked story (if any)
Set oRng = oRng.NextStoryRange
Loop Until oRng Is Nothing
Next oRng
End With
End Sub

[rockmonk]

this code is amazing! It's what I want!

Thank you all for the replies!

[gmaxey]

You're welcome. Glad I could help

[Kurt]

You existing code doesn't perform a comprehensive search. While a sample as Graham suggests would be helpful, this may do:


Sub extraxtHyperlinks()
Dim oRng As Word.Range, oRngResult As Range
Dim oFld As Field
Dim oHyperlink As Hyperlink
Dim oILS As InlineShape
Dim lngJunk As Long
Dim oShp As Shape

With ActiveDocument
'Fix the skipped blank Header/Footer problem
lngJunk = .Sections(1).Headers(1).Range.StoryType
.Range.AutoFormat
For Each oRng In .StoryRanges
Do
For Each oFld In oRng.Fields
If oFld.Type = wdFieldHyperlink Then
For Each oHyperlink In oFld.Result.Hyperlinks
Set oRngResult = oFld.Result
oRngResult.Collapse wdCollapseEnd
oRngResult.Move wdCharacter, 1
oRngResult.InsertAfter " " & oHyperlink.Address
Next oHyperlink
End If
Next oFld
'If you mean a picture that contains a hyperlink to other content then:
For Each oILS In oRng.InlineShapes
On Error Resume Next
'If you mean a picture that contains a hyperlink to other content then:
oILS.Range.InsertAfter " " & oILS.Hyperlink.Address
'If you mean a picture that is linked to its source then"
oILS.Range.InsertAfter " " & oILS.LinkFormat.SourceFullName
Next
'If you want a complete comprehensive search includig the text range of shapes in headers and footer then:
' On Error Resume Next
' Select Case rngStory.StoryType
' Case 6, 7, 8, 9, 10, 11
' If rngStory.ShapeRange.Count > 0 Then
' For Each oShp In rngStory.ShapeRange
' If oShp.TextFrame.HasText Then
' For Each oFld In oShp.TextFrame.TextRange.Fields
' 'And so on.
' Next oFld
' End If
' Next
' End If
' Case Else
' 'Do Nothing
' End Select
' On Error GoTo 0
'Get next linked story (if any)
Set oRng = oRng.NextStoryRange
Loop Until oRng Is Nothing
Next oRng
End With
End Sub


Hello Greg,

Can I get something like this but copy everything in a Word document including graphics and text?

I just posted this request and I didn't include the link here.

Thanks,

Kurt

[dj44]

Hello Greg,

thank you for writing this code, i was just looking for something like this, the hyeprlinks in word did not hyperlink when i pasted my work - the text was plain - so i needed the links to be made clickable and blue and underlined and this did the job - what a relief :grinhalo:

thanks again and
cheers :beerchug:

DJ

[Kurt]

Hello Greg,

thank you for writing this code, i was just looking for something like this, the hyeprlinks in word did not hyperlink when i pasted my work - the text was plain - so i needed the links to be made clickable and blue and underlined and this did the job - what a relief :grinhalo:

thanks again and
cheers :beerchug:

DJ

I am glad this helped you.

Keep on learning! :beerchug::beerchug: