İstenen Bir Hücreye Klasörden Resim Getirmek

ayaz

Altın Üye
Katılım
7 Haziran 2021
Mesajlar
4
Excel Vers. ve Dili
2010 türkçe
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

Destek Ekibi
Destek Ekibi
Katılım
16 Mayıs 2008
Mesajlar
561
Excel Vers. ve Dili
Ev : Office Excel 2003
İş : Office Excel 2003
Kod:
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

Altın Üye
Katılım
7 Haziran 2021
Mesajlar
4
Excel Vers. ve Dili
2010 türkçe
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

Destek Ekibi
Destek Ekibi
Katılım
16 Mayıs 2008
Mesajlar
561
Excel Vers. ve Dili
Ev : Office Excel 2003
İş : Office Excel 2003
Klasör içerisinde ekteki resim gibi kullanırsanız Resim eklenmemiş resmi gelecektir. Kodu tekrar deneyin.

Kod:
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
 

Ekli dosyalar

  • 3.4 KB Görüntüleme: 9

ayaz

Altın Üye
Katılım
7 Haziran 2021
Mesajlar
4
Excel Vers. ve Dili
2010 türkçe
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

Destek Ekibi
Destek Ekibi
Katılım
16 Mayıs 2008
Mesajlar
561
Excel Vers. ve Dili
Ev : Office Excel 2003
İş : Office Excel 2003
Kod:
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.
 

yasarcan

Altın Üye
Katılım
30 Nisan 2016
Mesajlar
100
Excel Vers. ve Dili
2007
Tek hücreye değilde birleştirilmiş hücreye resmi almak için kodu nasıl düzenlemem gerekiyor?
 

usubaykan

Destek Ekibi
Destek Ekibi
Katılım
16 Mayıs 2008
Mesajlar
561
Excel Vers. ve Dili
Ev : Office Excel 2003
İş : Office Excel 2003
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

Altın Üye
Katılım
30 Nisan 2016
Mesajlar
100
Excel Vers. ve Dili
2007
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.
 
Üst