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

[Jo..]

Now I am stuck again. Does anyone know how to transfer the excel vba to access vba? Now the Excel macro will run after clicking on an icon. It would be nice if I could have access to do the job. Please help transfer to access vba code.

Option Explicit

Sub Picture1_Click()
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


    
    '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 = 150#
                    .ShapeRange.Width = Cells(pictureRow, picturePasteColumn).Width
                    .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
     
    Range("A10").Select
    Application.ScreenUpdating = True
    Exit Sub
    
End Sub

Thank you experts. Your input really helped me a lot!

[ItsMe]

Does anyone know how to transfer the excel vba to access vba?

I think I was trying to explain how to do this in an earlier post. Aside from generating my own test data and creating my own example, I am not sure how else to explain it. There is certainly more than one way to approach this. I have offered to help you analyze your problem and determine the most feasible approach. Not sure what else I can do. As far as knowing how, exporting data into Excel is not anything new. There are plenty of examples out there.

[June7]

Code in Access to manipulate Excel requires opening Excel objects in VBA. This is already demonstrated in earlier posts of this thread, including the original post.

[Jo..]

My bad for not putting the code of my attempt here. I have already removed the code from my database, as it failed before I asked the question. I will try again and post the code that I try with and ask the question again (If I fail again). I hope not!!!!!!

[Jo..]

Hi All!!!! I am back just to share my solution to this question. Below code is the code that is working for me.
Thank you experts for giving me the logic to do this.

Option Compare DatabaseOption Explicit


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


Sub Model1()
    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") + 3


    '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 = 4 To c
    'Enter your data from your table here to the required cells
    mySheet.Range("A" & i) = i - 3
    mySheet.Range("B" & i) = T("ProductPicture")
    
    If mySheet.Rows(i).RowHeight < 150 Then
    mySheet.Rows(i).RowHeight = 150
    End If
    
    Dim myPict As Excel.Picture
    Dim picturePath As String
    
    picturePath = mySheet.Cells(i, 2)
    
    With mySheet.Cells(i, 2)
        Set myPict = .Parent.Pictures.Insert(picturePath)
        myPict.ShapeRange.LockAspectRatio = msoTrue
        If (myPict.Height \ myPict.Width) <= (.Height \ .Width) Then
            myPict.Width = .Width - 1
            myPict.Left = .Left + 1
            myPict.Top = .Top + ((.Height - myPict.Height) / 2)
        Else
            myPict.Top = .Top + 1
            myPict.Height = .Height - 1
            myPict.Left = .Left + ((.Width - myPict.Width) / 2)
        End If
    End With
        
    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