Changing picture using macro

[manojtmenon]

i have an excel report its contain many picture i want to change all picture in same size using macro , pls help me how to do using macro

 

[NARAYANK991]

Hi ,

If this is a one-off exercise , what is the need for a macro ?

Select any one picture , press CTRL A to select all pictures , right-click and deselect the checkboxes Lock aspect ratio and Relative to original picture size.

Now , set the picture height and width to what ever you want.

Narayan

 

[Kenneth Hobson]

I did not address aspect ratios though it can do so easily.

Sub SamePicSize()
  Dim i As Integer, c As Integer
  Dim h As Double, w As Double
  With ActiveSheet
    c = .Shapes.Count
    If c <= 1 Then Exit Sub
    h = .Shapes(1).Height
    w = .Shapes(1).Width
    For i = 2 To c
      'https://msdn.microsoft.com/VBA/Office-Shared-VBA/articles/msoautoshapetype-enumeration-office
      If .Shapes(i).AutoShapeType = msoShapeRectangle Then '1
        .Shapes(i).Width = w
        .Shapes(i).Height = h
      End If
    Next i
  End With
End Sub

 

[manojtmenon]

i need change picture code also , pls help me to provide change current picture to new picture by macro,because i have many new images so its difficult to change one by one.

 

[manojtmenon]

Hi ,

If this is a one-off exercise , what is the need for a macro ?

Select any one picture , press CTRL A to select all pictures , right-click and deselect the checkboxes Lock aspect ratio and Relative to original picture size.

Now , set the picture height and width to what ever you want.

Narayan

 

[manojtmenon]

i want to change current images to new images with same size and same position so like this many sheet i want to make .so pls provide macro it should select pictures and replace to new pictures with same size.

 

[manojtmenon]

Sub Change_PIC()
'
' Change_PIC Macro
'

'
ActiveSheet.Shapes.Range(Array("Picture 1")).Select
ActiveSheet.Shapes.Range(Array("Picture 1")).Select
ActiveSheet.Shapes.Range(Array("Picture 2")).Select
ActiveSheet.Shapes.Range(Array("Picture 3")).Select
ActiveSheet.Shapes.Range(Array("Picture 7")).Select
ActiveSheet.Shapes.Range(Array("Picture 8")).Select
ActiveSheet.Shapes.Range(Array("Picture 9")).Select
ActiveSheet.Shapes.Range(Array("Picture 4")).Select
ActiveSheet.Shapes.Range(Array("Picture 5")).Select
ActiveSheet.Shapes.Range(Array("Picture 6")).Select
ActiveSheet.Shapes.Range(Array("Picture 10")).Select
ActiveSheet.Shapes.Range(Array("Picture 11")).Select
ActiveSheet.Shapes.Range(Array("Picture 12")).Select
ActiveSheet.Shapes.Range(Array("Picture 13")).Select
ActiveSheet.Shapes.Range(Array("Picture 14")).Select
ActiveSheet.Shapes.Range(Array("Picture 15")).Select
ActiveWindow.ScrollRow = 92
ActiveSheet.Shapes.Range(Array("Picture 16")).Select
ActiveSheet.Shapes.Range(Array("Picture 17")).Select
ActiveSheet.Shapes.Range(Array("Picture 18")).Select

ActiveSheet.Shapes.Range(Array("Picture 19")).Select

Range("B1").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Select
Application.CutCopyMode = False
Selection.Copy
Application.CutCopyMode = False
ActiveCell.Select
Selection.Copy
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "MDY00406"
ActiveWorkbook.SaveAs Filename:= _
"C:\antenna macro\MDY00406-YPTT-template.xlsb", FileFormat:=xlExcel12, _
CreateBackup:=False
ActiveCell.Offset(10, -1).Range("A1").Select
End Sub
-------------------------------------------------------------------
Pls support this selected pictures i want to change from one folder with same size.

 

[Kenneth Hobson]

That is a totally different goal.

Your posted code was in the workbook. I don't know what it was supposed to do other than put MDY00406 into B1 and save the workbook. When pasting code, please do so between code tags. Type them as shown in the Tip:.

I am guessing that you want a different picture file embedded into each rectangular shape? I guess the folder is in H2. What are the file extensions: jpg, gif, png, etc.? Does it matter which file goes where? If so, how is that determined?