Hello,
The code below is replacing a picture with another in only one sheet. How to modify this code to replace all pictures ( all named "Picture 2") in a folder with 15 workbooks where each workbook has 3 sheets ( named "Pic1", "Pic2" and "Pic3" ) with this picture named "Picture 2".
'change picture without change image size
Sub change_picture()
strPic = "Picture 2"
Set shp = Worksheets(1).Shapes(strPic)
'Capture properties of exisitng picture such as location and size
With shp
t = .Top
l = .Left
h = .Height
w = .Width
End With
Worksheets(1).Shapes(strPic).Delete
Set shp = Worksheets(1).Shapes.AddPicture("C:\Users\mike\Desktop\lastpic\.1\2.jpg", msoFalse, msoTrue, l, t, w, h)
shp.Name = strPic
End Sub
Sub change_picture()
' Change as needed, keep the \ at the end
Const strFolder = "C:\Excel\"
Const strPic = "Picture 2"
Const strPicFile = "C:\Users\mike\Desktop\lastpic\.1\2.jpg"
Dim strFile As String
Dim wbk As Workbook
Dim wsh As Worksheet
Dim shp As Shape
Dim t As Single, l As Single, h As Single, w As Single
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
strFile = Dir(strFolder & "*.xls*")
Do While strFile <> ""
Set wbk = Workbooks.Open(Filename:=strFolder & strFile, UpdateLinks:=False)
For Each wsh In Worksheets(Array("Pic1", "Pic2", "Pic3"))
Set shp = wsh.Shapes(strPic)
'Capture properties of existing picture such as location and size
With shp
t = .Top
l = .Left
h = .Height
w = .Width
.Delete
End With
Set shp = wsh.Shapes.AddPicture(strPicFile, msoFalse, msoTrue, l, t, w, h)
shp.Name = strPic
Next wsh
wbk.Close SaveChanges:=True
strFile = Dir
Loop
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Hello,
I added another sheet "Pic4" which is protected and gave me an error:
(The specified value is out of range.) and line ".Delete" became highlighted. I tried to find if I have a misspelling but I found nothing.
Do you think because sheet "Pic4" is protected?
Thanks
Sub change_picture()
' Change as needed, keep the \ at the end
Const strFolder = "C:\Excel\"
Const strPic = "Picture 2"
Const strPicFile = "C:\Users\mike\Desktop\lastpic\.1\2.jpg"
Dim strFile As String
Dim wbk As Workbook
Dim wsh As Worksheet
Dim f As Boolean
Dim shp As Shape
Dim t As Single, l As Single, h As Single, w As Single
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
strFile = Dir(strFolder & "*.xls*")
Do While strFile <> ""
Set wbk = Workbooks.Open(Filename:=strFolder & strFile, UpdateLinks:=False)
For Each wsh In Worksheets(Array("Pic1", "Pic2", "Pic3", "Pic4", "Pic5"))
If wsh.ProtectContents Then
f = True
wsh.Unprotect
End If
Set shp = wsh.Shapes(strPic)
'Capture properties of existing picture such as location and size
With shp
t = .Top
l = .Left
h = .Height
w = .Width
.Delete
End With
Set shp = wsh.Shapes.AddPicture(strPicFile, msoFalse, msoTrue, l, t, w, h)
shp.Name = strPic
If f Then
wsh.Protect
f = False
End If
Next wsh
wbk.Close SaveChanges:=True
strFile = Dir
Loop
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
sets shp to the first shape with the specified name that it finds. It's a bad idea to have multiple shapes with the same name - you never know which one you're dealing with.
I changed the name of the second picture from "Picture 2" to "Picture 1", I changed the line
Const strPic = "Picture 2" to
Const strPic = "Picture 1". I run the macro again and the line
Set shp = wsh.Shapes(strPic) became highlighted. Is that because the code always finds the first picture?
Regards
If all the sheets Pic1 to Pic5 contain a picture named Picture 1, the code should work.
If you forgot to rename it in one or more of those sheets, you'd get an error.
