Comprimir imagen con Macro

Hola,  tengo esta macro con la que inserto una foto pero cuando quiero comprimir para que al grabar el archivo pese menos, no lo hace, y termina la operación....
desde la instrucción marcada no funciona, agradecere contarme en que fallo, ¿puede ser el nombre del archivo?
Sub InFotos()On Error GoTo x
    Dim strFoto1$      
    strFoto1$ = _    Application.GetOpenFilename("Fotografias (*.jpg), *.jpg")        ActiveCell.Select   
ActiveSheet.Pictures.Insert(strFoto1$).Select   
Selection.ShapeRange.LockAspectRatio = msoFalse   
Selection.ShapeRange.Height = 155#   
Selection.ShapeRange.Width = 250.75   
Selection.ShapeRange.Rotation = 0#   
ActiveSheet.Shapes(strFoto1$).Select   
Selection.ShapeRange.PictureFormat.Brightness = 0.5    Selection.ShapeRange.PictureFormat.Contrast = 0.5    Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic    Selection.ShapeRange.PictureFormat.CropLeft = 0#    Selection.ShapeRange.PictureFormat.CropRight = 0#    Selection.ShapeRange.PictureFormat.CropTop = 0#    Selection.ShapeRange.PictureFormat.CropBottom = 0#      
Exit Sub
x:
MsgBox "Operacion Terminada"    
End Sub