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

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

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