Klasörden Resim Çagırma

[aligunes]

Aşağıdaki kod ile klasörden resim çağırıyorum resmi boyutlandırırken üst sağ sol tamam sadece alt boyutlandırmayı sabitleyemedim yardımcı olabilecekler var mı?

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [d3]) Is Nothing Then Exit Sub

' hata kontrolü
On Error GoTo çıkış
' Resimleri Sil

ActiveSheet.DrawingObjects.Delete
' Resim yolunun bulunması

Dim ResimYolu As Variant
Dim Resim As Object

ResimYolu = ActiveWorkbook.Path & "\" & Range("d3") & ".jpg"

'Resmi oluştur
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

'Resim Boyutlandır.

With Range("d5")
Resim.Top = .Top
Resim.Left = .Left
Resim.Height = .Height
Resim.Width = .Width
End With


çıkış:
End Sub

 

[Orion1]

Aşağıdaki kod ile klasörden resim çağırıyorum resmi boyutlandırırken üst sağ sol tamam sadece alt boyutlandırmayı sabitleyemedim yardımcı olabilecekler var mı?

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [d3]) Is Nothing Then Exit Sub

' hata kontrolü
On Error GoTo çıkış
' Resimleri Sil

ActiveSheet.DrawingObjects.Delete
' Resim yolunun bulunması

Dim ResimYolu As Variant
Dim Resim As Object

ResimYolu = ActiveWorkbook.Path & "\" & Range("d3") & ".jpg"

'Resmi oluştur
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

'Resim Boyutlandır.

With Range("d5")
Resim.Top = .Top
Resim.Left = .Left
Resim.Height = .Height
Resim.Width = .Width
End With


çıkış:
End Sub

deneyiniz.

With Range("d5")
[B][COLOR="Red"]Resim.ShapeRange.LockAspectRatio = msoFalse[/COLOR][/B]
Resim.Top = .Top
Resim.Left = .Left
Resim.Height = .Height
Resim.Width = .Width
End With