Replace picture size and location

[noelmus]

The code below works fine but I can't modify it so that the new picture will have this location and size:
.Top = Rows(1).Top
.Left = Columns(1).Left
.Height = 2.69cm
.Width = 3.59cm

Any help is appreciated.

Sub change_picture()
    ' Change as needed, keep the \ at the end
    Const strFolder = "C:\Users\mars\Desktop\Dog\"
    Const strPic = "Picture 5"
    Const strPicFile = "C:\Users\mars\Desktop\cat.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("C2", "C4", "C6"))
            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

 

[C Moore]

What happens if you delete below at the beginning?

Dim t As Single, l As Single, h As Single, w As Single

 

[C Moore]

Also you have to convert your cm I think.

 

[noelmus]

I remove the line

Dim t As Single, l As Single, h As Single, w As Single

and the new picture took the size and location of the old picture.
Convert cm to what?
Thanks in advance

 

[C Moore]

I haven't checked or used this, popped up when I googled.
.Height = Application.CentimetersToPoints(2.69)
.Width = Application.CentimetersToPoints(3.59)

 

[noelmus]

Mr Moore, I managed to do it by the help of a friend:

Sub change_picture()
    ' Change as needed, keep the \ at the end
    Const strFolder = "C:\Users\mars\Desktop\Dog\"
    Const strPic = "Picture 5"
    Const strPicFile = "C:\Users\mars\Desktop\cat.jpg"
    Dim strFile As String
    Dim wbk As Workbook
    Dim wsh As Worksheet
    Dim f As Boolean
    Dim shp As Shape
  
    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("C2", "C4", "C6"))
            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
            With wsh.Pictures.Insert(strPicFile).ShapeRange 'Insert picture
             .LockAspectRatio = msoTrue
             .Width = 40
             .Left = wsh.Columns(1).Left
             .Top = wsh.Rows(1).Top
             .Name = strPic
        End With
            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

Thanks for trying to help me.