Не все так просто, но возможно.
Надо немножко "разобрать" файл и найти картинку
Sub test()
Dim oSourseSheet As Worksheet: Set oSourseSheet = Application.ActiveSheet
Dim WB As Workbook: Set WB = Workbooks.Add(xlWBATWorksheet)
If CopyBackgroundPicture(oSourseSheet, WB.Sheets(1)) _
Then MsgBox "Подложка скопирована": WB.Activate _
Else MsgBox "Что-то пошло не так"
End Sub
Private Function CopyBackgroundPicture(ByRef oSourseSheet As Worksheet, ByRef oTargetSheet As Worksheet) As Boolean
'' Author: boa
'' Written: 12.07.2019
'' Edited:
' Description: Копирует подложку листа SourseSheet
' TargetSheet - лист куда надо скопировать
On Error Resume Next
Dim newFile$, sFiles$
Dim ZipFile$, PathZip$
Dim Pict$, PathPicture$
newFile = Environ("temp") & "\temp.xlsx"
ZipFile = Environ("temp") & "\temp.zip"
If Dir(ZipFile) <> "" Then Kill ZipFile
CopySheet oSourseSheet, newFile
Name newFile As ZipFile
PathZip = UnZipFiles(ZipFile)
' имя файла "image1.png" получено экспериментальным путем. Может отличаться. Надо тестить.
' можно перебором вытянуть все картинки и потом предоставить пользователю право выбора.
oTargetSheet.SetBackgroundPicture Filename:=PathZip & "xl\media\" & "image1.png"
Shell "cmd /c rd /S/Q """ & PathZip & """" 'удаляем временную папку Zip
Kill ZipFile 'удаляем файл Zip
CopyBackgroundPicture = Err = 0
End Function
Private Sub CopySheet(ByVal oSourseSheet As Worksheet, ByVal sSaveFullName$)
Dim WB As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set WB = Workbooks.Add(xlWBATWorksheet)
With WB
oSourseSheet.Copy after:=.Sheets(1)
.Sheets(1).Delete
.SaveAs sSaveFullName
.Close False
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Function UnZipFiles$(ByVal ZipName$)
' ZipName - полный путь к архиву
' DestPath - полный путь к папке для распаковки архива
Dim ShellApp As Object, DestPath As String
DestPath = Environ("tmp") & "\UNZIP_" & CLng(Timer) & "\"
MkDir DestPath
Set ShellApp = CreateObject("Shell.Application")
'Copy the files in the newly created folder
ShellApp.Namespace((DestPath)).CopyHere ShellApp.Namespace((ZipName)).Items
Set ShellApp = Nothing
UnZipFiles = DestPath
End Function