CODEWITHSUNDEEP
vbams-officems-word
james
james

Reputation: 139

Add hyperlinks to linked images

I'm trying to add hyperlinks to images, which were added via IncludePicture fields.

For example, this is an image:

{ IncludePicture "C:\\Test\\Image 1.png" \d }

And so, it should be added hyperlink to it:

C:\\Test\\Image 1.png

After that, I can click on my image in document with mouse, and it will be opened in file manager.

Here is the code. For some reason, it doesn't properly work. How it should be fixed?

Sub AddHyperlinksToImages()
    On Error Resume Next
    Application.ScreenUpdating = False
    Dim iShp As InlineShape
    For Each iShp In ActiveDocument.InlineShapes
        iShp.Hyperlink.Address = iShp.LinkFormat.SourceFullName 'Doesn't work

        'Just for testing
        'fullPath = iShp.LinkFormat.SourceFullName
        'MsgBox fullPath
    Next
    Application.ScreenUpdating = True
End Sub

Upvotes: 0

Views: 225

Answers (1)

Variatus
Variatus

Reputation: 14383

Please try this code.

Sub AddHyperlinksToImages()
    ' 22 Sep 2017

    Dim Fld As Field
    Dim FilePath As String
    Dim Tmp As String
    Dim i As Integer

    Application.ScreenUpdating = False
    ActiveDocument.Fields.Update
    For Each Fld In ActiveDocument.Fields
        With Fld
            If InStr(1, Trim(.Code), "includepicture", vbTextCompare) = 1 Then
                If .InlineShape.Hyperlink Is Nothing Then
                    i = InStr(.Code, Chr(34))
                    If i Then
                        FilePath = Replace(Mid(.Code, i + 1), "\\", "\")
                        i = InStr(FilePath, "\*")
                        If i Then FilePath = Left(FilePath, i - 1)
                        Do While Len(FilePath) > 1
                            i = Asc(Right(FilePath, 1))
                            FilePath = Left(FilePath, Len(FilePath) - 1)
                            If i = 34 Then Exit Do
                        Loop
                        If i > 1 Then ActiveDocument.Hyperlinks.Add .InlineShape, FilePath
                    End If
                End If
            End If
        End With
    Next Fld
    Application.ScreenUpdating = True
End Sub

Upvotes: 1

Related Questions