[skam1]

Hi all,

I'm a newbie here so I appreciate any help that is offered. I searched around the forum here a bit, but could not find anything matching my exact needs (similar posts used combo boxes or just needed a single picture... not quite what I need)

I'm trying to create a product catalog for a client.
The product info is stored on a database and is being pulled into excel via an excel ODBC Query. One of the fields is the image name (product01.jpg, product02.jpg, etc..). The images are stored on the hard drive. The list of products will be different everytime depending on what the user filters in the query.

I need to be able to include the images in the product list.
Sample fields are ProductId, ProductName, ProductCost, ProductImage.
I'm guessing this will need VBA code to work. I'm not familiar with VBA coding, but with some help I'm sure I can get it working. Ideally, the pictures should show up as 125x125 pixels and the rowhight for each row should match the image hight.

All this needs to be dynamic as one time the query might return 10 rows, and another time 150 rows.

Running Windows XP with Excel 2003.

Any help is appreciated!

[skam1]

bump

[Aj_old]

Hi and welcome to forum.
First I think it would be easier done in Access - as it's more suitable for such things.
Second if you need it done in excel we would need more info:
1. are the images stored in the same folder?
2. does the query return the full name (name with extension and the path?
3. the excel file is already opened or it need to be opened?

[skam1]

Hi,

Thanks for taking the time to respond.

As I mentioned, I'm trying to create this for a client and they said they want it in excel... so that's what I have to stick with, even if it's harder to do it that way

1. Just to clarify... Are the images stored in the same folder as what? Same folder as the excel file? Ideally the user should be able to open up Excel from his desktop shortcut and run the report (images are not stored on desktop).

2. The query returns just the file name and extension. the path is not returned.

3. I'm not sure if I understood your 3rd question. The way the report should work is that the user opens a blank excel sheet and runs the odbc query. Excel would then pull in the pictures automatically based on the picture name that was returned from the query. If the user decides to then take that excel file that's already open and re-run the query with different parameters, it should work as well (update the pictures based on the new results).

Hope that all made sense.
Let me know if you have any other questions for me.

I appreciate your help!

[Aj_old]

Try this codes.

Sub InsertPictures()
    col = "B" 'Change the column letter to corespond to the column where the filenames are stored
    nr_pictures = ActiveSheet.Cells(65356, col).End(xlUp).Row
    pict_path = ThisWorkbook.Path & "\"
    
    For i = 2 To nr_pictures 'If your data do not stat with row 2, change i=2 to the coresponding value
        InsertPicture pict_path & Cells(i, col).Value, Cells(i, col)
    Next
End Sub

Sub InsertPicture(PictureFileName As String, TargetCell As Range)
' inserts a picture at the top left position of TargetCell
Dim p As Object, t As Double, l As Double, w As Double, h As Double
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    If Dir(PictureFileName) = "" Then Exit Sub
    ' import picture
    Set p = ActiveSheet.Pictures.Insert(PictureFileName)


    ' determine positions
    With TargetCell
        t = .Top
        l = .Left
        .ColumnWidth = 20
        .RowHeight = 93.75
    End With
    
    ' position picture
    With p
        .Top = t
        .Left = l
    End With
    
    ' resize picture
    With p
        .Width = Application.CentimetersToPoints(3.3)
        .Height = Application.CentimetersToPoints(3.3)
    End With
    
    Set p = Nothing
End Sub

[skam1]

Aj_Old,

I copied that code into a module window, but nothing happens in the spreadsheet. I clicked on the run button as well and still nothing. I'm very much a newbie when it comes to VB code in excel.. is there something else I'm supposed to do to execute that code?

Thanks

[The Villan]

Why is this marked as solved. Doesn't seem like it to me.

[skam1]

@The Villain:
I must have done that accidentally.. my apologies.
I just set it back to Unsolved.

@Aj_old:
I take back my last post... I played around with the picture path string as my pictures are in a subfolder called images (I changed that line of code to look like this: pict_path = ThisWorkbook.Path & "\images\".
It seems to be working now (yay!) except it just a few minor tweaks.

1. If I re-run the odbc query to get a new list, it lays the new pics over the old ones. Is there a way to delete the old pictures before fetching the new ones?

2. The picture hight on the pics seems perfect, but for the width I can see the right hand border of the cell behind sticking out. So the cells with long image names are sticking out a little from behind the picture. I realize that this is because the image size I requested is 125x125 pixels and some of the image names are longer than that. So is there a way to hide the image name column (I don't really need to discplay the image name in the report) and display the actual image in another column?

3. Is it possible to automatically display a border around each picture to match the rest of the cells?


Thanks again for spending the time to help me!

[The Villan]

No Problems Skam, just wondered :-)

[Aj_old]

I modified a little the code so it should do what you need.

Sub InsertPictures()
    col = "H" 'Change the column letter to corespond to the column where the filenames are stored
    nr_pictures = ActiveSheet.Cells(65356, col).End(xlUp).Row
    pict_path = ThisWorkbook.Path & "\"
    
    'Will delete the old pictures
    For Each pict In ActiveWorkbook.ActiveSheet.Shapes
        pict.Delete
    Next
    
    'Will hide the column with picture name
    Columns(col & ":" & col).EntireColumn.Hidden = True

    
    Rows("2:65536").EntireRow.AutoFit
    
    col_range = Cells(1, col).Offset(0, 1).Column
    For i = 2 To nr_pictures 'If your data do not stat with row 2, change i=2 to the coresponding value
        InsertPicture pict_path & Cells(i, col).Value, Cells(i, col_range)
    Next
End Sub

Sub InsertPicture(PictureFileName As String, TargetCell As Range)
' inserts a picture at the top left position of TargetCell
Dim p As Object, t As Double, l As Double, w As Double, h As Double
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    If Dir(PictureFileName) = "" Then Exit Sub
    ' import picture
    Set p = ActiveSheet.Pictures.Insert(PictureFileName)


    ' determine positions
    With TargetCell
        t = .Top
        l = .Left
        .ColumnWidth = 20
        .RowHeight = 93.75
    End With
    
    ' position picture
    With p
        .Top = t
        .Left = l
    End With
    
    ' resize picture
    With p
        .ShapeRange.LockAspectRatio = msoFalse
        .Width = Application.CentimetersToPoints(3.3)
        .Height = Application.CentimetersToPoints(3.3)

        .ShapeRange.Line.Weight = 1.5
        .ShapeRange.Line.DashStyle = msoLineSolid
        .ShapeRange.Line.Style = msoLineSingle
        .ShapeRange.Line.Transparency = 0#
        .ShapeRange.Line.Visible = msoTrue
        .ShapeRange.Line.ForeColor.SchemeColor = 64
        .ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
    End With
    
    Set p = Nothing
End Sub

[skam1]

Aj_old,

This seems to do exactly what I need! Awesome!

I just need to test it out with my client and if all goes smoothly I'll mark this thread as solved.

Thanks so much for your help!

[Aj_old]

You are welcome, just tell us the results, so we know what went good, and what not.

[skam1]

Hi,

I finally got in touch with my client and we got it up and running.
It all worked perfectly except for one thing.

There are some cases where the image name field will be blank for a given row, or there will be an image name there that does not exist in the image directory. In those cases, there's an image in the image directory called "noimage.gif" which simply displays "No Image Available"... I'd like to display that image in those 2 cases.

Here's the code I'm using:

Sub InsertPictures()
    col = "H" 'Change the column letter to corespond to the column where the filenames are stored
    'col2 = "I" 'Column where pics will be displayed
    nr_pictures = ActiveSheet.Cells(65356, col).End(xlUp).Row
    pict_path = ThisWorkbook.Path & "\images\"
 
    'Will delete the old pictures
    For Each pict In ActiveWorkbook.ActiveSheet.Shapes
        pict.Delete
    Next
 
    'Will hide the column with picture name
    Columns(col & ":" & col).EntireColumn.Hidden = True
 
    Rows("2:65536").EntireRow.AutoFit
 
    col_range = Cells(1, col).Offset(0, 2).Column
    For i = 2 To nr_pictures 'If your data do not stat with row 2, change i=2 to the coresponding value
        InsertPicture pict_path & Cells(i, col).Value, Cells(i, col_range)
    Next
End Sub
Sub InsertPicture(PictureFileName As String, TargetCell As Range)
' inserts a picture at the top left position of TargetCell
Dim p As Object, t As Double, l As Double, w As Double, h As Double
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    If Dir(PictureFileName) = "" Then Exit Sub
    ' import picture
    Set p = ActiveSheet.Pictures.Insert(PictureFileName)
 
    ' determine positions
    With TargetCell
        t = .Top
        l = .Left
        .ColumnWidth = 20
        .RowHeight = 93.75
    End With
 
    ' position picture
    With p
        .Top = t
        .Left = l
    End With
 
    ' resize picture
    With p
        .ShapeRange.LockAspectRatio = msoFalse
        .Width = Application.CentimetersToPoints(3.3)
        .Height = Application.CentimetersToPoints(3.3)
        .ShapeRange.Line.Weight = 0.1
        .ShapeRange.Line.DashStyle = msoLineSolid
        .ShapeRange.Line.Style = msoLineSingle
        .ShapeRange.Line.Transparency = 0#
        .ShapeRange.Line.Visible = msoTrue
        .ShapeRange.Line.ForeColor.SchemeColor = 44
        .ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
    End With
 
    Set p = Nothing
End Sub

Hope that made sense.
Again, I appreciate your help.

[skam1]

bump

[Aj_old]

Try this code, it should work, just find in the second part of the code the noimage.gif, and change it to the name of your file that corresponds to no image situation.

Sub InsertPictures()
    Application.ScreenUpdating = False
    
    col = "H" 'Change the column letter to corespond to the column where the filenames are stored
    'col2 = "I" 'Column where pics will be displayed
    nr_pictures = ActiveSheet.Cells(65356, col).End(xlUp).Row
    pict_path = ThisWorkbook.Path & "\images\"
 
    'Will delete the old pictures
    For Each pict In ActiveWorkbook.ActiveSheet.Shapes
        pict.Delete
    Next
 
    'Will hide the column with picture name
    If Not (Columns(col & ":" & col).EntireColumn.Hidden) Then Columns(col & ":" & col).EntireColumn.Hidden = True
 
    Rows("2:65536").EntireRow.AutoFit
 
    col_range = Cells(1, col).Offset(0, 2).Column
    For i = 2 To nr_pictures 'If your data do not stat with row 2, change i=2 to the coresponding value
        InsertPicture pict_path, Cells(i, col).Value, Cells(i, col_range)
    Next
    
    Application.ScreenUpdating = True

End Sub
Sub InsertPicture(PicturePath, PictureFileName As String, TargetCell As Range)
' inserts a picture at the top left position of TargetCell
Dim p As Object, t As Double, l As Double, w As Double, h As Double
Dim PicturePath_and_name, NoImage As String
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    
    'test if picture name is not empty, and replace it with noimage.gif
        NoImage = "Noimage.gif"
         If PictureFileName = "" Then PictureFileName = NoImage
    
    'Get the full file name
        PicturePath_and_name = PicturePath & PictureFileName
    
    'test if the file exists, nad if no, replace it with noimage.gif
        If Dir(PicturePath_and_name) = "" Then PicturePath_and_name = PicturePath & NoImage
    
    'import picture
        Set p = ActiveSheet.Pictures.Insert(PicturePath_and_name)
    
    
    ' determine positions
    With TargetCell
        t = .Top
        l = .Left
        .ColumnWidth = 20
        .RowHeight = 93.75
    End With
 
    ' position picture
    With p
        .Top = t
        .Left = l
    End With
 
    ' resize picture
    With p
        .ShapeRange.LockAspectRatio = msoFalse
        .Width = Application.CentimetersToPoints(3.3)
        .Height = Application.CentimetersToPoints(3.3)
        .ShapeRange.Line.Weight = 0.1
        .ShapeRange.Line.DashStyle = msoLineSolid
        .ShapeRange.Line.Style = msoLineSingle
        .ShapeRange.Line.Transparency = 0#
        .ShapeRange.Line.Visible = msoTrue
        .ShapeRange.Line.ForeColor.SchemeColor = 44
        .ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
    End With
 
    Set p = Nothing
End Sub