I am using the following code to add a picture and load an image in it on worksheet.
Sub Test()
Dim shp As Shape
Set shp = ActiveSheet.Shapes.AddPicture("Sample.jpg", msoFalse, msoTrue, 100, 100, 100, 100)
shp.Name = "MyPhoto"
End Sub
How can I unload the picture from the shape?
I tried these lines but none worked for me
Sub Unload_Picture()
Dim shp As Shape
Set shp = ActiveWorkbook.Sheets(1).Shapes("MyPhoto")
'shp.Picture = Nothing
'shp.Picture = LoadPicture("")
End Sub
Add image control with vba
Sub ImageCTRL()
Dim Img As OLEObject, pic As MSForms.Image
Dim sh As Worksheet
Set sh = ActiveSheet
With sh
Set Img = .OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, _
DisplayAsIcon:=False, Left:=20, Top:=20, Width:=400, Height:=400)
With Img
.Name = "MyImg"
Set pic = Img.Object
pic.Picture = LoadPicture("C:\Users\yourpic.pdf Page 1 image 1.jpeg")
End With
End With
End Sub
To change the picture in the control.
Sub changeImg()
Me.MyImg.Picture = LoadPicture("C:\Users\otherpic.jpg")
End Sub
I have these codes in the worksheet module.
The image control has an autofit feature, check the cntrl properties window.
You can also resize the control to a specified size, same as when you added it.
Sub changeImg()
Me.MyImg.Picture = LoadPicture("C:\Users\newPic.jpeg")
With Me.MyImg
.Top = 20
.Left = 20
.Width = 400
.Height = 400
End With
End Sub
I created a macro for Excel which opens a list of all visible sheets in a workbook and goes to the desired sheet as you scroll through the list. The idea is to avoid using the mouse as much as possible.
I am forced to scroll down starting from the first item in the list.
I would like to instead "start" from the initial sheet (wherever it may be) so I can scroll up/down depending on what sheet I would like to open.
In other words,
I would like the listbox to populate with all visible sheets
I would like the starting point for the user to be the active sheet so they can scroll up/down from their starting point
Code for the listbox:
Private Sub CommandButton1_Click()
Unload ListBox
End Sub
Private Sub UserForm_Initialize()
Dim WS As Worksheet
For Each WS In Worksheets
ListBox1.AddItem WS.Name
Next WS
End Sub
Private Sub ListBox1_Click()
Sheets(ListBox1.Value).Activate
End Sub
Code which opens the listbox:
Public Sub ShowUserForm()
Load ListBox
ListBox.Show
Debug.Print "===="
Debug.Print
End Sub
another one...
Private Sub UserForm_Initialize()
Dim ws As Worksheet, idx As Long
With Me.ListBox1
For Each ws In ActiveWorkbook.Worksheets
If ws.Visible = xlSheetVisible Then
.AddItem ws.Name
If ws Is ActiveSheet Then
idx = .ListCount - 1 ' item indexes start at zero
End If
End If
Next
.ListIndex = idx '
End With
End Sub
Private Sub ListBox1_Change()
Worksheets(ListBox1.Value).Activate
End Sub
You mentioned "all . . . sheets", if you want to include Chart sheets loop Each objSheet in Sheets and in the change event replace Worksheets with Sheets
what's about that:
Private Sub UserForm_Initialize()
Dim wksTab As Worksheet
For Each wksTab In ThisWorkbook.Worksheets
If wksTab.Visible = xlSheetVisible Then
If wksTab.Name <> ActiveSheet.Name Then
Me.ListBox1.AddItem wksTab.Name
End If
End If
Next wksTab
Me.ListBox1.AddItem ActiveSheet.Name
Me.ListBox1.ListIndex = Me.ListBox1.ListCount - 1
End Sub
Best regards
Bernd
Hy, I have an excel workbook consisting an Excel Sheet which contains images, shapes, arrows and many more shapes. The structure of the sheet looks like this.
In the above picture, I circle all the textboxes, arrows, Ovels, shapes which I want to delete. I have written a code to delete text boxes which are checking the existence of textboxes and if found delete them. In the other hand, if not exist show pop-up that text-box, does not exist. The code is as under.
Sub resetall()
Dim ws As Worksheet
Dim arow As Shapes
Dim txtbox As TextBox
Set ws = ActiveSheet
If ws.TextBoxes.Count < 0 Then
MsgBox "No Text Box Exist."
Exit Sub
End If
ws.TextBoxes.Delete
MsgBox "Text Box has been deleted successfully."
End Sub
This code is working fine, but I could not find the code for Arrows, and Oval Shapes, and Circles. Please check my code and guide me. I tried to use the shapes. Oval reference from the library but could not succeed. Please guide me. Thank you.
https://www.thespreadsheetguru.com/the-code-vault/vba-delete-all-shapes
Sub DeleteAllShapes()
'PURPOSE: Remove All Shape Objects From The Active Worksheet
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
shp.Delete
Next shp
End Sub
Optionally, add a test inside the loop for a specific type from msoShapeType
Try the next code, please:
Sub DeleteallShapesExceptRect()
Dim ws As Worksheet, s As Shape, boolRect As Boolean
Set ws = ActiveSheet
For Each s In ws.Shapes
If s.Type = msoAutoShape Then
If s.AutoShapeType = msoShapeRectangle Then
boolRect = True
End If
End If
If Not boolRect Then s.Delete
boolRect = False
Next
The next variant excepts any Rectangle shape type:
Sub DeleteallShapesExceptAllRect()
Dim ws As Worksheet, s As Shape, boolRect As Boolean
Set ws = ActiveSheet
For Each s In ws.Shapes
If s.Type = msoAutoShape Then
If s.AutoShapeType = msoShapeRectangle Or _
msoShapeRoundedRectangle Or msoShapeRound1Rectangle Or _
msoShapeSnip2DiagRectangle Then
boolRect = True
End If
End If
If Not boolRect Then s.Delete
boolRect = False
Next
End Sub
The following variant deletes all shapes from a specific range:
Sub DeleteAllShapesOnRange()
Dim ws As Worksheet, s As Shape, rngDel As Range
Set ws = ActiveSheet: Set rngDel = ws.Range("A1:W6")
For Each s In ws.Shapes
If Not Intersect(rngDel, s.TopLeftCell) Is Nothing Then
s.Delete
End If
Next
End Sub
And the next one deletes all shapes which are Not on the specific range:
Sub DeleteAllShapesNotOnRange()
Dim ws As Worksheet, s As Shape, rngNoDel As Range, boolFound As Boolean
Set ws = ActiveSheet: Set rngNoDel = ws.Range("A1:W6")
For Each s In ws.Shapes
If Not Intersect(rngNoDel, s.TopLeftCell) Is Nothing Then
boolFound = True
End If
If Not boolFound Then s.Delete
Next
End Sub
And finally, a version deleting all shapes not having text:
Sub DeleteAllShapesNotHavingText()
Dim ws As Worksheet, s As Shape, boolFound As Boolean
Set ws = ActiveSheet
For Each s In ws.Shapes
If Not Len(s.TextFrame2.TextRange.Text) = 0 Then
boolFound = True
End If
If Not boolFound Then s.Delete
Next
End Sub
Note: Each such a code is able to ask for permission before deletion, but it will not make big difference between the manual deletion and the one done in code... If you insist to have such a condition, please specify which of the above versions to be adapted.
Anyhow, the next Sub returns (in Immediate Window) all (mentioned) shapes type. You can change their names. The following code check their real type, which is returned like Long:
Sub EnumerateShapesType()
Dim ws As Worksheet, s As Shape, boolRect As Boolean, arrS As Variant, arrEl As Variant, El As Variant
arrS = Split("Rectangle|1,Round Rectangle|5,Oval|9,Right Arrow|33,Down Arrow|36", ",")
Set ws = ActiveSheet
For Each s In ws.Shapes
If s.Type = msoAutoShape Then
For Each El In arrS
If s.AutoShapeType = Split(El, "|")(1) Then
Debug.Print s.Name, Split(El, "|")(0): Exit For
End If
Next
End If
Next
End Sub
Office 365 answer:
Go to the Home tab
Go to Find & Select
Go to Selection Pane
You now have the names of the shapes in your worksheet.
As an example, you could use ActiveSheet.Shapes.Range(Array("Straight Arrow Connector 1")).Delete to remove a single item.
I have a workbook with various worksheets. Each sheet has a button to open a userform which i used to input data in the respective sheet. E.g. button 1 in "sheet1" to open userform1 to input data in sheet1. Button 2 in "sheet2" to open userform2 to input data in sheet2 and so on.
I wanted to create shortcut buttons for each button 1,2 in the main sheet to directly open respective userform i wanted.
Thanks for your help in advance.
I supposed that the buttons are form controls and you rename their caption "Form1", "Form2" and so on ..
The first sheet name is "Main" >> so try this code that will copy your buttons to the Main sheet
Sub Test()
Dim ws As Worksheet
Dim sh As Worksheet
Dim shp As Shape
Dim rw As Long
Set ws = ThisWorkbook.Worksheets("Main")
rw = 5
Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> ws.Name Then
sh.Activate
For Each shp In ActiveSheet.Shapes
If shp.Type = msoOLEControlObject Or shp.Type = msoFormControl Then
If Left(shp.AlternativeText, 4) = "Form" Then
shp.Copy
Application.Goto Sheets("Main").Range("G" & rw)
ActiveSheet.Paste
rw = rw + 2
End If
End If
Next shp
End If
Next sh
Application.ScreenUpdating = True
End Sub
Here is some code from an xls file. In Excel 2010 it doesn't work. I can't find the collection Pictures in the object explorer
Private Sub Worksheet_Calculate()
Dim oPic As Picture
'make them invisible
For Each oPic In Me.Pictures
If Left(oPic.Name, 2) = "jq" Then
oPic.Visible = False
End If
Next
end sub
What would the equivalent 2010 code be?
Use this to loop through pictures in Excel
Sub Sample()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
If shp.Type = msoPicture Then
Debug.Print shp.Name
End If
Next
End Sub