Solved: Extracting Hyperlinks from the shapes or textboxes

[kbsudhir]

Hi All,

I have multiple shapes & text boxes in a sheet. I want to extract the hyper links of those shapes or text boxes which have hyper links in them. But not able to get that done.

Requesting your guidance to get this solved.

Regards
Sudhir

[p45cal]

[VBA]Sub blah()
For Each shp In ActiveSheet.Shapes
MsgBox shp.Hyperlink.Address & vbLf & shp.Hyperlink.SubAddress
Next shp
End Sub
[/VBA]

[kbsudhir]

Thanks p45cal. I will try this out & let you know.

Regards
Sudhir

[kbsudhir]

Hi p45cal,

Thanks for your guidance but the below code is giving me an "Application-defined or object-defined" error. I am using below code

[VBA]Sub blah()
cnt = 2
For Each shp In sheets("sheet1").Shapes

sheets("sheet2").Range("B" & cnt).valuE = shp.Name
sheets("sheet2").Range("B" & cnt).value = shp.Hyperlink.Address & vbLf & shp.Hyperlink.SubAddress
cnt = cnt+1
Next shp
End Sub [/VBA]

I am getting error in line
[VBA]sheets("sheet2").Range("B" & cnt).value = shp.Hyperlink.Address & vbLf & shp.Hyperlink.SubAddress [/VBA]

Is this error because that particular shape do not have a hyperlink ..?? If so, then can we check if that shape has a hyperlink then extract the same.

Appreciating your guidance.

Regards
Sudhir

[kbsudhir]

Hi p45cal,

Yep, this error is due to non-availability of hyperlink in that shape. Is it possible to check if a shape has hyperlink, if yes then extract the link ...??

Regards
Sudhir

[mancubus]

maybe


[vba]

Sub blah()
cnt = 2
For Each shp In Sheets("sheet1").Shapes
If shp.Hyperlinks.Count > 0 Then
Sheets("sheet2").Range("B" & cnt).Value = shp.Name
Sheets("sheet2").Range("B" & cnt).Value = shp.Hyperlink.Address & vbLf & shp.Hyperlink.SubAddress
cnt = cnt + 1
End If
Next shp
End Sub

[/vba]

[kbsudhir]

Hi Mancubus,

Thanks for the guidance.

This is not working as I am getting an error "Object doesn't support this property or method" in line
[VBA] If shp.Hyperlinks.Count > 0 Then [/VBA]

Regards
Sudhir

[p45cal]

try:[VBA]Sub blah()
Dim cc As Hyperlink
cnt = 2
For Each shp In Sheets("sheet1").Shapes
Set cc = Nothing
On Error Resume Next
Set cc = shp.Hyperlink
On Error GoTo 0
If Not cc Is Nothing Then
Sheets("sheet2").Range("B" & cnt).Value = shp.Name
Sheets("sheet2").Range("B" & cnt).Value = cc.Address & vbLf & cc.SubAddress
cnt = cnt + 1
End If
Next shp
End Sub
[/VBA]

[kbsudhir]

Thanks p45cal. It works perfectly.

Just a small query.. if i want to extract the innertext of the shape how to get that done ..??

Appreciating your time & efforts for the guidance.

Thanks a lot ..!!!

Regards
Sudhir

[shrivallabha]

Try also:
Edit: See if the bold line works for you to extract text on the shape.
[vba]Public Sub ExtractHyperlinks()
Dim hlnk As Hyperlink
Dim cnt As Long
cnt = 2
For Each hlnk In ActiveSheet.Hyperlinks
' hlnk.type = 0 if it is in cell
' hlnk.type = 1 if it is on shape
If hlnk.Type = 1 Then
Sheets("Sheet2").Range("B" & cnt).Value = hlnk.Shape.Name
Sheets("Sheet2").Range("C" & cnt).Value = hlnk.Address & vbLf & hlnk.SubAddress
Sheets("Sheet2").Range("D" & cnt).Value = hlnk.Shape.TextFrame.Characters.Caption
cnt = cnt + 1
End If
Next hlnk
End Sub[/vba]

[kbsudhir]

Thanks shrivallabha, it works. I am using the below code

[VBA] Sheets("Sheet2").Range("D" & cnt).Value = shp.TextFrame.Characters.Caption[/VBA]

My issue is completely solved. I thanks p45cal, shrivallabha & mancubus for their guidance.

Thanks a lot ...!!!

Regards
Sudhir