Shapes don't have a LoadPicture method. You'd need:

ActiveSheet.Shapes("Rettangolo con angoli arrotondati 2").Fill.UserPicture ActiveWorkbook.Path & "ImmaginiCavallo_Nero" & ".jpg"

 

There is no Clipboard object in VBA so no you can't use SetImage and GetImage. Search the web for Stephen Bullen's PastePicture code.

Hi Velouria Nice to meet you.
First I say thank you for your code; Nor will I certainly make good use of it.

But in spite of everything it doesn't work as my project is written like this:

 

Sub EsportaFoglio() On Error GoTo 1 Dim NomeFoglio As String Dim CurFolder, DestFolder, DestFile Dim Shp As Shape Dim SH As Foglio1 Dim idomanda As Integer Application.ScreenUpdating = False 'Qui Si Prende Il Nome Da Dare Al File Appena Creato NomeFoglio = Range("B2").Value & "" 'Funzione Identificativa Del Percorso Di Salvataggio Del File Appena Creato CurFolder = ActiveWorkbook.Path DestFolder = CurFolder & "Allegati" DestFile = DestFolder & NomeFoglio & ".xlsx" 'Qui Si Verifica Che Il File Che Si Vuole Creare Non Sia Già Disponibile If Dir(DestFolder, vbDirectory) = "" Then idomanda = MsgBox("Occorre Creare La Sottocartella Denominata Allegati", vbYesNo, "By A.Maurizio - Attenzione !") If idomanda = vbYes Then Exit Sub Else End If End If 'Qui Si Avverte Che Il File Di Excel Esiste Già - Pertanto Se Si Risponde Con Il Tasto ( Si ) _ Il File Esistente Verrebbe Sostituito If Dir(DestFile) <> "" Then idomanda = MsgBox("Esiste Già !!!!", vbYesNo, "By A.Maurizio - Attenzione !") If idomanda = vbYes Then Kill DestFile Else Exit Sub End If End If 'Application.ScreenUpdating = False 'Qui Si Prende Solo Una determinata Area Del Foglio Originale Con i suoi Dati - E Lo Si _ Trasporta Nel Nuovo Foglio Appena Creato Set range1 = Range("A6:L21") Set newbook = Workbooks.Add range1.Copy Range("A1").PasteSpecial Paste:=xlPasteValues 'Con Questo Codice Si Adattano Le Celle Che Hanno Un Dato All'oro Interno Più lungo _ Della cella stessa, in Modo da Poter Visualizzare Il tutto. Range("A6").Select Columns("A:L").ColumnWidth = 16 Range("A1").Select ActiveSheet.Shapes("Rettangolo 2").Fill.UserPicture ActiveWorkbook.Path & "Immagini_Di_AppoggioTopolino" & ".jpg" 'Questo Codice Preleva I Dati dalle Varie Funzioni E Li Salva per Creare Il Foglio Di Excel Da Noi Desiderato. ActiveWorkbook.SaveAs Filename:=DestFile, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 'Questo codice Fa In Modo Che Il Foglio Di excel Appena Creato Venga Subito Salvato Nella Nostra _ Sottocartella Senza Essere Aperto. ActiveWindow.Close 'Application.Quit 'Application.ScreenUpdating = True 1: 'Call AddDonutShape End Sub

 

Therefore it is true that the Sheet is created and placed in my sub-folder (Attachments)
But only:
1) Not only does the scapes already positioned on base sheet 1 not transport me to the new sheet
2) But if I also put your code before Copy and PasteSpecial,
If I send everything, a sheet is opened with no data and no shapes inserted.
3) And finally the new file is not saved in the folder
That's all
I guarantee you that I have tried to do everything, but there has been no way to do differently to what you see, if you try my project!.
Thanks for everything however you are fantastic
Hello from A.Maurizio
(P.S) I am attaching test files

Well that escalated quickly! 😉

Just FYI, it's really not a great idea to just put an error handler that exits silently at the top of your code - makes debugging harder.

Anyway, this should work:

Sub EsportaFoglio()
On Error GoTo 1

Dim NomeFoglio As String
Dim CurFolder, DestFolder, DestFile
Dim Shp As Shape
Dim SH As Foglio1
Dim idomanda As Integer

Application.ScreenUpdating = False

'Qui Si Prende Il Nome Da Dare Al File Appena Creato
NomeFoglio = Range("B2").Value & ""

'Funzione Identificativa Del Percorso Di Salvataggio Del File Appena Creato
CurFolder = ActiveWorkbook.Path

DestFolder = CurFolder & "Allegati"
DestFile = DestFolder & NomeFoglio & ".xlsx"

'Qui Si Verifica Che Il File Che Si Vuole Creare Non Sia Già Disponibile
If Dir(DestFolder, vbDirectory) = "" Then
idomanda = MsgBox("Occorre Creare La Sottocartella Denominata Allegati", vbYesNo, "By A.Maurizio - Attenzione !")
If idomanda = vbYes Then
Exit Sub

Else

End If
End If

'Qui Si Avverte Che Il File Di Excel Esiste Già - Pertanto Se Si Risponde Con Il Tasto ( Si ) _
Il File Esistente Verrebbe Sostituito
If Dir(DestFile) <> "" Then
idomanda = MsgBox("Esiste Già !!!!", vbYesNo, "By A.Maurizio - Attenzione !")
If idomanda = vbYes Then
Kill DestFile

Else
Exit Sub

End If
End If

'Application.ScreenUpdating = False

'Qui Si Prende Solo Una determinata Area Del Foglio Originale Con i suoi Dati - E Lo Si _
Trasporta Nel Nuovo Foglio Appena Creato
Set range1 = Range("A6:L21")

Dim newBook As Workbook
Set newBook = Workbooks.Add
Dim destSheet As Worksheet
Set destSheet = newBook.Sheets(1)

Application.CopyObjectsWithCells = True
range1.Copy
With destSheet
.Paste Destination:=.Range("A1")
.Range("A1").PasteSpecial Paste:=xlPasteValues

'Con Questo Codice Si Adattano Le Celle Che Hanno Un Dato All'oro Interno Più lungo _
Della cella stessa, in Modo da Poter Visualizzare Il tutto.
.Columns("A:L").ColumnWidth = 16
.Shapes("Rettangolo 2").Fill.UserPicture CurFolder & "Immagini_Di_AppoggioTopolino" & ".jpg"
End With

'Questo Codice Preleva I Dati dalle Varie Funzioni E Li Salva per Creare Il Foglio Di Excel Da Noi Desiderato.
newBook.SaveAs Filename:=DestFile, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

'Questo codice Fa In Modo Che Il Foglio Di excel Appena Creato Venga Subito Salvato Nella Nostra _
Sottocartella Senza Essere Aperto.
newBook.Close
'Application.Quit

'Application.ScreenUpdating = True
1:
'Call AddDonutShape
End Sub

Hi Velouria, I congratulate you on your program; Even if it is known that it does not differ much from what I had done up to now.
But I tried your program
And I must say that it is true that now everything seems to be normal; Including Image.
What I could notice is that the new excel file is not saved in the Subfolder ( Attachments )!
But the file is simply created and then automatically opened.
At this point what should I do in your opinion
to automatically save the Whole as it is.
I await your clarifications on the matter
In the meantime I offer you my sincere thanks from A.Maurizio

Again Hi Velouria
I took your opening sentences of your last post for good; When you were referring to mine (On Error goto Finish) and its Debuggin
For here I removed it and started everything
So it is true that he gave me an error immediately highlighting this part of the program

(.Shapes ("Rectangle 2"). Fill.UserPicture CurFolder & " Support_Pictures Mickey Mouse" & ".jpg")

But I was able to immediately understand where the mistake lay
Therefore, all I did was put the writing (Sheet1) at the beginning of the procedure
Doing so now also save the file in the sub-folder ( Attachments ) Therefore I ask you to no longer keep my last request as I am satisfied with it.

Thanks again for everything Sincere Greetings and Good Evening to you and all the staff of MyOnlineTraininghub
By A.Maurizio