Image quality

[eliozo]

I wrote a code where i can browse a picture and put it in a selected cell in a small size. When clicking on the photo, it will get bigger. The problem is when it gets bigger it looses its quality and not well shown. How can i keep the same quality of the image ?Thank you for your help

Sub InsertPicture()
    Dim cel As Range, Pic As Object
    With Application.InputBox("Select Cell from Column B to place a Photo and click OK", "Browse Picture", , , , , , 8)
        Set Pic = ActiveSheet.Shapes.AddPicture(FileName:=GetImage, _
            linktofile:=msoFalse, savewithdocument:=msoCTrue, Left:=0, Top:=0, Width:=-1, Height:=-1)
             Pic.Top = .Top: Pic.Left = .Left: Pic.Height = .Height
    End With
    With Pic
        .Name = "P" & Format(Now, "yymmddhhmmss")
        .OnAction = "'" & ActiveWorkbook.Name & "'!Resize"
        .ZOrder msoSendToBack
 
    End With
End Sub
 
Private Function GetImage() As String
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .ButtonName = "Submit"
        .Title = "Select an image file"
        .Filters.Add "Image", "*.gif; *.jpg; *.jpeg", 1
        If .Show = -1 Then GetImage = .SelectedItems(1) Else End
    End With
End Function
 
Sub Resize()
    Dim shp As Shape: Set shp = ActiveSheet.Shapes(Application.Caller)
    With shp.TopLeftCell
        .Activate
        If shp.Height > .Height Then shp.Height = .Height Else shp.Height = .Height * 7
    End With
End Sub

 

[Yongle]

Example illustrating use of ScaleWidth and ScaleHeight properties
Assign macro below to an image, then click on image to test

Sub ClickOnPic()
    Dim size As Double, cel As Range
 
    Select Case MsgBox(vbTab & "Yes(BIGGER)" & "    " & "No(SMALLER)", vbYesNo, "")
        Case vbYes:     size = 2
        Case vbNo:      size = 0.5
    End Select
 
    ActiveSheet.Shapes(Application.Caller).Select
    With Selection
        Set cel = .TopLeftCell
        .ShapeRange.ScaleWidth size, msoFalse, msoScaleFromTopLeft
        .ShapeRange.ScaleHeight size, msoFalse, msoScaleFromBottomRight
        .Left = cel.Left
        .Top = cel.Top
        cel.Activate
    End With
End Sub

What you need to do:
Amend your code to insert larger image and use ScaleWidth and ScaleHeight properties to make it smaller without affecting quality
.
.
.