Script to import thumbnails-

mulletizer · Aug 17, 2011

Hey Forum, I could use some help automating the process of importing jpg thumbnails if anyone has the time. I saw some similar posts I am inspecting, but I thought I would post here as well just in case. We basically have many thumbnails that need to be imported corresponding to data in another column and it gets tedious importing the clip art.
Thank you.

Our setup is as follows.

Column A is empty, but needs to contain a thumbnail.
Column B contains the first part of the name of the thumbnail. Ex: "V01_01"

The thumbnails are contained in a constant path.

Z:\Folder1\Folder2\Thumbnails\V01_01.002459562.jpg

The last digits after the image name change based on the sequence it was created from. Ex:"Z:\Folder1\Folder2\Thumbnails\V02_09.002965345.jpg

The script would read in the image name in column B, search for a thumbnail in the constant path and import it into column A. During the import the thumbnail would need to be resized to .51 X.32

We are currently using Excel 2004 in OSX, but will be upgrading.

Any help or simple clues appreciated. Thanks again.

Jim

repairman615 · Aug 19, 2011

Hello,

Welcome to the message board!

Have you any progress on this?

I beleive I have all the peices of code that could help you.
Just need to stitch them togather...
I do not yet have a complete answer for your question yet. I will keep working on it.

Would you clarify if there could possible be more than one file that matches the first part of the thumbnail?
Also what is the data in column B:B like... continuious, scatterd, B5:B32 ...?

So far I have code to resize to your requested size.

Code:

With ActiveSheet.Shapes("Rectangle 3")
        .Height = 0.51 * 72
        .Width = 0.32 * 72
    End With

"Rectangle 3" in the above would need to be the variable thumbnail.

Also code to find the files based on a partial match of the filename in the path specified. However, this needs more work to determine the range of your column B:B and to insert the found file based on the partial match using wildcards.

If nothing else, this will bump your thread to the top.

-Jeff

mulletizer · Aug 22, 2011

Hey repairman615, thanks for the welcome. I am going to look at this harder tonight as well.

The data in column B is not ordered in the column, but will always have a match in the thumbnails directory. The name in this case is always 6 characters long in the format" V##_##". This would make the wildcard search easier. Coding wise, I would think it would be, for all selected columns in B, search the thumbnails directory for a thumbnail with a name matching the first 6 characters in B and import that thumbnail in A.

Thanks again for your help!

repairman615 · Aug 23, 2011

Hello,

Here is what I have. I beleive Richard Schollar had something to do with the FileList function...

Copy this code into a standard module:

Sub ThumbPartialName() Dim c As Range, _ Listrng As Range, _ i As Long, _ myvar As Variant, _ myJPGobj As OLEObject, _ fPath As String, _ Ws As Worksheet, _ strFirstCell As String strFirstCell = "B4" ''' Change this to your first cell with data in column B:B Set Ws = Sheets("Sheet1") Set Listrng = Ws.Range(strFirstCell & ":B" & Range("B" & Rows.Count).End(xlUp).Row) fPath = "C:\Users\standard account\Documents\" If Right(fPath, 1) <> "\" Then fPath = fPath & "\" For Each c In Listrng If c.Value <> "" Then 'c.Select myvar = FileList(fPath, c.Value & "*.pdf") If TypeName(myvar) <> "Boolean" Then If UBound(myvar) - LBound(myvar) > 0 Then MsgBox "Multiple files match the entry: " & c.Value & _ vbNewLine & "Located at: " & c.Address & _ vbNewLine & "Only the first match will appear.", vbOKOnly, "Multiply results" For i = LBound(myvar) To LBound(myvar) Set myJPGobj = ActiveSheet.OLEObjects.Add(Filename:= _ myvar(1), Link:=True, _ DisplayAsIcon:=False) With myJPGobj .Top = c.Top .Left = c.Offset(0, -1).Left .Height = 0.51 * 72 .Width = 0.32 * 72 End With Next i Else 'For i = LBound(myvar) To UBound(myvar) Set myJPGobj = ActiveSheet.OLEObjects.Add(Filename:= _ myvar, Link:=True, _ DisplayAsIcon:=False) With myJPGobj .Top = c.Top .Left = c.Offset(0, -1).Left .Height = 0.51 * 72 .Width = 0.32 * 72 End With 'Next i End If Else MsgBox "For " & c.Value & ", no file was found,", vbOKOnly, "Possible Error" End If End If Next c End Sub Function FileList(fldr As String, Optional fltr As String) As Variant Dim sTemp As String, sHldr As String If Right$(fldr, 1) <> "\" Then fldr = fldr & "\" sTemp = Dir(fldr & fltr) If sTemp = "" Then FileList = False Exit Function End If Do sHldr = Dir If sHldr = "" Then Exit Do sTemp = sTemp & "|" & sHldr Loop FileList = Split(sTemp, "|") End Function

Be sure to change the strFirstCell to your first (top) cell with data.

You can press Alt + F8 and select ThumbPartialName to run or call by other means.

-Jeff

repairman615 · Aug 24, 2011

The above would not work as it is looking in the file path that exists on my computer... and also for a PDF...

Here is an update using your filepath and looking for a .JPG

Option Explicit Sub ThumbPartialName() Dim c As Range, _ Listrng As Range, _ i As Long, _ myvar As Variant, _ myJPGobj As OLEObject, _ fPath As String, _ Ws As Worksheet, _ strFirstCell As String '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' strFirstCell = "B4" ''' Change this to your first cell with data in column B:B '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Set Ws = Sheets("Sheet1") Set Listrng = Ws.Range(strFirstCell & ":B" & Range("B" & Rows.Count).End(xlUp).Row) fPath = "Z:\Folder1\Folder2\Thumbnails\" If Right(fPath, 1) <> "\" Then fPath = fPath & "\" For Each c In Listrng If c.Value <> "" Then 'c.Select myvar = FileList(fPath, c.Value & "*.jpg") If TypeName(myvar) <> "Boolean" Then If UBound(myvar) - LBound(myvar) > 0 Then MsgBox "Multiple files match the entry: " & c.Value & _ vbNewLine & "Located at: " & c.Address & _ vbNewLine & "Only the first match will appear.", vbOKOnly, "Multiply results" For i = LBound(myvar) To LBound(myvar) Set myJPGobj = ActiveSheet.OLEObjects.Add(Filename:= _ myvar(1), Link:=True, _ DisplayAsIcon:=False) With myJPGobj .Top = c.Top .Left = c.Offset(0, -1).Left .Height = 0.51 * 72 .Width = 0.32 * 72 End With Next i Else 'For i = LBound(myvar) To UBound(myvar) Set myJPGobj = ActiveSheet.OLEObjects.Add(Filename:= _ myvar, Link:=True, _ DisplayAsIcon:=False) With myJPGobj .Top = c.Top .Left = c.Offset(0, -1).Left .Height = 0.51 * 72 .Width = 0.32 * 72 End With 'Next i End If Else MsgBox "For " & c.Value & ", no file was found.", vbOKOnly, "Possible Error" End If End If Next c End Sub Function FileList(fldr As String, Optional fltr As String) As Variant Dim sTemp As String, sHldr As String If Right$(fldr, 1) <> "\" Then fldr = fldr & "\" sTemp = Dir(fldr & fltr) If sTemp = "" Then FileList = False Exit Function End If Do sHldr = Dir If sHldr = "" Then Exit Do sTemp = sTemp & "|" & sHldr Loop FileList = Split(sTemp, "|") End Function 

Let me know if you need help inserting this.

-Jeff

repairman615 · Sep 5, 2011

Hey Mullitizer,

Checking in to see what happened. Please let me know as I am curious about your results.

Thanks,

Jeff

mulletizer · May 29, 2012

I apologize for not updating this. I got discouraged and gave up at the time, but I am back on it. I'll let you know when I have it working. Thanks again for your help.

Script to import thumbnails-

mulletizer

New Member

Excel Facts

repairman615

Well-known Member

mulletizer

New Member

repairman615

Well-known Member

repairman615

Well-known Member

repairman615

Well-known Member

mulletizer

New Member

Similar threads

Forum statistics

Share this page

Script to import thumbnails-

mulletizer

New Member

Excel Facts

repairman615

Well-known Member

mulletizer

New Member

repairman615

Well-known Member

repairman615

Well-known Member

repairman615

Well-known Member

mulletizer

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock