Insert pictures to external Excel file

[Tobback]

I am trying to insert text and pictures from a specific folder to a hidden Excel file, in specific cells, but for some reason I do not succeed in adding the pictures to the file.

What I can is open a hidden Excel file and add a bunch of data to the Excel. I can also add pictures tot the Excel from which the VBA script is running. However combining both is something where I fail.

I use the following code to open an Excel file and put data in there:

Dim ExcelFileName As String
ExcelFileName = "C:\PictureTest.xlsx"

Dim Workbook As New Excel.Application
Dim DataWorkbook As New Excel.Workbook
Set DataWorkbook = Workbook.Workbooks.Open(ExcelFileName)
Workbook.Sheets("Sheet1").Cells(1, 1) = "Data to CELL"
DataWorkbook.Save
DataWorkbook.Close
Set Workbook = Nothing
Set DataWorkbook = Nothing
This one works perfectly, I can put data in any sheet anywhere I want. However I also need to put pictures on certain sheets/cells.

I use the following code to add a picture to the active Excel file from which I am running the VBA script:

Dim PicturePath As String
PicturePath = "C:\Picture.tif"

Dim strPath As String
Dim Picture As Object
Set Picture = ActiveSheet.Pictures.Insert(PicturePath)
Picture.ShapeRange.LockAspectRatio = msoCTrue
Picture.Placement = xlMoveAndSize
Picture.ShapeRange.Width = 0.3 * Picture.Width

Is there anyone who can help me in getting both combined?

 

[Domenic]

The following macro should get you started. Note, however, change the path to the folder accordingly. Also, since there's a bug with Pictures.Insert since Excel 2010, Shapes.AddPicture is used instead.

Option Explicit

Sub UpdateWorkbook()
    
    Dim strPath As String
    Dim strFile As String
    Dim strPicture As String
    Dim wkbOpen As Workbook
    Dim shpPicture As Shape
    
    Application.ScreenUpdating = False
    
    strPath = "C:\Users\Domenic\Desktop\" 'change the path accordingly
    If Right(strPath, 1) <> "\" Then
        strPath = strPath & "\"
    End If
    
    strFile = "PictureTest.xlsx"
    strPicture = "Picture.tif"
    
    Set wkbOpen = Workbooks.Open(strPath & strFile)
    
    With wkbOpen
        With .Worksheets("Sheet1")
            .Cells(1, 1).Value = "Data to Cell"
            Set shpPicture = .Shapes.AddPicture(Filename:=strPath & strPicture, LinkToFile:=msoFalse, _
                SaveWithDocument:=msoTrue, Left:=.Range("A3").Left, Top:=.Range("A3").Top, Width:=-1, Height:=-1)
            With shpPicture
                .Placement = xlMoveAndSize
                .Width = .Width * 0.3
            End With
        End With
        With .Worksheets("Sheet2")
            'etc
            '
            '
        End With
    End With
    
    With wkbOpen
        .Save
        .Close
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "Completed", vbInformation 'optional
    
    Set wkbOpen = Nothing
    Set shpPicture = Nothing


End Sub

Hope this helps!

 

[Tobback]

Thanks a lot Domenic!!!
You make my day!
That is exactly what I needed, thank you so much!

 

[Domenic]

You're very welcome. I'm glad I could help. And thanks for the feedback.

Cheers!