İstenen Bir Hücreye Klasörden Resim Getirmek

[ayaz]

Merhaba,
Excel dosyasının bulunduğu Aktif klasör içerisinde “Resimlerim” klasörü olduğunu varsayalım. Resimlerim klasörü içerisinde bulunan resimlerden (jpg) ismini yazdığım resmi istediğim herhangi bir excel hücresine mevcut hücre genişliğine uyacak şekilde getirmek istiyorum.
Bu işlemi yapabilecek bir fonksiyona ihtiyacım var.
Örneğin: “Resimlerim” Klasöründe “0001.jpg, 0002.jpg, 0003.jpg, 0004.jpg …. vb. (en az 5000 adet)” isimlere sahip resim dosyaları var. Sizin yardımınızla Yeni oluşacak fonksiyonun isminin de “ResimEkle” olduğunu varsayalım.
Excel dosyasında Herhangi bir hücreye “=ResimEkle(0001)” yazıp Enter tuşuna bastığımda mevcut hücrede “0001.jpg isimli resmin hücre genişliğine uyacak şekilde görünmesini istiyorum.
Umarım böyle bir modül yazmak mümkündür. Bana yardımcı olursanız sevinirim. Şimdiden teşekkür ederim.

 

[usubaykan]

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Resim As OLEObject, Yeni_Resim As OLEObject, Resim_Adres As Range, Yol As String, Resim_Adı As String
   
    Application.ScreenUpdating = False
   
    Yol = ThisWorkbook.Path & "\RESİM\"
    Resim_Adı = Target.Value & ".jpg"

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

Sayfanın "Private Sub Worksheet_Change" bölümüne yazılmıştır. Kod yazdığınız hücre üzerine resim getirir. Kullanıcı tanımlı fonksiyon değildir. Belki bir alternatif olur.

 

[ayaz]

Sayın usubaykan, ilginize teşekkür ederim. Olmayan bir dosya ismi yazıldığında hata veriyor. hata mesajı yerine olmayan dosya ismi girildiğinde "dosya bulunamadı" şeklinde mesaj vermesi ve ilgili hücreye "resimyok" isimli resmi getirmesi mümkün olur mu? teşekkürler.

 

[usubaykan]

Klasör içerisinde ekteki resim gibi kullanırsanız Resim eklenmemiş resmi gelecektir. Kodu tekrar deneyin.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Resim As OLEObject, Yeni_Resim As OLEObject, Resim_Adres As Range, Yol As String, Resim_Adı As String
   
    Application.ScreenUpdating = False
   
    If Target = "Resim yok" Then Exit Sub
    
    Yol = ThisWorkbook.Path & "\RESİM\"
    Resim_Adı = Target.Value & ".jpg"

    Set Resim_Adres = Cells(Target.Row, Target.Column)
    If ActiveSheet.Shapes.Count > 0 Then
       
    If Target = "" Then
        For Each Resim In ActiveSheet.OLEObjects
            If Not Intersect(Range(Resim.TopLeftCell.Address & ":" & Resim.TopLeftCell.Address), Resim_Adres) Is Nothing Then
                Resim.Delete
            End If
        Next
    Exit Sub
    End If
    End If
   
    Set Yeni_Resim = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, _
        DisplayAsIcon:=False, Left:=Resim_Adres.Left, Top:=Resim_Adres.Top, Width:=Resim_Adres.Width, Height:=Resim_Adres.Height)
   
    With Yeni_Resim
        .Top = Resim_Adres.Top
        .Left = Resim_Adres.Left
        .Height = Resim_Adres.Height
        .Width = Resim_Adres.Width
        .Object.PictureSizeMode = fmPictureSizeModeStretch
    End With
   
    If Dir(Yol & Resim_Adı) <> "" Then
        Yeni_Resim.Object.Picture = LoadPicture(Yol & Resim_Adı)
    Else
        Yeni_Resim.Object.Picture = LoadPicture(Yol & "X.jpg") ' hücre üzerinde "Resim eklenmemiş" resmi koyar
        Target = "Resim yok" 'Hücre içerisine yazar
        Exit Sub
    End If
   
    Application.ScreenUpdating = True
End Sub

 

[balanar]

Merhaba, çalışır halde örnek bir dosya yüklemeniz mümkün müdür? @usubaykan

 

[usubaykan]

Tabiki de.

 

[ayaz]

merhaba, aynı hücreye yeni bir resim eklendiğinde önceki resim otomatik olarak silinmiyor yeni resim diğerinin üzerine ekleniyor. bu da dosya boyutunu arttırıyor. Bu sorunu düzeltmeniz mümkün müdür? @usubaykan

 

[usubaykan]

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Resim As OLEObject, Yeni_Resim As OLEObject, Resim_Adres As Range, Yol As String, Resim_Adı As String
   
    Application.ScreenUpdating = False
   
    If Target = "Resim yok" Then Exit Sub
    
    Yol = ThisWorkbook.Path & "\RESİM\"
    Resim_Adı = Target.Value & ".jpg"
    Set Resim_Adres = Cells(Target.Row, Target.Column)
    If ActiveSheet.Shapes.Count > 0 Then
       
    If Target = "" Then
        For Each Resim In ActiveSheet.OLEObjects
            If Not Intersect(Range(Resim.TopLeftCell.Address & ":" & Resim.TopLeftCell.Address), Resim_Adres) Is Nothing Then
                Resim.Delete
            End If
        Next
    Exit Sub
    End If
    End If
   
   If Target <> "" Then
        For Each Resim In ActiveSheet.OLEObjects
            If Not Intersect(Range(Resim.TopLeftCell.Address & ":" & Resim.TopLeftCell.Address), Resim_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:=Resim_Adres.Left, Top:=Resim_Adres.Top, Width:=Resim_Adres.Width, Height:=Resim_Adres.Height)
   
    With Yeni_Resim
        .Top = Resim_Adres.Top
        .Left = Resim_Adres.Left
        .Height = Resim_Adres.Height
        .Width = Resim_Adres.Width
        .Object.PictureSizeMode = fmPictureSizeModeStretch
    End With
   
    If Dir(Yol & Resim_Adı) <> "" Then
        Yeni_Resim.Object.Picture = LoadPicture(Yol & Resim_Adı)
    Else
        Yeni_Resim.Object.Picture = LoadPicture(Yol & "X.jpg")
        Target = "Resim yok"
        Exit Sub
    End If
   
    Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Target = Target.Value
End Sub

bu şekilde deneyin.

 

[ayaz]

Teşekkürler @usubaykan

 

[yasarcan]

Tek hücreye değilde birleştirilmiş hücreye resmi almak için kodu nasıl düzenlemem gerekiyor?

 

[usubaykan]

Seçili alan mı olacak yoksa belirlediğiniz alan mı yoksa daha önceden birleştirilmiş ve siz o alana mı resim alacaksınız?
Örnek bir dosyanız var mı?

 

[yasarcan]

Paylaşılan örnekte denedim. belirli bir alanı birleştirdim. formül çalışmadı. formülde çalışayım dedim yapamadım. öğrenmek için soruyorum.

 

[spacebar]

merhabalar. seçim yaparak resim getirmek isterseniz ekteki dosya işinize yarayabilir.