ActiveSheet.Shapes.AddPicture - How to improve quality of images?

[Rodolfo SN]

Hi, guys.
I am using "ActiveSheet.Shapes.AddPicture" to import images into my worksheet, however the pictures decrease quality every time I did that.
Is there any way to set a better resolution or something that help this point?

Sub Insere()
BoolImage = True
Dim Imagem As Object
Dim ImgFileFormat As String
ImgFileFormat = "Image Files JPG (*.jpg),*.jpg, Image Files NEF (*.nef),*.nef, Image Files JPEG (*.jpeg),*.jpeg, Image Files GIF (*.gif),*.gif, Image Files BMP (*.bmp),*.bmp"
Pict = Application.GetOpenFilename(ImgFileFormat)
If Pict = False Then
'End
BoolImage = False
Else


Set Imagem = ActiveSheet.Shapes.AddPicture(Pict, False, True, 1, 1, -1, -1)
Imagem.Top = ActiveCell.Top
Imagem.Left = ActiveCell.Left

Imagem.Placement = xlMoveAndSize


Dim escala
Dim deslocamento
If Imagem.Height > 187 Then
escala = 187 / Imagem.Height
Imagem.Height = Imagem.Height * escala
'Imagem.Width = Imagem.Width * escala
Imagem.Select
deslocamento = (((385 - Imagem.Width) / 2))
Selection.ShapeRange.IncrementLeft deslocamento
deslocamento = (((187 - Imagem.Height) / 2)) ' O valor de 191 encontrado através da multiplicação da altura das células
Selection.ShapeRange.IncrementTop deslocamento
ElseIf Imagem.Width > 383 Then
escala = 370 / Imagem.Width
'Imagem.Height = Imagem.Height * escala
Imagem.Width = Imagem.Width * escala
Imagem.Select
deslocamento = (((191 - Imagem.Height) / 2))
Selection.ShapeRange.IncrementTop deslocamento
deslocamento = (((375 - Imagem.Width) / 2)) ' Valor de 385 encontrado experimentalmente / Excel tem unidades diferentes para Height e e Widht
Selection.ShapeRange.IncrementLeft deslocamento

End If
End If


End Sub