• Skip to main content
  • Skip to header right navigation
  • Skip to site footer

My Online Training Hub

Learn Dashboards, Excel, Power BI, Power Query, Power Pivot

  • Courses
  • Pricing
    • Free Courses
    • Power BI Course
    • Excel Power Query Course
    • Power Pivot and DAX Course
    • Excel Dashboard Course
    • Excel PivotTable Course – Quick Start
    • Advanced Excel Formulas Course
    • Excel Expert Advanced Excel Training
    • Excel Tables Course
    • Excel, Word, Outlook
    • Financial Modelling Course
    • Excel PivotTable Course
    • Excel for Customer Service Professionals
    • Excel for Operations Management Course
    • Excel for Decision Making Under Uncertainty Course
    • Excel for Finance Course
    • Excel Analysis ToolPak Course
    • Multi-User Pricing
  • Resources
    • Free Downloads
    • Excel Functions Explained
    • Excel Formulas
    • Excel Add-ins
    • IF Function
      • Excel IF Statement Explained
      • Excel IF AND OR Functions
      • IF Formula Builder
    • Time & Dates in Excel
      • Excel Date & Time
      • Calculating Time in Excel
      • Excel Time Calculation Tricks
      • Excel Date and Time Formatting
    • Excel Keyboard Shortcuts
    • Excel Custom Number Format Guide
    • Pivot Tables Guide
    • VLOOKUP Guide
    • ALT Codes
    • Excel VBA & Macros
    • Excel User Forms
    • VBA String Functions
  • Members
    • Login
  • Blog
  • Excel Webinars
  • Excel Forum
    • Register as Forum Member

How to Get an Image from my Subfolder and Display it in a Shapes|VBA & Macros|Excel Forum|My Online Training Hub

You are here: Home / How to Get an Image from my Subfolder and Display it in a Shapes|VBA & Macros|Excel Forum|My Online Training Hub

vba course banner

Avatar
sp_LogInOut Log In sp_Registration Register
sp_Search Search
Advanced Search|Last Search Results
Search
Forum Scope




Match



Forum Options



Minimum search word length is 3 characters - maximum search word length is 84 characters
sp_Search Search
sp_RankInfo
Lost password?
sp_CrumbsHome HomeExcel ForumVBA & MacrosHow to Get an Image from my Subfold…
sp_PrintTopic sp_TopicIcon
How to Get an Image from my Subfolder and Display it in a Shapes
Avatar
A.Maurizio
Member
Members
Level 0
Forum Posts: 202
Member Since:
June 26, 2016
sp_UserOfflineSmall Offline
1
July 13, 2022 - 4:26 am
sp_Permalink sp_Print

Hello everyone from Maurizio
I am writing to you because I would like to know how to take an image from my undercoat
And visualize it in a shape Positioned on the Excel sheet All here thanks.

I of mine have tried this code, but it keeps giving me error.

 

ActiveSheet.Shapes("Rettangolo con angoli arrotondati 2").LoadPicture (ActiveWorkbook.Path & "\Immagini\Cavallo_Nero" & ".jpg")

 

In addition, according to you, it is possible to use the Clipboar SetImage and GetImage method
Thank you for all the help you will want to give me on this
Greetings From A.Maurizio

Avatar
Velouria
London or thereabouts
Moderator
Members


Trusted Members

Moderators
Level 4
Forum Posts: 648
Member Since:
November 1, 2018
sp_UserOfflineSmall Offline
2
July 13, 2022 - 6:56 pm
sp_Permalink sp_Print

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

ActiveSheet.Shapes("Rettangolo con angoli arrotondati 2").Fill.UserPicture ActiveWorkbook.Path & "\Immagini\Cavallo_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.

Avatar
A.Maurizio
Member
Members
Level 0
Forum Posts: 202
Member Since:
June 26, 2016
sp_UserOfflineSmall Offline
3
July 14, 2022 - 2:40 am
sp_Permalink sp_Print

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_Appoggio\Topolino" & ".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

Avatar
Velouria
London or thereabouts
Moderator
Members


Trusted Members

Moderators
Level 4
Forum Posts: 648
Member Since:
November 1, 2018
sp_UserOfflineSmall Offline
4
July 14, 2022 - 7:58 pm
sp_Permalink sp_Print

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_Appoggio\Topolino" & ".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

Avatar
A.Maurizio
Member
Members
Level 0
Forum Posts: 202
Member Since:
June 26, 2016
sp_UserOfflineSmall Offline
5
July 14, 2022 - 11:46 pm
sp_Permalink sp_Print sp_EditHistory

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

Avatar
A.Maurizio
Member
Members
Level 0
Forum Posts: 202
Member Since:
June 26, 2016
sp_UserOfflineSmall Offline
6
July 15, 2022 - 12:05 am
sp_Permalink sp_Print

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

sp_Feed
Go to top
Forum Timezone: Australia/Brisbane
Most Users Ever Online: 245
Currently Online: Philip Treacy
Guest(s) 11
Currently Browsing this Page:
1 Guest(s)
Top Posters:
SunnyKow: 1432
Anders Sehlstedt: 873
Purfleet: 414
Frans Visser: 346
David_Ng: 306
lea cohen: 222
Jessica Stewart: 216
A.Maurizio: 202
Aye Mu: 201
jaryszek: 183
Newest Members:
Melanie Ford
Isaac Felbah
Adele Glover
Hitesh Asrani
Rohan Abraham
Anthony van Riessen
Erlinda Eloriaga
Abisola Ogundele
MARTYN STERRY
Rahim Lakhani
Forum Stats:
Groups: 3
Forums: 24
Topics: 6356
Posts: 27793

 

Member Stats:
Guest Posters: 49
Members: 32324
Moderators: 3
Admins: 4
Administrators: Mynda Treacy, Philip Treacy, Catalin Bombea, FT
Moderators: MOTH Support, Velouria, Riny van Eekelen
© Simple:Press —sp_Information

Sidebar

Blog Categories

  • Excel
  • Excel Charts
  • Excel Dashboard
  • Excel Formulas
  • Excel PivotTables
  • Excel Shortcuts
  • Excel VBA
  • General Tips
  • Online Training
  • Outlook
  • Power Apps
  • Power Automate
  • Power BI
  • Power Pivot
  • Power Query
microsoft mvp logo
trustpilot excellent rating
Secured by Sucuri Badge
MyOnlineTrainingHub on YouTube Mynda Treacy on Linked In Mynda Treacy on Instagram Mynda Treacy on Twitter Mynda Treacy on Pinterest MyOnlineTrainingHub on Facebook
 

Company

  • About My Online Training Hub
  • Disclosure Statement
  • Frequently Asked Questions
  • Guarantee
  • Privacy Policy
  • Terms & Conditions
  • Testimonials
  • Become an Affiliate

Support

  • Contact
  • Forum
  • Helpdesk - For Technical Issues

Copyright © 2023 · My Online Training Hub · All Rights Reserved. Microsoft and the Microsoft Office logo are trademarks or registered trademarks of Microsoft Corporation in the United States and/or other countries. Product names, logos, brands, and other trademarks featured or referred to within this website are the property of their respective trademark holders.