Soru Excel Resim Çağırma

[ERBİL35]

Merhabalar Exteki Excele Resim klasöründen C15 hücresine Ad Soyad yazarak (ActiveX dDenetimi) Resim getirebilirmiyiz

 

[byfika]

Aşağıdaki kodu SAYFA1 in kod bölümüne kaydedin. Sayfa1 C15 'e isim girdiğinizde resim gelecektir. Resimler resimlerin olduğu dosyada olacak.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [c15]) Is Nothing Then Exit Sub
On Error GoTo çıkış
ActiveSheet.DrawingObjects.Delete
Dim ResimYolu As Variant
Dim Resim As Object
ResimYolu = "C:\Users\PC\Desktop\çalışma\Resimler\" & Range("c15") & ".jpg"
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)
With Range("C5")
Resim.Top = .Top
Resim.Left = .Left
Resim.Height = 150
Resim.Width = 100
End With
çıkış:
End Sub

 

[1Al2Ver]

Merhaba sayın byfika,

Kod, sayfada, diğer obje ve resimleri silmeden, sadece "C5" hücresindeki resmi silsin isteniyor ise, ne yapılmalıdır ?

Teşekkür ederim.

 

[ERBİL35]

maalesef her ıkısıde olmuyor siz kodlayıp deneye bilirmisiniz birde Resim Yolu E\ olacak şekilde düzenleyebilirmisiniz

 

[byfika]

Neden olmadığını anlayamadım. Siz nasıl yapmak istiyorsunuz. İlk mesajınızda resimler dosyasının E de olacağı yazılı olmadığından, resim yolu masa üstüne göre ayarlı. Sadece Resimler yolu değiştirildiğinde çalışır.
Resimler klasörünü E ye koyun ve
ResimYolu = "C:\Users\PC\Desktop\çalışma\Resimler\" & Range("c15") & ".jpg" olan resim yolunu alttaki gibi değiştirin.

ResimYolu = "e:\Resimler\" & Range("c15") & ".jpg"

Ayrıca örnek dosya ekte....

 

[ERBİL35]

Neden olmadığını anlayamadım. Siz nasıl yapmak istiyorsunuz. İlk mesajınızda resimler dosyasının E de olacağı yazılı olmadığından, resim yolu masa üstüne göre ayarlı. Sadece Resimler yolu değiştirildiğinde çalışır.
Resimler klasörünü E ye koyun ve
ResimYolu = "C:\Users\PC\Desktop\çalışma\Resimler\" & Range("c15") & ".jpg" olan resim yolunu alttaki gibi değiştirin.

ResimYolu = "e:\Resimler\" & Range("c15") & ".jpg"

Ayrıca örnek dosya ekte....

Şimdi oldu Teşekkürler bir ricam daha olacak EKTEKİ ÖRNEĞE GÖRE aynı sayfada birden farklı resim çağırma farklı ad soyadı kullanarak yan yana misal örnek birine C15 hücresinde yazınca gelecek diğerinde G15 hücresine yazınca RESİM getirebilirmiyiz.

 

[usubaykan]

https://www.excel.web.tr/threads/diger-sayfalardaki-listeden-resimli-ve-sayisal-veri-cekmek.187953/#post-1043220
linki inceleyin benzer bir çalışma.

 

[1Al2Ver]

Merhaba,

Kod, sayfada, diğer obje ve resimleri silmeden,

Sadece "C5" hücresindeki resmi silsin istiyorum ,

Ne yapılmalıdır ?

Teşekkür ederim.

 

[usubaykan]

https://www.excel.web.tr/threads/diger-sayfalardaki-listeden-resimli-ve-sayisal-veri-cekmek.187953/#post-1043220
linki inceleyin benzer bir çalışma.

 

[1Al2Ver]

Merhaba sayın usubaykan,

İlginiz ve link için teşekkür ederim,

Kullandığım kod aşağıdadır, tüm resimleri silmesi dışında sorunumu çözüyor,

Bu kod'da yapılacak değişiklik ile sadece ilgili hücredeki (F2) resim silinsin istiyorum,

Tekrar teşekkür ederim.

Private Sub Worksheet_Change(ByVal Target As Range)

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

On Error GoTo çıkış

ActiveSheet.DrawingObjects.Delete

Dim ResimYolu As Variant

Dim Resim As Object

ResimYolu = ActiveWorkbook.Path & "\" & Range("B2") & ".png"

Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

With Range("F2")
Resim.Top = .Top
Resim.Left = .Left
Resim.Height = 400 '.Height 100
Resim.Width = 640 '.Width 575
End With
çıkış:
End Sub

 

[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
   
    If Intersect(Target, [B12]) Is Nothing Then Exit Sub ' hedef B12 hücresi değilse çık

    Application.ScreenUpdating = False
   
    Yol = ThisWorkbook.Path & "\" ' Excel dosyasının bulunduğu klasör
    Resim_Adı = [B12] & ".jpg" ' bulunduğu klasör içerisinde ki Resim adı

    Set Resim_Adres = [F2] 'İlgili resmin kopyalanacağı hücre
   
    If ActiveSheet.Shapes.Count > 0 Then
       
       
    If Target = "" Then ' (B12 hücresi boş ise)
        For Each Resim In ActiveSheet.OLEObjects 'Resimler için döngü
            If Not Intersect(Range("F2:F2"), Resim_Adres) Is Nothing Then 'eğer resim adresi ilgili adres ise
                Resim.Delete ' hücredeki resmi sil
            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 = 400
        .Width = 640
        .Object.PictureSizeMode = fmPictureSizeModeStretch
    End With
   
    If Dir(Yol & Resim_Adı) <> "" Then
        Yeni_Resim.Object.Picture = LoadPicture(Yol & Resim_Adı)
    End If
   
    Application.ScreenUpdating = True
End Sub

Alternatif olsun bu şekilde deneyin.

 

[1Al2Ver]

Sayın usubaykan merhaba,

Emek ve ilginiz için çok teşekkür ederim,

Kod, .jpg formatında sorunsuz çalışıyor,

Benim resim formatlarım .png'dir, kodu bu haliyle çalıştıramadım,

Bu sorunu aşabilirsem, bu kodu kullana bilirim,

Tekrar teşekkür ederim.

 

[usubaykan]

Option Explicit
Public Resim As Object, u As Variant
Public Resimyolu As String

Private Sub Worksheet_Change(ByVal Target As Range)
    If [B12] <> "" Then
        If Intersect(Target, [B12]) Is Nothing Then Exit Sub
            [F2].Select
                Resimyolu = ActiveWorkbook.Path & "\" & [B12] & ".png"
                Set Resim = ActiveSheet.Pictures.Insert(Resimyolu)
                
                With Resim
                .Top = .Top
                .Left = .Left
                .Height = 400
                .Width = 600
                End With
                [B12].Select
                
    Else
                If [B12] = "" Then
                    Resim.Name = u
                    ActiveSheet.Shapes.Range(Array("" & Resim.Name & "")).Delete
                End If
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    u = [B12]
End Sub

 

[1Al2Ver]

Sayın usubaykan tekrar merhaba,

Yeni kod sorunsuz çalışıyor, ancak B2'den her seçimde F2'ye resimler üst üste biniyor,

Kodu tekrar kontrol ederseniz sevinirim.

Teşekkür ederim.

 

[usubaykan]

siz bence bir örnek dosya ekleyin.

 

[1Al2Ver]

Sayın usubaykan merhaba,

İlginiz için teşekkür ederim.

 

[metin_0606]

Sayın usubaykan merhaba,

İlginiz için teşekkür ederim.

Deneyiniz

 

[1Al2Ver]

Sayın metin_0606 merhaba,

İlginiz için teşekkür ederim,

Ekli dosya, sanırım yanlış dosya, yanılmıyorsam benim gönderdiğim kodları içeriyor,

Kontrol ederseniz memnun olurum.

 

[metin_0606]

Sayın metin_0606 merhaba,

İlginiz için teşekkür ederim,

Ekli dosya, sanırım yanlış dosya, yanılmıyorsam benim gönderdiğim kodları içeriyor,

Kontrol ederseniz memnun olurum.

Gönderdiğiniz dosyada resimler üst üste biniyor demişsiniz sanırım sorun buydu yanlış anlamadıysam

 

[1Al2Ver]

Gönderdiğiniz dosyada resimler üst üste biniyor demişsiniz sanırım sorun buydu yanlış anlamadıysam

Merhaba,

Hayır yanlış anlamadınız, bunun çözülmesini istemiştim,

Kısaca, B2'den seçim yapıldığında, her seçim sonrası F2'ye, seçilen isme ait resim gelmeli, buraya kadar tamam,

Ancak her seçimde, F2'deki resim silinip yerine yenisi gelmeli,

Şu haliyle her seçim sonrası resimler üst üste biniyor,

Bunu aşmaya çalışıyorum,

Teşekkür ederim.