Sub to extract path from hyperlink formula and insert picture into comments

[Max]

Hi guys,

Looking for help to amend/enhance the Sub InsertPicComment() below (from
Dave P)
to do a few other things at one go

In col B are lots of hyperlink formulas below such as in say, B7 down:
=HYPERLINK("G:\...\Airline.jpg","Airline House.jpg")

a. Extract the path: "G:\...\Airline.jpg" into col A (into A7)
b. Insert the picture: Airline.jpg into the comment for B7
c. Skip step (b) if the file is not a picture file
(there could be hyperlinks in col B to non-picture files such as: .xls,
..ppt, .db, etc)
d. Do nothing where col B does not contain hyperlink formulas (eg: blank
cells, etc)

Thanks


Sub InsertPicComment()
' Dave Peterson
Dim myCell As Range
Dim myRng As Range
Dim testStr As String
Dim PictFileName As String

Set myRng = Selection
For Each myCell In myRng.Cells

PictFileName = myCell.Offset(0, -1).Value
testStr = ""
On Error Resume Next
testStr = Dir(PictFileName)
On Error GoTo 0
If testStr = "" Then
'do nothing, picture not found

Else
If myCell.Comment Is Nothing Then
myCell.AddComment Text:="" 'or "new comment here!" 'or ""
End If
myCell.Comment.Shape.Fill.UserPicture PictFileName
End If

' Else
' If myCell.Comment Is Nothing Then
' myCell.AddComment Text:=""
' End If
' myCell.Comment.Shape.Fill.UserPicture PictFileName
' myCell.Comment.Shape.LockAspectRatio = msoTrue
' myCell.Comment.Shape.Height = 143.25
' End If
Next myCell
End Sub

 

[Dave Peterson]

Parsing formulas is never easy, but if you know what those =hyperlink() formulas
look like you could use something like:

Option Explicit
Sub testme()
Dim LastRow As Long
Dim FirstRow As Long
Dim iRow As Long
Dim wks As Worksheet
Dim myFormula As String
Dim QuotePos As Long

Set wks = Worksheets("sheet1")
With wks
FirstRow = 7
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
For iRow = FirstRow To LastRow
If .Cells(iRow, "B").HasFormula Then
myFormula = LCase(.Cells(iRow, "B").Formula)
If myFormula Like "=hyperlink(""*" Then
myFormula = Mid(myFormula, 13)
QuotePos = InStr(1, myFormula, Chr(34), vbTextCompare)
If QuotePos = 0 Then
'do nothing
Else
myFormula = Left(myFormula, QuotePos - 1)
Select Case Right(myFormula, 4)
Case Is = ".jpg", ".bmp", ".gif"
.Cells(iRow, "a").Value = myFormula
Call InsertPicComment(.Cells(iRow, "B"), _
myFormula)
End Select
End If
End If
End If
Next iRow
End With

End Sub
Sub InsertPicComment(myCell As Range, PictFileName As String)

Dim testStr As String

testStr = ""
On Error Resume Next
testStr = Dir(PictFileName)
On Error GoTo 0

If testStr = "" Then
'do nothing, picture not found
Else
If myCell.Comment Is Nothing Then
myCell.AddComment Text:="" 'or "new comment here!" 'or ""
End If
myCell.Comment.Shape.Fill.UserPicture PictFileName
End If

End Sub

You don't really need this line:
..Cells(iRow, "a").Value = myFormula
to get the picture in the comment.

This will not work with:

=hyperlink(If(a1="x","....","----"),"click me")
kind of formula.

 

[Dave Peterson]

Ps. Add as many extensions as you want to support pictures. I didn't include
all of them <bg>.

 

[Max]

Superb .. Many thanks, Dave !

2 fine-tweaks requested ..

a. I'd like the sub to write the extracted path into col A,
even for non-picture file lines. Currently it doesn't do this.
(I might need the path in col A for some other purpose later.)

b. If I wanted the sub to write the pic's filename eg: Airline.jpg
into the comment as well, how should this part be changed?

Sub InsertPicComment
....
myCell.AddComment Text:=""

Thanks

 

[Dave Peterson]

I'm kind of confused about what to do with the comment string--if there's
already a comment there what should happen? But you should be able to fiddle
with that to get what you want.

Option Explicit
Sub testme()
Dim LastRow As Long
Dim FirstRow As Long
Dim iRow As Long
Dim wks As Worksheet
Dim myFormula As String
Dim QuotePos As Long

Set wks = Worksheets("sheet1")
With wks
FirstRow = 7
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
For iRow = FirstRow To LastRow
If .Cells(iRow, "B").HasFormula Then
myFormula = LCase(.Cells(iRow, "B").Formula)
If myFormula Like "=hyperlink(""*" Then
myFormula = Mid(myFormula, 13)
QuotePos = InStr(1, myFormula, Chr(34), vbTextCompare)
If QuotePos = 0 Then
'do nothing
Else
myFormula = Left(myFormula, QuotePos - 1)
.Cells(iRow, "a").Value = myFormula
Select Case Right(myFormula, 4)
Case Is = ".jpg", ".bmp", ".gif"
Call InsertPicComment(.Cells(iRow, "B"), _
myFormula)
End Select
End If
End If
End If
Next iRow
End With

End Sub
Sub InsertPicComment(myCell As Range, PictFileName As String)

Dim testStr As String

testStr = ""
On Error Resume Next
testStr = Dir(PictFileName)
On Error GoTo 0

If testStr = "" Then
'do nothing, picture not found
Else
If myCell.Comment Is Nothing Then
myCell.AddComment Text:=testStr
Else
myCell.Comment.Text Text:=myCell.Comment.Text & "--" & testStr
End If
myCell.Comment.Shape.Fill.UserPicture PictFileName
End If

End Sub

 

[Max]

Terrific. Runs great !
Thanks for the options ..

 

[Dave Peterson]

Just curious about Savefile.com.

Won't your files go away if they're not download in 14 days?

 

[Max]

Just curious about Savefile.com.
Won't your files go away if they're not download in 14 days?

Yes, they will*. That's why I'd do a zip pack coralling of individual files
every xx days or so to maintain availability to those who may be interested.
*IIRC from the site's T&Cs, enforcement aside that is <g>

 

[Dave Peterson]

Thanks for the info.

Yes, they will*. That's why I'd do a zip pack coralling of individual files
every xx days or so to maintain availability to those who may be interested.
*IIRC from the site's T&Cs, enforcement aside that is <g>

 

[Max]

Dave,

Could I have a slight variation of the last sub you provided, just to allow
me to select a range in col B to run the sub, instead of the sub running the
full show down col B on its own ? Think I'll also need this flexibility to
better handle the sub runs, especially when working on large cols with a lot
of pics. Thanks.

 

[Dave Peterson]

How about:

Option Explicit
Sub testme()

Dim wks As Worksheet
Dim myFormula As String
Dim QuotePos As Long
Dim myRng As Range
Dim myCell As Range

Set wks = ActiveSheet
With wks
Set myRng = Nothing
On Error Resume Next
Set myRng = Intersect(Selection, .UsedRange)
On Error GoTo 0
End With

If myRng Is Nothing Then
MsgBox "not in the used range"
Exit Sub
End If

For Each myCell In myRng.Cells
If myCell.HasFormula Then
myFormula = LCase(myCell.Formula)
If myFormula Like "=hyperlink(""*" Then
myFormula = Mid(myFormula, 13)
QuotePos = InStr(1, myFormula, Chr(34), vbTextCompare)
If QuotePos = 0 Then
'do nothing
Else
myFormula = Left(myFormula, QuotePos - 1)
If myCell.Column > 1 Then
myCell.Offset(0, -1).Value = myFormula
End If
Select Case Right(myFormula, 4)
Case Is = ".jpg", ".bmp", ".gif"
Call InsertPicComment(myCell, _
myFormula)
End Select
End If
End If
End If
Next myCell


End Sub
Sub InsertPicComment(myCell As Range, PictFileName As String)

Dim testStr As String

testStr = ""
On Error Resume Next
testStr = Dir(PictFileName)
On Error GoTo 0

If testStr = "" Then
'do nothing, picture not found
Else
If myCell.Comment Is Nothing Then
myCell.AddComment Text:=testStr
Else
myCell.Comment.Text Text:=myCell.Comment.Text & "--" & testStr
End If
myCell.Comment.Shape.Fill.UserPicture PictFileName
End If

End Sub

 

[Max]

Dave, thanks for the variation !
It runs great. Much appreciated.
I'm glad to have the 2 options ready to apply.

 

[Dave Peterson]

Glad I could help.

Dave, thanks for the variation !
It runs great. Much appreciated.
I'm glad to have the 2 options ready to apply.