Resimleri Hücreye Çekme Sorunu

[Fuat Şirin]

Merhaba Değerli hocalarım,
Bir Yerde Takıldım Alttaki kodda RESİM klasör içindeki
resimleri b sütununa yazdığım isimlerle c sutununa aynı isimdeki resimleri alıyorum fakat bunu buton yolu ile yapamadım . bir butona atayıp tıklayınca otomatik yapmasını istiyorum yardımcı olursanız sevinirim

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
    Dim Resim As OLEObject
    Dim Yeni_Resim As OLEObject
    Dim Adres As Range
    Dim Dosya_Yolu As String
    Dim Resim_Adı As String
    
    If Intersect(Target, [b:b]) Is Nothing Then Exit Sub
    'If Target.Interior.ColorIndex <> 40 Or Target = "" Or Not IsNumeric(Target) Then Exit Sub
    'If Target.Offset(0, -2) <> "MODEL:" Then Exit Sub
    
    Application.ScreenUpdating = False
    
    Dosya_Yolu = ThisWorkbook.Path & "\RESİMLER\"
    Resim_Adı = Target.Value & ".jpg"

    Set Adres = Range(Target.Offset(0, 1).Address, Target.Offset(0, 1).Address)
    
    If ActiveSheet.Shapes.Count > 0 Then
        For Each Resim In ActiveSheet.OLEObjects
            If Not Intersect(Range(Resim.TopLeftCell.Address & ":" & Resim.BottomRightCell.Address), Adres) Is Nothing Then
                Resim.Delete
            End If
        Next
    End If
    
    Set Yeni_Resim = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, _
        DisplayAsIcon:=False, Left:=Adres.Left, Top:=Adres.Top, Width:=Adres.Width, Height:=Adres.Height)
    
    With Yeni_Resim
        .Top = Adres.Top
        .Left = Adres.Left
        .Height = Adres.Height
        .Width = Adres.Width
        .Object.PictureSizeMode = fmPictureSizeModeStretch
    End With
    
    If Dir(Dosya_Yolu & Resim_Adı) <> "" Then
        Yeni_Resim.Object.Picture = LoadPicture(Dosya_Yolu & Resim_Adı)
    Else
        Yeni_Resim.Object.Picture = LoadPicture(Dosya_Yolu & "Stok_Resmi_Yok.jpg")
    End If
    
    Application.ScreenUpdating = True
End Sub

 

[bedersu]

Sayın Fuat Şirin,
Butona atamada sıkıntı yok fakat siz bu kodlarla Worksheet event kullanmışsınız.Dolayısıyla hücreyi seçince hücredeki değere göre resim atıyor.Bunu bir butona atayınca,istenilen resim ismi açılan kutuya mı yazılacak yoksa o an seçili olan hücredeki isme göre mi resim getirilecek?

 

[Fuat Şirin]

öncelikle teşekkür
şöyle söyliyim yapmak istediğim a sutununa giren modellere ait resimleri
b sütununda listelemek. a sütununa tüm modelleri giricem yan sütuna resimleri gelicek

 

[halit3]

Bu kodu denertmisiniz ?

Sub aktar()
On Error Resume Next
Dim Resim As OLEObject
Dim Yeni_Resim As OLEObject
Dim Adres As Range
Dim Dosya_Yolu As String
Dim Resim_Adı As String
 
Application.ScreenUpdating = False
Dosya_Yolu = ThisWorkbook.Path & "\RESİMLER\"
For i = 1 To Cells(Rows.Count, "a").End(3).Row
Resim_Adı = Cells(i, 1).Value & ".jpg"
Set Adres = Range(Cells(i, 2).Address, Cells(i, 2).Address)
If ActiveSheet.Shapes.Count > 0 Then
For Each Resim In ActiveSheet.OLEObjects
If Not Intersect(Range(Resim.TopLeftCell.Address & ":" & Resim.BottomRightCell.Address), Adres) Is Nothing Then
Resim.Delete
exit for
End If
Next
End If
Set Yeni_Resim = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, _
DisplayAsIcon:=False, Left:=Adres.Left, Top:=Adres.Top, Width:=Adres.Width, Height:=Adres.Height)
With Yeni_Resim
.Top = Adres.Top
.Left = Adres.Left
.Height = Adres.Height
.Width = Adres.Width
.Object.PictureSizeMode = fmPictureSizeModeStretch
End With
If Dir(Dosya_Yolu & Resim_Adı) <> "" Then
Yeni_Resim.Object.Picture = LoadPicture(Dosya_Yolu & Resim_Adı)
Else
Yeni_Resim.Object.Picture = LoadPicture(Dosya_Yolu & "Stok_Resmi_Yok.jpg")
End If
Next
Application.ScreenUpdating = True
End Sub

 

[halit3]

Buda farklı bir uygulama
kod:

Sub aktar2()
Application.ScreenUpdating = False
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "OLEObject" Then
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.Object) = "Image" Then
Picture.Delete
End If
End If
Next Picture
On Error Resume Next
Dim Obj As Object
Dim Cell As Range
For r = 1 To Cells(Rows.Count, "a").End(3).Row
Set Cell = Cells(r, "b")
Set Obj = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Image.1")
With Obj
.Left = Cell.Left
.Top = Cell.Top
.Height = Cells(r, "b").Height
.Width = Cell.Width
.Placement = xlFreeFloating
.PrintObject = True
.Object.PictureSizeMode = 3
End With
Next r
Dim uzanti(3)
uzanti(1) = "bmp": uzanti(2) = "jpg": uzanti(3) = "gif"
Klasör = ThisWorkbook.Path & "\Resimler\"
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "OLEObject" Then
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.Object) = "Image" Then
isim = Cells(Picture.BottomRightCell.Row - 1, 1)
For i = 1 To 3
resimyükle = Klasör & isim & "." & uzanti(Val(i))
Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
a = ds.FileExists(resimyükle)
If a = True Then
ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.Object.Picture = LoadPicture(resimyükle)
Exit For
Else
End If
Next i
End If
End If
Next Picture
Range("A1").Select
Application.ScreenUpdating = True
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub