Collecting list of Photos and hyperlinking to them?

[Simon Lloyd]

Hi all...this is in a way linked to this http://vbaexpress.com/forum/showthread.php?t=12553

Here's what i have for collecting a list of pictures in a folder Ideally if i could collect a list of photos (the names would all be the ID numbers used for the staff i.e AE 1 NW) everytime my Staff workbook is opened and create hyperlinks to the pictures on my staff sheet the staff ID's are held in column A and the hyperlink should go in column L for each found ID, this way the hyperlink will always be to the most recent photo of the employee!

[VBA]
Option Explicit
Sub Last_Created_Hyperlink_Test()
Dim fso As New FileSystemObject
Dim fls As Files
Dim i As Integer
Dim Picfile, MyFile As Variant
Set fls = fso.GetFolder("C:\Documents and Settings\Simon\Desktop\new pics").Files

i = 2

With Worksheets("Sheet1")
.Cells(1, 1) = "File Name"
.Cells(1, 2) = "File Size"
.Cells(1, 3) = "Date Created"
.Cells(1, 4) = "Link To Photo"
For Each Picfile In fls
MyFile = "C:\Documents and Settings\Simon\Desktop\Staff ID Photos\" & Picfile
.Cells(i, 1) = Picfile.Name
.Cells(i, 2) = Picfile.Size
.Cells(i, 3) = Picfile.DateCreated
.Cells(i, 4).Hyperlinks.Add Anchor:=Selection, Address:=MyFile, TextToDisplay:="Yes"
i = i + 1
Next
End With
Columns("A").AutoFit
End Sub

[/VBA]I have tried creating hyperlinks in my testbook as per the code above but it doesnt work.

Any help or ideas appreciated!

Regards,
SImon

[Haldun]

Hi,

Change following code
[vba].Cells(i, 4).Hyperlinks.Add Anchor:=Selection, Address:=MyFile, TextToDisplay:="Yes"[/vba]
with
[vba].Cells(i, 4).Hyperlinks.Add Anchor:=.Cells(i, 4), Address:=Picfile, TextToDisplay:="Yes"[/vba]

[Haldun]

Ooppsss , I did not realize that you have different paths in your code

[vba]Option Explicit
Sub Last_Created_Hyperlink_Test()
Dim fso As New FileSystemObject
Dim fls As Files
Dim i As Integer
Dim Picfile, MyFile As Variant
Set fls = fso.GetFolder("C:\Documents and Settings\Simon\Desktop\new pics").Files

i = 2

With Worksheets("Sayfa1")
.Cells(1, 1) = "File Name"
.Cells(1, 2) = "File Size"
.Cells(1, 3) = "Date Created"
.Cells(1, 4) = "Link To Photo"
For Each Picfile In fls
MyFile = "C:\Documents and Settings\Simon\Desktop\Staff ID Photos\" & Picfile.Name
.Cells(i, 1) = Picfile.Name
.Cells(i, 2) = Picfile.Size
.Cells(i, 3) = Picfile.DateCreated
.Cells(i, 4).Hyperlinks.Add Anchor:=.Cells(i, 4), Address:=MyFile, TextToDisplay:="Yes"
i = i + 1
Next
End With
Columns("A").AutoFit
End Sub[/vba]

[Simon Lloyd]

Haldun, thanks for the response, it shouldn't be different paths i posted some code i was messing around with, it should only have one Path this one ("C:\Documents and Settings\Simon\Desktop\new pics"), the other folder i have created ready!

Regards,
SImon

[Simon Lloyd]

This is what i have just used:
[vba]
Sub Last_Created_Hyperlink_Test()
Dim fso As New FileSystemObject
Dim fls As Files
Dim i As Integer
Dim Picfile, MyFile As Variant
Set fls = fso.GetFolder("C:\Documents and Settings\Simon\Desktop\new pics").Files

i = 2

With Worksheets("Sheet1")
.Cells(1, 1) = "File Name"
.Cells(1, 2) = "File Size"
.Cells(1, 3) = "Date Created"
.Cells(1, 4) = "Link To Photo"
For Each Picfile In fls
MyFile = "C:\Documents and Settings\Simon\Desktop\new pics\" & Picfile.Name
.Cells(i, 1) = Picfile.Name
.Cells(i, 2) = Picfile.Size
.Cells(i, 3) = Picfile.DateCreated
.Cells(i, 4).Hyperlinks.Add Anchor:=.Cells(i, 4), Address:=MyFile, TextToDisplay:="Yes"
i = i + 1
Next
End With
Columns("A").AutoFit
End Sub
[/vba]it does create the hyperlink in the correct area but all other text is blue and underlined just like a hyperlink but not!, why is this happening?

Regards,
Simon
EDIT: Have cured this, as sheet 1 cells seemed to have been formatted this way! Tut!

[Haldun]

What you see in screen tip when you hover mouse on a cell in column D. You should see full path of the file.

[Simon Lloyd]

Hi, i'm trying to add this line above the hyperlink line
[vba]
Mc = Application.WorksheetFunction.VLookup(Worksheets("Photo Details").Cells(i, 1).Value, Sheets("Employee Details").Range("StaffID"), 1, False)
[/vba]and have changed the hyperlink line to
[vba]
Mc.Offset(0, 11).Hyperlinks.Add Anchor:=Mc.Offset(0, 11), Address:=MyFile, TextToDisplay:="Yes"
[/vba]when i run it i am getting "Runtime Error 1004 unable to set the Vlookup property of the worksheet function class" what am i doing wrong?, i have Dim'd Mc as Variant, the statement falls within the "With" statement for the photo details sheets (previously sheet1 in the code above).

Regards,
SImon

EDIT: StaffID is a dynamic named range

[Simon Lloyd]

Being the numpty that i am i find i havent got anything wrong....except the filename that it is looking up contains ".jpg" but the value i am trying to find is what comes before it!, is there any way in the vlookup to TRIM .jpg so rather than look for AE 1 NW.jpg it only looks for AE 1 NW ?

Regards,
Numpty!

[Simon Lloyd]

I have added an extra column in Photo Details and added this formula =IF(A3<>"",LEFT(A3, LEN(A3)-4),"") this takes care of the .jpg
[VBA]
Mc = Application.WorksheetFunction.VLookup(Worksheets("Photo Details").Cells(i, 5).Value, Sheets("Employee Details").Range("StaffID"), 1, False)
[/VBA]but i now have problems with this line
[vba]
Mc.Offset(0, 11).Hyperlinks.Add Anchor:=Mc.Offset(0, 11), Address:=MyFile, TextToDisplay:="Yes"
[/vba]what i am trying to do is put the hyperlink at the offset of the vlookup result!. I know the above was a nieve attempt.

Regards,
Simon

[Haldun]

I'm not quite sure that VLookUp function returns Range object. It only returns value of cell if founded.

Following code trims last four chars from a string. Just replace FileName part.
[VBA]LEFT(FileName,Len(FileName)-4)[/VBA]

[mdmackillop]

Hi Simon,
Why not use Find with Offset rather than VLookup

[Simon Lloyd]

Will do, thanks for the suggestion Malcom, i was just messing around with Match!

Regards,
Simon

[Simon Lloyd]

Why does this create the hyperlink on the activesheet and not on the employee sheet?
[VBA]
Sub Last_Created_Hyperlink_Test()
Dim fso As New FileSystemObject
Dim fls As Files
Dim i As Integer
Dim Picfile, MyFile As Variant
Dim Mc As Range
Set fls = fso.GetFolder("C:\Documents and Settings\Simon\Desktop\new pics\Staff ID Photos").Files

i = 2

With Worksheets("Photo Details")
.Cells(1, 1) = "File Name"
.Cells(1, 2) = "File Size"
.Cells(1, 3) = "Date Created"
.Cells(1, 4) = "Link To Photo"
.Cells(1, 5) = "LookUp Value"
For Each Picfile In fls
MyFile = "C:\Documents and Settings\Simon\Desktop\new pics\Staff ID Photos\" & Picfile.Name
.Cells(i, 1) = Picfile.Name
.Cells(i, 2) = Picfile.Size
.Cells(i, 3) = Picfile.DateCreated
With Sheets("Employee Details")
Set Mc = Cells.Find(What:=Worksheets("Photo Details").Cells(i, 5).Value, After:=.Cells(1, 1), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
Mc.Offset(0, 11).Hyperlinks.Add Anchor:=Mc.Offset(0, 11), Address:=MyFile, TextToDisplay:="Yes"
End With
i = i + 1
Next
End With
Columns("A:E").AutoFit
End Sub
[/VBA]Any ideas?

Regards,
Simon

[Simon Lloyd]

Hi all, i have got the code below to work but the only problem now seems to be that it will only create 2 hyperlinks then comes up with "Runtime Error 91, Object variable or With variable not set", why should it work fine for the first 2 but then not subsequent ones?
[vba]
Sub Last_Created_Hyperlink_Test()
Dim fso As New FileSystemObject
Dim fls As Files
Dim i As Integer
Dim Picfile, MyFile As Variant
Dim Mc As Range
Set fls = fso.GetFolder("C:\Documents and Settings\Simon\Desktop\new pics\Staff ID Photos").Files

i = 2

With Worksheets("Photo Details")
.Cells(1, 1) = "File Name"
.Cells(1, 2) = "File Size"
.Cells(1, 3) = "Date Created"
.Cells(1, 4) = "Link To Photo"
.Cells(1, 5) = "LookUp Value"
For Each Picfile In fls
MyFile = "C:\Documents and Settings\Simon\Desktop\new pics\Staff ID Photos\" & Picfile.Name
.Cells(i, 1) = Picfile.Name
.Cells(i, 2) = Picfile.Size
.Cells(i, 3) = Picfile.DateCreated

Set Mc = Sheets("Employee Details").Cells.Find(What:=Worksheets("Photo Details").Cells(i, 5).Value, _
After:=Sheets("Employee Details").Cells(1, 1), _LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

MsgBox MyFile''''entered to check the path of each file being hyperlinked
Mc.Offset(0, 11).Hyperlinks.Add Anchor:=Mc.Offset(0, 11), Address:=MyFile, TextToDisplay:="Yes"
i = i + 1
Next
End With
Columns("A:E").AutoFit
End Sub
[/vba]Regards,
Simon
EDIT: It seems to be because the value it has found is created by a formula and not a "pure" entry in the cell any way to cure this?

[mdmackillop]

Hi Simon
Rather than search the whole sheet, as you appear to know the location of the subject
[VBA]Set Mc = Sheets("Employee Details").Columns(1).Find(.....[/VBA]

[Simon Lloyd]

Thanks for that Malcom, it still has trouble of course when it comes across a name thats created by formula

=IF(B5<>"",REPLACE(A4,4,SEARCH(" ",A4,4)-4,MID(A4,4,SEARCH(" ",A4,4)-4)+1),"")

this gives AE * NW where * is an incremental number.
The lines below are supposed to find a value and when found create a hyperlink at the offest of that but using MsgBox Mc.Value the message box shows blank?

[vba]
Set Mc = Sheets("Employee Details").Columns(1).Find(What:=Worksheets("Photo Details").Cells(i, 5).Value, _
After:=Sheets("Employee Details").Cells(1, 1), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
MsgBox Mc.Value''''USING THIS TO CHECK VALUE
Mc.Offset(0, 11).Hyperlinks.Add Anchor:=Mc.Offset(0, 11), Address:=MyFile, TextToDisplay:="Yes"
[/vba]

I have attached the workbook as i probably am not explaining myself very well!

Regards,
Simon

[mdmackillop]

Instead of the Selection Change code for Employee Details (which seems to have problems) try this change event instead
[vba]Private Sub Worksheet_Change(ByVal Target As Range)
Dim ID As String
If Target.Cells.Count > 1 Then Exit Sub
If Target.Address = Cells(Rows.Count, 2).End(xlUp).Address Then
ID = Target.Offset(-1, -1)
Target.Offset(, -1) = Split(ID)(0) & " " & Split(ID)(1) + 1 & " " & Split(ID)(2)
Target.Offset(, 3).FormulaR1C1 = "=IF(RC[-1]<>"""",DATEDIF(RC[-1],NOW(),""y"") & "" years, "" & DATEDIF(RC[-1],NOW(),""ym"") & "" months, ""& DATEDIF(RC[-1],NOW(),""md"") & "" days"","""")"
End If

End Sub


[/vba]

[Krishna Kumar]

Hi,

You could try this UDF to insert the picture.

[vba]Function ShowPicD(PicFile As String) As Boolean
'Author: Damon Ostrander
'Same as ShowPic except deletes previous picture when picfile changes
Dim AC As Range
Static P As Shape
On Error GoTo Done
Set AC = Application.Caller
If PicExists(P) Then
P.Delete
Else
'look for a picture already over cell
For Each P In ActiveSheet.Shapes
If P.Type = msoLinkedPicture Then
If P.Left >= AC.Left And P.Left < AC.Left + AC.Width Then
If P.Top >= AC.Top And P.Top < AC.Top + AC.Height Then
P.Delete
Exit For
End If
End If
End If
Next P
End If
Set P = ActiveSheet.Shapes.AddPicture(PicFile, True, True, AC.Left, AC.Top, 200, 200)
ShowPicD = True
Exit Function
Done:
ShowPicD = False
End Function
Function PicExists(P As Shape) As Boolean
'Return true if P references an existing shape
Dim ShapeName As String
On Error GoTo NoPic
If P Is Nothing Then GoTo NoPic
ShapeName = P.Name
PicExists = True
NoPic:
PicExists = False
End Function[/vba]

See here

HTH