dosyadan resim çağırma

[dayibasi]

üstadlar merhaba

bir senaryo ile açıklamak isterim.

c içerisinde "resimler" dosyası var. bu dosya içerisinde numaralı resimler var.

excel sayfasında a1 hücresine 11 yazdığımda, eğer 11 numaralı resim varsa, b4 hücresinde çıkıyor, yoksa "resim yok" uyarısı alıyorum.

elimdeki diğer 22 numaralı resim için de aynı işlemler yapılabiliyor.

hazır bulduğum kod aşağıdaki gibidir.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim res As String
Dim a As Shape
Dim B4 As Range
If Target = "" Or Target.Address <> "$A$1" Then Exit Sub
If Target.Count > 1 Then Exit Sub
Set B4 = Range("B4")
For Each a In Shapes
a.Delete
Next a
B4.ClearContents
res = "C:\Resimler\" & Target & ".jpg"
If Dir(res) = "" Then
B4 = "RESİM YOK"
Else
With ActiveSheet.Pictures.Insert(res)
.Left = B4.Left
.Top = B4.Top
.Height = B4.Height
.Width = B4.Width
End With
End If
End Sub

gayet güzel çalışıyor.

ancak bazı düzenlemeler istiyorum, kodları defalarca bozdum ama anlamadım.

bu resimler b4 genişliğine sığıp aynı boy oranında aşağıya uzayan biçimde değil de, b4 b5 b6 genişliğine sığmasını istiyorum.

bu kodu düzenlememe yardım eder misiniz?

şimdiden teşekkürler.

not: onlarca dosya indirdim, denedim. mevcut kod işime en yakın olanı. el ile düzenleme yapabilirim ama bir düzenleme beni bu dertten de kurtarabilir.

 

[muygun]

Merhaba;
Sayfanın kod bölümüne;

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
On Error Resume Next
Dim resim As Picture, Alan As Range
Set Alan = Range("b4:b6")
For Each resim In ActiveSheet.Pictures
If Not Intersect(resim.TopLeftCell, Alan) Is Nothing Then
resim.Delete
End If
Next
B4 = "RESİM YOK"
Set Alan = Nothing
Range("B4").Select
resimadi = LoadPicture("")
resimadi = Range("a1").Text & ".jpg"
ActiveSheet.Pictures.Insert("C:\Resimler\" & resimadi).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 40 'yükseklik
Selection.ShapeRange.Width = 48 'genişlik
Selection.ShapeRange.Rotation = 0#
Range("A1").Select
Application.ScreenUpdating = True
End Sub

Kodlarını yerleştirerek ve kodlardaki ;
yükseklik için;
Selection.ShapeRange.Height = 40 'yükseklik (40 sayısını değiştirerek)
genişlik için;
Selection.ShapeRange.Width = 48 'genişlik (48 sayısını değiştirerek)
istediğiniz boyutu oluşturun.

İyi çalışmalar.