PDA

View Full Version : Solved: Extracting Hyperlinks from the shapes or textboxes



kbsudhir
12-14-2012, 11:20 AM
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.:banghead: :banghead: :banghead: :banghead:

Requesting your guidance to get this solved.

Regards
Sudhir

p45cal
12-14-2012, 05:40 PM
Sub blah()
For Each shp In ActiveSheet.Shapes
MsgBox shp.Hyperlink.Address & vbLf & shp.Hyperlink.SubAddress
Next shp
End Sub

kbsudhir
12-14-2012, 08:40 PM
Thanks p45cal. I will try this out & let you know.

Regards
Sudhir

kbsudhir
12-14-2012, 11:18 PM
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

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

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

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
12-14-2012, 11:23 PM
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
12-15-2012, 04:18 AM
maybe




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

kbsudhir
12-15-2012, 05:31 AM
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
If shp.Hyperlinks.Count > 0 Then

Regards
Sudhir

p45cal
12-15-2012, 05:57 AM
try: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

kbsudhir
12-15-2012, 07:01 AM
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
12-15-2012, 07:02 AM
Try also:
Edit: See if the bold line works for you to extract text on the shape.
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

kbsudhir
12-15-2012, 07:35 AM
Thanks shrivallabha, it works. I am using the below code

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

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

Thanks a lot ...!!!

Regards
Sudhir