Inserting pictures into excel columns

maddengm33

Board Regular
Joined
Jan 25, 2005
Messages
62
Here is what I would like to be able to do:

In cells A1:A10, I have the numbers 1,2,3....10.
I have jpg images in a folder named PIX in my C drive, each of these pictures is numbered 1,2,3....10.
I would like to be able to place a formula in cell B1 which looks at cell A1 and if the number in A1 matches the name of a picture in the folder PIX, I would like for that picture to be displayed in cell B1. If the number in cell A1 does not match an image, then I would like the cell to be blank. The same goes for B2 looking at the value in A2, etc.
Is this possible?
I am not very familiar with macros or VBA; therefore, any instructions involving macros and/or VBA would need to be detailed.
Any help is greatly appeciated.

Jim
 

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.
If you wanted hyperlinks to the files, you could simply use the formula:
=HYPERLINK("C:\PIX\"&A1&".JPG")

but if you do indeed want the pix themselves, I'll check back tomorrow (leaving work soon) and see if anyone else has solved your problem.
 
Upvote 0
Tazguy37, as a follow up to your suggestion for the HYPERLINK formula, could you also place a formula in cell C1 that asks excel to look in the PIX folder and see if that picture (which matches the number in cell A1) actually exists?

Thanks

Jim
 
Upvote 0
This is module code to ask you for the folder to look in for your photos then it adds all the photos to a column. The code also included a reset to return the application to blank!

Option Explicit
Option Base 1

Private Declare Function GetSystemDirectory _
Lib "kernel32" _
Alias "GetSystemDirectoryA" ( _
ByVal lpBuffer As String, _
ByVal nSize As Long) _
As Long

Const iMsgStyle As Integer = vbInformation + vbSystemModal
Dim x As Double

Function GetDrive()
Dim sSave As String, lRet As Long
sSave = Space(255)
lRet = GetSystemDirectory(sSave, 255)
GetDrive = Left(sSave, 3)
End Function

Sub LoadPictureFiles()
Dim objFolder As Object, strPictFullPath As String, strFileName As String
Dim ws As Worksheet, wb As Workbook
Dim OldStaBar As Boolean
Dim ArrImg
Dim z As Integer

'// Define your image Formats here [Change as required]
ArrImg = Array("*.bmp", "*.gif", "*.jpg", "*.jpeg", "*.tif")

'//
Set objFolder = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please Select Image Folder", 0, GetDrive)

If Not objFolder Is Nothing Then
'// Is it the Root Dir?...if so change
If Len(objFolder.Items.Item.Path) > 3 Then
strPictFullPath = objFolder.Items.Item.Path & Application.PathSeparator
Else
strPictFullPath = objFolder.Items.Item.Path
End If
Else
Exit Sub
End If

x = 2
'// Speed things up
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With

'// Clear Old Data
DeletePicts
'// Setup Status
OldStaBar = Application.DisplayStatusBar
Application.StatusBar = True

For z = 1 To UBound(ArrImg)
strFileName = Dir(strPictFullPath & ArrImg(z))
' If strFileName = "" Then MsgBox "No " & ArrImg(z) & " files exist in " & _
' strPictFullPath, iMsgStyle: GoTo Again

'// Lets get the list
Do Until strFileName = ""
'On Error GoTo ErrH
Cells(x, 1).Select
ActiveSheet.Pictures.Insert(strPictFullPath & strFileName).Select
'// Now resize the ImageCell
ImageCellFormat x, 1
Cells(x, 2) = strFileName
Cells(x, 3) = FileLen(strPictFullPath & strFileName) \ 1024 & " Kb"
Cells(x, 4) = FileDateTime(strPictFullPath & strFileName)
Application.StatusBar = "File#:" & x - 1 & " " & strPictFullPath & strFileName
strFileName = Dir()
x = x + 1
Loop

Again:
Next
'// Format cell range
Columns("B:D").AutoFit
Columns(2).HorizontalAlignment = xlRight

MsgBox "Done......" & vbCrLf & x - 2 & " Image files found in " & _
strPictFullPath, iMsgStyle

Reset:
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.StatusBar = OldStaBar
End With

Exit Sub
ErrH:

MsgBox Err.Number & vbCr & _
Err.Description & vbCr _
, vbMsgBoxHelpButton _
, "Error Accessing: " & strPictFullPath & strFileName _
, Err.HelpFile _
, Err.HelpContext

End Sub

Sub ImageCellFormat(rRow As Double, rCol As Integer)
Dim Left As Double, Top As Double
Dim Wdth As Double

Static LastW As Double

'// Incase Img is larger
'// Xl2000 409 Row Height Max!
On Error Resume Next
With ActiveSheet.Shapes
If x = 2 Then LastW = Selection.ShapeRange.Width - 0.1
Wdth = Selection.ShapeRange.Width
If Wdth > LastW Then LastW = Wdth: Columns(rCol).ColumnWidth = Wdth / 5.3
Rows(rRow).RowHeight = Selection.ShapeRange.Height

Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 200
Rows(rRow).RowHeight = 200
Columns("A:A").Select
Selection.ColumnWidth = 50
[A1].Select

If Err Then
'// handle Image > 409
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 200
Rows(rRow).RowHeight = 200
End If
End With
End Sub

'// To delete ALL pictures then;
Sub DeletePicts()
Dim Pict As Shape

For Each Pict In ActiveSheet.Shapes
If Pict.Type = 13 Then
Pict.Delete
End If
Next

With Range([A2:D2], [A2:D2].End(xlDown))
.ClearContents
.Rows.AutoFit
.ColumnWidth = 8.43
End With
[A1].Select
'// reset the Usedrange
ActiveSheet.UsedRange
End Sub
 
Upvote 0
Joe Was, thanks for the code, but what I need is to be able to look at the number in a cell and see if that picture exists in the folder.
 
Upvote 0
This Custom Function and Sub work together to check if a file is found.
You will need to change the Sub to not use the InPutBox to get the file name, just load the "FolderFile" Var. with your cell value and blend the resulting code into whatever Sub you are working with or use it as a stand alone. To use it as an automatic stand alone you will need to add the loop code!

As it is now it asks you for the "Drive:\Folder\FileName.ext" and tests for that file. Also, comment out the "Does Exist" MsgBox if you loop the code!

Private Function FileExists(fName) As Boolean
'Custom Sheet Function!
'Syntax: =FileExists("Drive:/Folder(s)/FileName")
'If file is found: Returns TRUE, else FALSE.
Dim myFolder As String

myFolder = Dir(fName)

If UCase(fName) = "HELP" Then
MsgBox " Syntax: =FileExists(""Drive:/Folder(s)/FileName"")" & vbCr & vbCr & _
"Like ==> =FileExists(""C:\Path\FileName.xls"")"
End If

If myFolder <> "" Then
FileExists = True
Else
FileExists = False
End If
End Function

Sub CKForFile()
'Check for a file!
Dim folderFile As String
Dim Message, Title, Default

Message = "Enter a Drive:/Folder/FileName" ' Set prompt.
Title = "Check for File" ' Set title.
Default = "C:\Test.txt" ' Set default.
' Display message, title, and default value.
folderFile = InputBox(Message, Title, Default)
'folderFile = "C:\Path\FileName.xls"

If FileExists(folderFile) Then
MsgBox folderFile & " Does Exist!"
Else
MsgBox folderFile & " Not Found?"
End If
End Sub
 
Upvote 0
Because I am not very familiar with VBA, I'm not able to follow what you are doing. I need to know specifically what needs to be placed in each cell.
 
Upvote 0
What extensions are you using for your pictures?
jpg?

And in the sheet cells are the extentions included or do you just want the numbers for the names to search for?

The code can be made to work both ways.

If the pictures have more than one type of extention we can also work around that as well, I just need to know how to build the code.

I know of no sheet formulas to work with picture files the way you describe, the ways I do know all require us to build that functionality into Excel with code!
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,215
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top