¿Macro para comprimir imágenes?

Hola que tal...
Quisiera saber si me puedes apoyar.
Tengo una Macro que me inserta una imagen en Excel, pero al ejecutarla con otra que me envía un mail con dicha imagen en el cuerpo del mensaje hace que pese alrededor de 2 a 3 MB, lo que es bastante pesado para el que recibe el mail, quisiera saber si existe alguna Macro para comprimir las imágenes y así hacer que "pese" menos dicha imagen para ser enviada por Mail.
Mi macro para insertar imagen es:
Sub IMAGEN()
Dim foto As Object, Arriba As Double, Izquierda As Double, Ancho As Double, Alto As Double
Dim ruta As String
Application.ScreenUpdating = False
On Error Resume Next
Hoja10.Shapes("IMAGEN").Delete
ruta = "C:\Imagen.jpg"
Set foto = Hoja10.Pictures.Insert(ruta)
With Range("A11: H31 ")
Arriba = .Top
Izquierda = .Left
Ancho = .Offset(0, .Columns.Count).Left - .Left
Alto = .Offset(.Rows.Count, 0).Top - .Top
End With
With foto
.Name = "IMAGEN"
.Top = 200
.Left = 0
.Width = Ancho
.Height = 315
End With
Set foto = Nothing
Application.ScreenUpdating = True
End Sub
agradezco de antemano tu apoyo