Wondering if there is Code for exporting images to Excel file with multiple records

[ItsMe]

I don't think cells would have coordinates other than the ROW and COLUMN reference. No idea if that can be used programmatically to position shape/image.

I am going to take a few minutes and check it out.

[ssanfu]

Other options......

What about creating the report in Access (with images), then exporting the report to a PDF file?

Or using Access automation with Powerpoint, then exporting as PDF?

Easier than trying to put lots of images in Excel (IMO).

My $0.02................

[ItsMe]

Easier than trying to put lots of images in Excel (IMO).

..

What's the fun in that?

Dim xlApp As New Excel.Application
Dim myBook As Workbook
Dim mySheet As Worksheet
Dim myShape As Shape
Dim myRange As Range

 
Set myBook = xlApp.Workbooks.Add
Set mySheet = myBook.Worksheets(1)
mySheet.Name = "ShapeExample"
Set myRange = mySheet.Cells(4, 9)
Set myShape = mySheet.Shapes.AddPicture("C:\Test\Pictures\samplePhoto.jpg", msoTrue, msoFalse, myRange.Left, myRange.Top, 500, 500)
myBook.SaveAs ("C:\Test\ExcelFiles\TestFile.xlsx")
MsgBox "Complete"
myBook.Close
xlApp.Quit
 
Set myShape = Nothing
Set mySheet = Nothing
Set xlApp = Nothing

[Jo..]

What's the fun in that?

Dim xlApp As New Excel.Application
Dim myBook As Workbook
Dim mySheet As Worksheet
Dim myShape As Shape
Dim myRange As Range

 
Set myBook = xlApp.Workbooks.Add
Set mySheet = myBook.Worksheets(1)
mySheet.Name = "ShapeExample"
Set myRange = mySheet.Cells(4, 9)
Set myShape = mySheet.Shapes.AddPicture("C:\Test\Pictures\samplePhoto.jpg", msoTrue, msoFalse, myRange.Left, myRange.Top, 500, 500)
myBook.SaveAs ("C:\Test\ExcelFiles\TestFile.xlsx")
MsgBox "Complete"
myBook.Close
xlApp.Quit
 
Set myShape = Nothing
Set mySheet = Nothing
Set xlApp = Nothing

Now you have mentioned. If I really could export to Excel as shapes and link to the images. Will the images be also linked to the path, or will they be embedded in the excel? I am guessing adding one picture is easy. And adding images according to the records will be complicated.

[ItsMe]

You can embed the image by changing one of the arguments. I think it is the one here in red.
samplePhoto.jpg", msoTrue, msoFalse, myRange.Left

It is hard to say how difficult it would be to get everything to format nicely. If the images are many different sizes, you will need code to handle that. Different sized images might make your spreadsheet unreadable or very difficult to read. You might have to create many named ranges to manage the export process. It could be huge or it could be not too bad.

There may be another solution. It depends on the business rules. Excel may be the way. But, as others have mentioned, managing this with Excel will not be simple.

[Jo..]

You can embed the image by changing one of the arguments. I think it is the one here in red.
samplePhoto.jpg", msoTrue, msoFalse, myRange.Left

It is hard to say how difficult it would be to get everything to format nicely. If the images are many different sizes, you will need code to handle that. Different sized images might make your spreadsheet unreadable or very difficult to read. You might have to create many named ranges to manage the export process. It could be huge or it could be not too bad.

There may be another solution. It depends on the business rules. Excel may be the way. But, as others have mentioned, managing this with Excel will not be simple.

The code you are using sets the width and height of the images at the same time inserting to the Excel.

shapes.AddPicture(Filename, LinkToFile, SaveWithDocument, Left, Top, Width, Height)

If the sizes you are referring to the file size, I have limited the user to only be able to select image sizes under 200k, so that should have solved the 1st part of the sizing problem for the Excel.

Thank you,
Jo

[ItsMe]

I was thinking about the dimensions and having to go after the JPG's extended file properties. Also, this would affect the layout and possibly make the spreadsheet aesthetically unappealing.

[Jo..]

What's the fun in that?

Dim xlApp As New Excel.Application
Dim myBook As Workbook
Dim mySheet As Worksheet
Dim myShape As Shape
Dim myRange As Range

 
Set myBook = xlApp.Workbooks.Add
Set mySheet = myBook.Worksheets(1)
mySheet.Name = "ShapeExample"
Set myRange = mySheet.Cells(4, 9)
Set myShape = mySheet.Shapes.AddPicture("C:\Test\Pictures\samplePhoto.jpg", msoTrue, msoFalse, myRange.Left, myRange.Top, 500, 500)
myBook.SaveAs ("C:\Test\ExcelFiles\TestFile.xlsx")
MsgBox "Complete"
myBook.Close
xlApp.Quit
 
Set myShape = Nothing
Set mySheet = Nothing
Set xlApp = Nothing

Hello,

I tried to used the code you wrote in the previous posts. It popped out error msg box saying "The specified value is out of range." Does that mean my row height won't fit the image? But I suppose the image should be floating. No limit on the row height. Then what does that mean?

Thank you for your reply!

[ItsMe]

Which line did it error on? If it was on the Set myRange, you need to specify a column index and a row index. I think it starts at 1, 1

So I think D6 would translate to 4, 6

If you want multiple cells, you need to play around with Ranges vs Range. I have always managed ranges by using Named ranges within a template. So, exported data would be predestined for an existing file with an existing named range. In your case, if you need multiple cells, you would need to define your range on the fly.

[Jo..]

Which line did it error on? If it was on the Set myRange, you need to specify a column index and a row index. I think it starts at 1, 1

So I think D6 would translate to 4, 6

If you want multiple cells, you need to play around with Ranges vs Range. I have always managed ranges by using Named ranges within a template. So, exported data would be predestined for an existing file with an existing named range. In your case, if you need multiple cells, you would need to define your range on the fly.

I tried with only using your code, which did not work. But then I tried putting your code into my code. I finally could get the ONE image into the excel.

Option Explicit

'Enter Location of your Template Here
Const ExcelTemplate = "\\nas\Database\Product Development\MasterList\QuoteSheetTemplate.xlsx"
'Enter the Folder Directory to save results to
Const SaveResutsFldr = "\\nas\Database\Product Development\MasterList"


Sub CreateWorkbook()
    Dim dbs As DAO.Database
    Dim qdf As DAO.QueryDef
    Dim strSQL As String
    strSQL = "SELECT * FROM QuoteItems WHERE Lognumber='" & Forms![QuoteLog]![LogNumber] & "';"


    Set dbs = CurrentDb
    With dbs
        .QueryDefs.Delete ("myQuery")
        Set qdf = dbs.CreateQueryDef("myQuery", strSQL)
        .Close
    End With
    
    Application.RefreshDatabaseWindow


    Dim SaveAsStr As String
    Dim ExcelApp As Excel.Application
    Dim WB As Excel.Workbook
    Dim mySheet As Excel.Worksheet
    Dim myShape As Excel.Shape
    Dim myRange As Excel.Range
    Dim qry As QueryDef
    Dim i As Integer
    Dim c As Integer


    c = DCount("*", "myQuery") + 9


    'Create Reference to Run Excel
    Set qry = CurrentDb.QueryDefs("myQuery")
    Set ExcelApp = CreateObject("Excel.Application")


    'Create Reference to your Table
    Dim T As Recordset
    Set T = qry.OpenRecordset


    'Loop through all Record on Table
    If Not (T.BOF And T.EOF) Then
    T.MoveFirst
    End If
    Do While Not T.EOF
    'Open Your Excel Template
    Set WB = ExcelApp.Workbooks.Open(ExcelTemplate)
    Set mySheet = WB.Worksheets(1)
    mySheet.Name = Forms![QuoteLog]![LogNumber]
        
    For i = 10 To c
    'Enter your data from your table here to the required cells
    Set myRange = mySheet.Range("A" & i)
    Dim StrProductPic As String
    StrProductPic = "\\nas\database\backup\image.jpg"
    Set myShape = mySheet.Shapes.AddPicture(StrProductPic, True, False, myRange.Left, myRange.Top, -1, -1)
    myShape.Width = 100
    mySheet.Cells(3, 41).Value = Forms![QuoteLog]![LogNumber]
    mySheet.Cells(3, 2).Value = Forms![QuoteLog]![CustomerName]
    mySheet.Cells(4, 41).Value = Forms![QuoteLog]![SentDate]
    mySheet.Range("B" & i) = T("LogNumber")
    mySheet.Range("C" & i) = T("ProductSpec")


    Dim strExcel As String
    Dim n As Integer
    strExcel = "=IF(A" & i & " = """"," & """EMPTY""" & "," & """FILLED""" & ") "
    mySheet.Range("D" & i).Formula = strExcel




    'Repeat this line for each piece of data you need entered
    'Changing the Sheet name, cell range, a field name as per your requirements
    'WB.Wor...
    'WB.Wor...


    T.MoveNext
    Next i
    i = i + 1
    Loop
    'Save and Close the Workbook
    SaveAsStr = SaveResutsFldr & "\" & [Forms]![QuoteLog].LogNumber & "_" & [Forms]![QuoteLog].CustomerName & "_" & Format(Now(), "yymmdd") & ".xlsx"
    WB.SaveAs SaveAsStr
    WB.Close
    Set WB = Nothing


    'Move to the Next Record




    'Close down the Excel Application
    ExcelApp.Quit
    Set ExcelApp = Nothing
    
    Shell "EXCEL.EXE """ & SaveAsStr & "", vbNormalFocus
End Sub

Now it is the hard part to get multiple images according to the records.

Thank you for your input.
Jo

[ItsMe]

The code I posted was copied straight out of a working example. If the paths are correct, it should work. However, incorrect paths would not generate the error you experienced.

One thing you should take note of is how I used the New keyword. When you Dimensioned your variable for the application, you did not instantiate it right away. So, if you used your declarations, you might have gotten that error. I would have expected something a little different though.
Dim ExcelApp As Excel.Application

Where mine is
Dim xlApp As New Excel.Application

and then I go straight to
Set myBook = xlApp.Workbooks.Add

...

You have one image path hardcoded in there. Did the same image get duplicated through multiple rows? Looks like it should have. Maybe you did not get the correct count.

Looks like you are starting at 10
For i = 10 To c


I can't remember, but I think these cells are 1 based index.

so maybe
For i = 1 To T.Count

or if you want to start at the 10th row
For i = 10 To T.Count

[Jo..]

The code I posted was copied straight out of a working example. If the paths are correct, it should work. However, incorrect paths would not generate the error you experienced.

One thing you should take note of is how I used the New keyword. When you Dimensioned your variable for the application, you did not instantiate it right away. So, if you used your declarations, you might have gotten that error. I would have expected something a little different though.
Dim ExcelApp As Excel.Application

Where mine is
Dim xlApp As New Excel.Application

and then I go straight to
Set myBook = xlApp.Workbooks.Add

...

You have one image path hardcoded in there. Did the same image get duplicated through multiple rows? Looks like it should have. Maybe you did not get the correct count.

Looks like you are starting at 10
For i = 10 To c


I can't remember, but I think these cells are 1 based index.

so maybe
For i = 1 To T.Count

or if you want to start at the 10th row
For i = 10 To T.Count

I have tried with T.count, but it did not work. So I am stuck with:
c = DCount("*", "myQuery") + 9

Yes. I have one image path hardcorded in there. It duplicated through multiple rows. Now I am trying to make the image path as variant which varies when it loop to different records.

I also have another idea to input the string of the path into Excel first. And then command Excel to insert the images based on the records on the Excel. This feels workable.

Jo

[ItsMe]

You have too much jammed in there. Take a step back and get an abstract for something small. Maybe forget the picture for right now and write some records to your worksheet.

You are going to enumerate some stuff to get things dynamic. So, you are going to need a recordcount. You are also going to need to do a little more with DAO.

You should not be doing this
mySheet.Cells(3, 41).Value = Forms![QuoteLog]![LogNumber]

You should use a DAO recordset to write to a cell.
mySheet.Cells(x, y).Value = rs![FieldName]

To get the correct value of a field, you need to open your recordset. I suggest getting it from a Named and Saved Query object. No query defs needed.

Dim rs as dao.recordset
set rs = currentdb.openrecordset("qyrName", dbopenSnapshot)

rs.MoveLast 'get count
rs.Movefirst

dim intCount = rs.Recordcount 'maybe its rs.count

Now you can start your loop and get something like
mySheet.Cells(1, 1).Value = rs![FieldName]


to get the second dimension of your array (that is your cell coordinates). You could probably hard code the known number of fields and create a second loop. Another approach may be to use a multidimensional array.

[Jo..]

You have too much jammed in there. Take a step back and get an abstract for something small. Maybe forget the picture for right now and write some records to your worksheet.

You are going to enumerate some stuff to get things dynamic. So, you are going to need a recordcount. You are also going to need to do a little more with DAO.

You should not be doing this
mySheet.Cells(3, 41).Value = Forms![QuoteLog]![LogNumber]

You should use a DAO recordset to write to a cell.
mySheet.Cells(x, y).Value = rs![FieldName]

To get the correct value of a field, you need to open your recordset. I suggest getting it from a Named and Saved Query object. No query defs needed.

Dim rs as dao.recordset
set rs = currentdb.openrecordset("qyrName", dbopenSnapshot)

rs.MoveLast 'get count
rs.Movefirst

dim intCount = rs.Recordcount 'maybe its rs.count

Now you can start your loop and get something like
mySheet.Cells(1, 1).Value = rs![FieldName]


to get the second dimension of your array (that is your cell coordinates). You could probably hard code the known number of fields and create a second loop. Another approach may be to use a multidimensional array.

The thing is that "mySheet.Cells(3, 41).Value = Forms![QuoteLog]![LogNumber]" will only have one. It does not loop.

[Jo..]

Based on my second idea of get the picture after exporting the data. It works with Excel VBA.

My Excel vba code:

Option Explicit

Sub Picture()
Dim pictureNameColumn   As String 'column where picture name is found
Dim picturePasteColumn  As String 'column where picture is to be pasted


Dim picturePath         As String 'picture name
Dim lastPictureRow      As Long   'last row in use where picture names are
Dim pictureRow          As Long   'current picture row to be processed




    pictureNameColumn = "E"
    picturePasteColumn = "A"
    
    pictureRow = 10 'starts from this row
    
    'error handler
    On Error GoTo Err_Handler
    
    'find row of the last cell in use in the column where picture names are
    lastPictureRow = Cells(Rows.Count, pictureNameColumn).End(xlUp).Row
    
    'stop screen updates while macro is running
    Application.ScreenUpdating = False


    'loop till last row
    Do While (pictureRow <= lastPictureRow)
     
        picturePath = Cells(pictureRow, "E") 'This is the picture name
        
        'if picture name is not blank then
        If (picturePath <> vbNullString) Then
            'check if pic is present
            If (Dir(picturePath) <> vbNullString) Then
            
                Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
                ActiveSheet.Pictures.Insert(picturePath).Select 'Path to where pictures are stored
                
                With Selection
                    .Left = Cells(pictureRow, picturePasteColumn).Left
                    .Top = Cells(pictureRow, picturePasteColumn).Top
                    .ShapeRange.LockAspectRatio = msoTrue
                    .ShapeRange.Height = 100#
                    .ShapeRange.Width = 130#
                    .ShapeRange.Rotation = 0#
                End With
            Else
                'picture name was there, but no such picture
                Cells(pictureRow, picturePasteColumn) = "No Picture Found"
            End If
        Else
            'picture name cell was blank
        End If
        'increment row count
        pictureRow = pictureRow + 1
    Loop
     
Exit_Sub:
    Range("A10").Select
    Application.ScreenUpdating = True
    Exit Sub
    
Err_Handler:
     MsgBox "Error encountered. " & Err.Description, vbCritical, "Error"
    GoTo Exit_Sub


End Sub

Now I will try putting this into Access to make it work!