Inserting Pictures Based on Formula

[mikec82]

I've searched around a bit already but haven't found anything specific to this topic so I thought I would ask. I have an excel file similar to below with Names in one column. I also have a folder on my desktop with jpeg images with names exactly matching the names in Column A. An example path to the file would be C:\Users\MikeC\Desktop\Photo_Uploads\Mark Clark.jpg. Is there any formula that would make Mark's picture appear in cell B2 if there was one in the folder?

Name	Picture
Mark Clark
John Smith
Jessica Robinson

<tbody>
</tbody>

 

[Jaafar Tribak]

Is it OK for you to use vba code (Macros) ? If so, you can take advantage of the worksheet Change event or even write a User Defined Function which you can use in your formulaes ... I recall having done something similar before, so let me know if you can use VBA and I will dig out the code and adapt it to meet your requirements

 

[mikec82]

I could definitely use VBA. I will look look into the two functions you mentioned. Any other feedback is appreciated as well. Thanks Jaafar.

 

[Jaafar Tribak]

Hi mike,

Here is this Boolean Getpicture UDF that you can flexibly use in a formula to insert your pictures as follows:

Name	Picture
A1 Mark Clark	B1 =IF(GetPicture("C:\Users\MikeC\Desktop\Photo_Uploads\"&A1),"","Pic Not Found")
A2 John Smith	B2 =IF(GetPicture("C:\Users\MikeC\Desktop\Photo_Uploads\"&A2),"","Pic Not Found")
A3 Jessica Robinson	B3 =IF(GetPicture("C:\Users\MikeC\Desktop\Photo_Uploads\"&A3),"","Pic Not Found")

<tbody>
</tbody>

Place this code in a Standard module :

Option Explicit

Private Declare Function SetTimer Lib "user32" _
        (ByVal hwnd As Long, _
        ByVal nIDEvent As Long, _
        ByVal uElapse As Long, _
        ByVal lpTimerFunc As Long) As Long
        
Private Declare Function KillTimer Lib "user32" _
        (ByVal hwnd As Long, _
        ByVal nIDEvent As Long) As Long
        
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
        pDest As Any, _
        pSource As Any, _
        ByVal dwLength As Long)
            
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" ( _
        ByVal lpString As Long) As Long

Private bPictureAdded As Boolean

Public Function GetPicture( _
    ByVal ImageFilePathName As String _
    ) As Boolean
    
    Dim lPtr As Long
    Dim sImageAndFileNames As String
    Dim oPic As Object
    
    On Error Resume Next
    Application.Caller.Parent.Shapes(Application.Caller.Address(, , , True)).Delete
    bPictureAdded = False
    If Len(ImageFilePathName) > 0 Then
        If Len(Dir(ImageFilePathName)) > 0 Then
            Set oPic = LoadPicture(ImageFilePathName)
            If Not oPic Is Nothing Then
                sImageAndFileNames = Application.Caller.Address(, , , True) & "|" & ImageFilePathName
                lPtr = StrPtr(sImageAndFileNames)
                 SetTimer Application.hwnd, lPtr, 1, AddressOf AddPicture
                 Do
                    DoEvents
                Loop Until bPictureAdded
                GetPicture = True
            End If
            Set oPic = Nothing
        End If
    End If
End Function

Private Sub AddPicture( _
    ByVal hwnd As Long, _
    ByVal uMsg As Long, _
    ByVal nIDEvent As Long, _
    ByVal dwTimer As Long _
    )

    Dim sImageAndFileNames As String
    Dim sTemp As String
    Dim lLen As Long
    Dim oPic As Shape
    Dim ar() As String
    
    On Error Resume Next
    KillTimer Application.hwnd, nIDEvent
    lLen = lstrlenW(nIDEvent) * 2
    sTemp = Space(lLen)
    CopyMemory ByVal sTemp, ByVal nIDEvent, lLen
    sImageAndFileNames = Replace(sTemp, Chr(0), "")
    ar = Split(sImageAndFileNames, "|")
    With Range(ar(0))
        .Parent.Shapes(ar(0)).Delete
        Set oPic = .Parent.Shapes.AddPicture _
        (ar(1), msoCTrue, msoFalse, .Left, .Top, .Width, .Height)
    End With
    With oPic
        .Placement = xlFreeFloating
        .Name = ar(0)
        .Visible = msoCTrue
    End With
    Set oPic = Nothing
    Erase ar
    bPictureAdded = True
End Sub

Note that the UDF will only work in 32 bit systems and the code must be modified to work in 64 bits

 

[Jaafar Tribak]

Please, ignore the previous post because I forgot to take into account the pictures file extensions
BTW, this UDF should work for all image files extensions such as JPG,BMP,TIFF etc ..
Try this :

Name	Picture
A1 Mark Clark	B1 =IF(GetPicture("C:\Users\MikeC\Desktop\Photo_Uploads\"&A1& ".jpg"),"","Pic Not Found")
A2 John Smith	B2 =IF(GetPicture("C:\Users\MikeC\Desktop\Photo_Uploads\"&A2& ".jpg"),"","Pic Not Found")
A3 Jessica Robinson	B3 =IF(GetPicture("C:\Users\MikeC\Desktop\Photo_Uploads\"&A3& ".jpg"),"","Pic Not Found")

<tbody>
</tbody>

Here is the GetPicture UDF code :

Option Explicit

Private Declare Function SetTimer Lib "user32" _
        (ByVal hwnd As Long, _
        ByVal nIDEvent As Long, _
        ByVal uElapse As Long, _
        ByVal lpTimerFunc As Long) As Long
        
Private Declare Function KillTimer Lib "user32" _
        (ByVal hwnd As Long, _
        ByVal nIDEvent As Long) As Long
        
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
        pDest As Any, _
        pSource As Any, _
        ByVal dwLength As Long)
            
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" ( _
        ByVal lpString As Long) As Long

Private bPictureAdded As Boolean

Public Function GetPicture( _
    ByVal ImageFilePathName As String _
    ) As Boolean
    
    Dim lPtr As Long
    Dim sImageAndFileNames As String
    Dim oPic As Object
    
    On Error Resume Next
    Application.Caller.Parent.Shapes(Application.Caller.Address(, , , True)).Delete
    bPictureAdded = False
    If Len(ImageFilePathName) > 0 Then
        If Len(Dir(ImageFilePathName)) > 0 Then
            Set oPic = LoadPicture(ImageFilePathName)
            If Not oPic Is Nothing Then
                sImageAndFileNames = Application.Caller.Address(, , , True) & "|" & ImageFilePathName
                lPtr = StrPtr(sImageAndFileNames)
                 SetTimer Application.hwnd, lPtr, 1, AddressOf AddPicture
                 Do
                    DoEvents
                Loop Until bPictureAdded
                GetPicture = True
            End If
            Set oPic = Nothing
        End If
    End If
End Function

Private Sub AddPicture( _
    ByVal hwnd As Long, _
    ByVal uMsg As Long, _
    ByVal nIDEvent As Long, _
    ByVal dwTimer As Long _
    )

    Dim sImageAndFileNames As String
    Dim sTemp As String
    Dim lLen As Long
    Dim oPic As Shape
    Dim ar() As String
    
    On Error Resume Next
    KillTimer Application.hwnd, nIDEvent
    lLen = lstrlenW(nIDEvent) * 2
    sTemp = Space(lLen)
    CopyMemory ByVal sTemp, ByVal nIDEvent, lLen
    sImageAndFileNames = Replace(sTemp, Chr(0), "")
    ar = Split(sImageAndFileNames, "|")
    With Range(ar(0))
        .Parent.Shapes(ar(0)).Delete
        Set oPic = .Parent.Shapes.AddPicture _
        (ar(1), msoCTrue, msoFalse, .Left, .Top, .Width, .Height)
    End With
    With oPic
        .Placement = xlFreeFloating
        .Name = ar(0)
        .Visible = msoCTrue
    End With
    Set oPic = Nothing
    Erase ar
    bPictureAdded = True
End Sub

 

[Jaafar Tribak]

Oops !!
Again another code error .. I mistakenly posted the wrong (ANSI) lstrlen API in the declarartions section.. I should have used its Unicode counterpart

I hope this time the code is correct

Name	Picture
A1 Mark Clark	B1 =IF(GetPicture("C:\Users\MikeC\Desktop\Photo_Uploads\"&A1& ".jpg"),"","Pic Not Found")
A2 John Smith	B2 =IF(GetPicture("C:\Users\MikeC\Desktop\Photo_Uploads\"&A2& ".jpg"),"","Pic Not Found")
A3 Jessica Robinson	B3 =IF(GetPicture("C:\Users\MikeC\Desktop\Photo_Uploads\"&A3& ".jpg"),"","Pic Not Found")

<tbody>
</tbody>

Corrected UDF code :

Option Explicit

Private Declare Function SetTimer Lib "user32" _
        (ByVal hwnd As Long, _
        ByVal nIDEvent As Long, _
        ByVal uElapse As Long, _
        ByVal lpTimerFunc As Long) As Long
        
Private Declare Function KillTimer Lib "user32" _
        (ByVal hwnd As Long, _
        ByVal nIDEvent As Long) As Long
        
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
        pDest As Any, _
        pSource As Any, _
        ByVal dwLength As Long)

Private Declare Function lstrlenW Lib _
        "kernel32" (ByVal lpString As Long) As Long

Private bPictureAdded As Boolean

Public Function GetPicture( _
    ByVal ImageFilePathName As String _
    ) As Boolean
    
    Dim lPtr As Long
    Dim sImageAndFileNames As String
    Dim oPic As Object
    
    On Error Resume Next
    Application.Caller.Parent.Shapes(Application.Caller.Address(, , , True)).Delete
    bPictureAdded = False
    If Len(ImageFilePathName) > 0 Then
        If Len(Dir(ImageFilePathName)) > 0 Then
            Set oPic = LoadPicture(ImageFilePathName)
            If Not oPic Is Nothing Then
                sImageAndFileNames = Application.Caller.Address(, , , True) & "|" & ImageFilePathName
                lPtr = StrPtr(sImageAndFileNames)
                 SetTimer Application.hwnd, lPtr, 1, AddressOf AddPicture
                 Do
                    DoEvents
                Loop Until bPictureAdded
                GetPicture = True
            End If
            Set oPic = Nothing
        End If
    End If
End Function

Private Sub AddPicture( _
    ByVal hwnd As Long, _
    ByVal uMsg As Long, _
    ByVal nIDEvent As Long, _
    ByVal dwTimer As Long _
    )

    Dim sImageAndFileNames As String
    Dim sTemp As String
    Dim lLen As Long
    Dim oPic As Shape
    Dim ar() As String
    
    On Error Resume Next
    KillTimer Application.hwnd, nIDEvent
    lLen = lstrlenW(nIDEvent) * 2
    sTemp = Space(lLen)
    CopyMemory ByVal sTemp, ByVal nIDEvent, lLen
    sImageAndFileNames = Replace(sTemp, Chr(0), "")
    ar = Split(sImageAndFileNames, "|")
    With Range(ar(0))
        .Parent.Shapes(ar(0)).Delete
        Set oPic = .Parent.Shapes.AddPicture _
        (ar(1), msoCTrue, msoFalse, .Left, .Top, .Width, .Height)
    End With
    With oPic
        .Placement = xlFreeFloating
        .Name = ar(0)
        .Visible = msoCTrue
    End With
    Set oPic = Nothing
    Erase ar
    bPictureAdded = True
End Sub