External Resim Çağırma Resim Boyutu

[cevatyildiz]

Merhaba

Aşağıda bütünleşik bir kodum var. Dışarıdan resim çağırmak istediğimde resimin boyutunu sınırlamadan gösterilmesini istiyorum. Picturesizemode focus gibi birşeydi diye hatırlıyorum ama o da formda çalışıyordu galiba... Yardımcı olabilir misiniz?

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Son As Long
Dim cmt, Kontrol, sPath, sFile
    
'Call ResetComments
Columns("D").ClearComments

Son = [b1000].End(4).Row

If Intersect(Target, Range("A3:H" & Son)) Is Nothing Then Exit Sub

If Target.Count > 1 Then Exit Sub

Application.ScreenUpdating = False
Range("A3:J" & Son).Interior.ColorIndex = xlNone
Range("A3:J" & Son).Font.Bold = False
Range("L3:L" & Son).Interior.ColorIndex = xlNone
Range("L3:L" & Son).Font.Bold = False
Range("N3:R" & Son).Interior.ColorIndex = xlNone
Range("N3:R" & Son).Font.Bold = False
Range("T3:W" & Son).Interior.ColorIndex = xlNone
Range("T3:W" & Son).Font.Bold = False
Range("Y3:AA" & Son).Interior.ColorIndex = xlNone
Range("Y3:AA" & Son).Font.Bold = False
Range("AC3:AE" & Son).Interior.ColorIndex = xlNone
Range("AC3:AE" & Son).Font.Bold = False

Range("A" & Target.Row & ":J" & Target.Row).Interior.ColorIndex = 36
Range("A" & Target.Row & ":J" & Target.Row).Font.Bold = True
Range("L" & Target.Row & ":L" & Target.Row).Interior.ColorIndex = 36
Range("L" & Target.Row & ":L" & Target.Row).Font.Bold = True
Range("N" & Target.Row & ":R" & Target.Row).Interior.ColorIndex = 36
Range("N" & Target.Row & ":R" & Target.Row).Font.Bold = True
Range("T" & Target.Row & ":W" & Target.Row).Interior.ColorIndex = 36
Range("T" & Target.Row & ":W" & Target.Row).Font.Bold = True
Range("Y" & Target.Row & ":AA" & Target.Row).Interior.ColorIndex = 36
Range("Y" & Target.Row & ":AA" & Target.Row).Font.Bold = True
Range("AC" & Target.Row & ":AE" & Target.Row).Interior.ColorIndex = 36
Range("AC" & Target.Row & ":AE" & Target.Row).Font.Bold = True
'Application.ScreenUpdating = True

'**************************************************************************************
On Error Resume Next

If Target.Column = 4 Then


    sFile = Cells(Target.Row, "D") & ".jpg"
    sPath = ThisWorkbook.Path & "\Pictures\" & sFile

    Kontrol = Dir(sPath): If Kontrol = "" Then Exit Sub

    Set cmt = Cells(Target.Row, "D").AddComment
    cmt.Visible = True
    cmt.Text Text:=sFile
    With cmt.Shape
        .Fill.UserPicture sPath
        .Width = 300
        .Height = 300
    End With

    Set cmt = Nothing

End If

End Sub