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 pictu 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
--
Max
Singapore
http://savefile.com/projects/236895
xdemechanik
---

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

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.

Max wrote:

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 pictu 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
--
Max
Singapore
http://savefile.com/projects/236895
xdemechanik
---

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

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

Max wrote:

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 pictu 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
--
Max
Singapore
http://savefile.com/projects/236895
xdemechanik
---

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

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
--
Max
Singapore
http://savefile.com/projects/236895
xdemechanik
---
"Dave Peterson" wrote in message
...
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.

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 wrote:

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
--
Max
Singapore
http://savefile.com/projects/236895
xdemechanik
---
"Dave Peterson" wrote in message
...
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

Terrific. Runs great !
Thanks for the options ..
--
Max
Singapore
http://savefile.com/projects/236895
xdemechanik
---
"Dave Peterson" wrote in message
...
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

Just curious about Savefile.com.

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

Max wrote:

Terrific. Runs great !
Thanks for the options ..
--
Max
Singapore
http://savefile.com/projects/236895
xdemechanik
---
"Dave Peterson" wrote in message
...
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

--

Dave Peterson

"Dave Peterson" wrote
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
--
Max
Singapore
http://savefile.com/projects/236895
xdemechanik
---

Thanks for the info.

Max wrote:

"Dave Peterson" wrote
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
--
Max
Singapore
http://savefile.com/projects/236895
xdemechanik
---

--

Dave Peterson

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.
--
Max
Singapore
http://savefile.com/projects/236895
xdemechanik
---
"Dave Peterson" wrote in message
...
Thanks for the info.

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 wrote:

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.
--
Max
Singapore
http://savefile.com/projects/236895
xdemechanik
---
"Dave Peterson" wrote in message
...
Thanks for the info.

--

Dave Peterson

Dave, thanks for the variation !
It runs great. Much appreciated.
I'm glad to have the 2 options ready to apply.
--
Max
Singapore
http://savefile.com/projects/236895
xdemechanik
---
"Dave Peterson" wrote in message
...
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

Glad I could help.

Max wrote:

Dave, thanks for the variation !
It runs great. Much appreciated.
I'm glad to have the 2 options ready to apply.
--
Max
Singapore
http://savefile.com/projects/236895
xdemechanik
---
"Dave Peterson" wrote in message
...
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

--

Dave Peterson