Open Folder containing Jpeg files to get hyperlink

[LittleAnn]

I need to try find a new formula / macro / VBA that will look up a
cell in column A (over 2000 cells containing a file name) and then opens the
folder where all the corresponding
..jpg's are kept and picks the correct file in order to insert the hyperlink
to that file. as there is over 2000 records I need it done swiftly, is it
possible?????
Example:
Column A File Name 00001 (macro will look this
cell open the folder,
search for that file i.e corresponding .jpg and insert the link to Column B)

Column B Hyperlink
file:///\\nts03\Jobs\6_Graphics\IncomingGraphics\Photos\11 Photos
1\1100001.jpg

 

[ryguy7272]

I think this is what you want...
Sub findfile()

'directory to start searching
strFolder = "c:\temp"

RowCount = 1
Do
Mode = InputBox("What type of search do you want to perform?" & vbCrLf & _
"1: list of folders only" & vbCrLf & _
"2: list of files only" & vbCrLf & _
"3: list of files and folders only")
Loop While Mode < 1 Or Mode > 3

If Mode = 2 Or Mode = 3 Then
Addlinks = MsgBox("Do you want to include Hyperlinks?", vbYesNo, _
Title:=Hyperlinks)
Else
Hyperlinks = vbNo
End If


Set fso = CreateObject _
("Scripting.FileSystemObject")
Set folder = _
fso.GetFolder(strFolder)

Call GetWorksheetsSubFolder(strFolder + "\", Mode, Addlinks, RowCount)

End Sub

Sub GetWorksheetsSubFolder(strFolder, Mode, Addlinks, ByRef RowCount)
Set fso = CreateObject _
("Scripting.FileSystemObject")

Set folder = _
fso.GetFolder(strFolder)
If Mode = 1 Or Mode = 3 Then
Range("A" & RowCount) = strFolder
RowCount = RowCount + 1
End If

If folder.subfolders.Count > 0 Then
For Each sf In folder.subfolders
On Error GoTo 100
Call GetWorksheetsSubFolder(strFolder + sf.Name + "\", Mode, Addlinks,
RowCount)
100 Next sf
End If
'folder size in bytes
On Error GoTo 200
If Mode = 2 Or Mode = 3 Then
For Each fl In folder.Files
If Addlinks = vbYes Then
With ActiveSheet
..Hyperlinks.Add Anchor:=.Range("A" & RowCount), Address:=fl.Path, _
TextToDisplay:=fl.Path
End With
Else
Range("A" & RowCount) = fl
End If
RowCount = RowCount + 1
Next fl
End If
200 On Error GoTo 0

End Sub

I got the code here, on this same DG, a while back. Forgot who posted it,
but I certainly can't take credit for it.


Also, you can try this, which looks just for JPEG files:
Sub FindFiles()

Dim Filename As Variant
Filename = Application.GetOpenFilename(FileFilter:="Picture File
(*.jpg),*.jpg", MultiSelect:=True)
If TypeName(Filename) <> "Boolean" Then
Range("A1").Resize(UBound(Filename, 1) - LBound(Filename, 1) + 1).Value =
Application.Transpose(Filename)
End If

Dim lngRow As Long, lngLastRow As Long
lngLastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
For lngRow = 1 To lngLastRow
ActiveSheet.Hyperlinks.Add Range("A" & lngRow), Range("A" & lngRow)
Next

End Sub

This code came from Jacob Skaria. Thanks Jacob!!


HTH,
Ryan---

 

[LittleAnn]

Thanks a million for this it worked perfectly!!!! Really appreciate it. The
only thing I had to do was delete the last mention of the line
Call GetWorksheetsSubFolder(strFolder + sf.Name + "\", Mode, Addlinks,