Resim Çağırma Kodunda Değişiklik

Katılım
29 Haziran 2018
Mesajlar
297
Excel Vers. ve Dili
2016 TÜRKÇE
Arkadaşlar Merhaba, Aşağıdaki kod yardımıyla jpg uzantılı resimleri çağırabiliyorum. Benim istediğim bu kodu diğer resim uzantılarını da desteklemesi. Bunun için nasıl bir değişiklik yapılmalıdır. (Özellikle png uzantılar) Saygılar.

C++:
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, [B:B]) Is Nothing Then Exit Sub
    If Target = "" Then Exit Sub

    Application.ScreenUpdating = False
   
    Yol = ThisWorkbook.Path & "\STOKLAR\"
    Resim_Adı = Target.Value & ".jpg"

    Set Resim_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.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")
    End If
   
    Application.ScreenUpdating = True
End Sub
 
Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Altın Üyelik Bitiş Tarihi
19-10-2021
Arkadaşlar Merhaba, Aşağıdaki kod yardımıyla jpg uzantılı resimleri çağırabiliyorum. Benim istediğim bu kodu diğer resim uzantılarını da desteklemesi. Bunun için nasıl bir değişiklik yapılmalıdır. (Özellikle png uzantılar) Saygılar.

C++:
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, [B:B]) Is Nothing Then Exit Sub
    If Target = "" Then Exit Sub

    Application.ScreenUpdating = False
  
    Yol = ThisWorkbook.Path & "\STOKLAR\"
    Resim_Adı = Target.Value & ".jpg"

    Set Resim_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.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")
    End If
  
    Application.ScreenUpdating = True
End Sub
Örnek dosya paylaşırmısınız
 

Emir Hüseyin Çoban

Destek Ekibi
Destek Ekibi
Katılım
11 Ağustos 2008
Mesajlar
5,892
Excel Vers. ve Dili
Office 2013 Tr - Win10 x64
.

Dipnot: Çalışmanızda KAT("Forms.Image.1";"") nesnesi kullanılıyor. Bu nesne PNG uzantılı dosyaları desteklemez.

.
 

Emir Hüseyin Çoban

Destek Ekibi
Destek Ekibi
Katılım
11 Ağustos 2008
Mesajlar
5,892
Excel Vers. ve Dili
Office 2013 Tr - Win10 x64
.

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
  
    If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
    If Target = "" Then Exit Sub

    Application.ScreenUpdating = False
  
    Yol = ThisWorkbook.Path & "\STOKLAR\"
    Resim_Adı = Target.Value '& ".jpg"

    Set Resim_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.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ı & ".jpg") <> "" Then Yeni_Resim.Object.Picture = LoadPicture(Yol & Resim_Adı & ".jpg"): GoTo atla
If Dir(Yol & Resim_Adı & ".gif") <> "" Then Yeni_Resim.Object.Picture = LoadPicture(Yol & Resim_Adı & ".gif"): GoTo atla
If Dir(Yol & Resim_Adı & ".dib") <> "" Then Yeni_Resim.Object.Picture = LoadPicture(Yol & Resim_Adı & ".dib"): GoTo atla
If Dir(Yol & Resim_Adı & ".bmp") <> "" Then Yeni_Resim.Object.Picture = LoadPicture(Yol & Resim_Adı & ".bmp"): GoTo atla
If Dir(Yol & Resim_Adı & ".wmf") <> "" Then Yeni_Resim.Object.Picture = LoadPicture(Yol & Resim_Adı & ".wmf"): GoTo atla
If Dir(Yol & Resim_Adı & ".emf") <> "" Then Yeni_Resim.Object.Picture = LoadPicture(Yol & Resim_Adı & ".emf"): GoTo atla
If Dir(Yol & Resim_Adı & ".ico") <> "" Then Yeni_Resim.Object.Picture = LoadPicture(Yol & Resim_Adı & ".ico"): GoTo atla
If Dir(Yol & Resim_Adı & ".cur") <> "" Then Yeni_Resim.Object.Picture = LoadPicture(Yol & Resim_Adı & ".cur"): GoTo atla
Yeni_Resim.Object.Picture = LoadPicture(Yol & "X.jpg")
atla:


    Application.ScreenUpdating = True
End Sub
.
 

byfika

Altın Üye
Altın Üye
Katılım
15 Ağustos 2009
Mesajlar
499
Excel Vers. ve Dili
Excel Vers. ve Dili : Ofis 2016 Tr
Altın Üyelik Bitiş Tarihi
13.09.2027
Merhabalar,
Bir modul içerisine alttaki kodu yazın ve butona atayın. Resim yolunu kendi bilgisayar ismine göre ayarlayın. Yükleyeceğiniz resimler .png uzantılı olmalı.
Değişmesi gereken bölüm koyu : " C:\Users\PC\Desktop\RESİM ÇALIŞMASI\ "

KOD:

Sub Resim_yükle()
Dim objPic As Picture, i As Long
Dim sPath As String, sFile As String

sPath = "C:\Users\PC\Desktop\RESİM ÇALIŞMASI\"

If Dir(sPath, vbDirectory) = "" Then
MsgBox "This directory does not exist"
Exit Sub
End If

On Error Resume Next
For Each objPic In ActiveSheet.Pictures
If objPic.Name Like "img_*" Then
objPic.Delete
End If
Next
On Error GoTo 0
Application.ScreenUpdating = False
For i = 4 To Range("B" & Rows.Count).End(3).Row
sFile = Range("B" & i).Value & ".png"
If Dir(sPath & sFile) <> "" Then
Dosya = sPath & sFile
Cells(i, "A").Select
Set Adres = Range(ActiveWindow.RangeSelection.Address)
ActiveSheet.Shapes.AddPicture(Filename:=Dosya, linktofile:=msoFalse, _
savewithdocument:=msoCTrue, Left:=0, Top:=0, Width:=-1, Height:=-1).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Top = Adres.Top
Selection.Left = Adres.Left
Selection.ShapeRange.Height = Adres.Height
Selection.ShapeRange.Width = Adres.Width
End If
Next
Application.ScreenUpdating = True
MsgBox "Png Resim Yüklendi"
End Sub
 
Katılım
29 Haziran 2018
Mesajlar
297
Excel Vers. ve Dili
2016 TÜRKÇE
Emin Bey,

yardımlarınız için teşekkür ederim, PNG uzantılı görseller hariç çalışıyor, PNG içinde çalışması için ne yapabiliriz?
 
Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Altın Üyelik Bitiş Tarihi
19-10-2021
Emin Bey,

yardımlarınız için teşekkür ederim, PNG uzantılı görseller hariç çalışıyor, PNG içinde çalışması için ne yapabiliriz?
Modül destekli Png uzantılı resimleri getiriyor. Resimlerin bulunduğu dosya yolunu kendinize göre uyarlayınız
 

Ekli dosyalar

Emir Hüseyin Çoban

Destek Ekibi
Destek Ekibi
Katılım
11 Ağustos 2008
Mesajlar
5,892
Excel Vers. ve Dili
Office 2013 Tr - Win10 x64
Emin Bey,

yardımlarınız için teşekkür ederim, PNG uzantılı görseller hariç çalışıyor, PNG içinde çalışması için ne yapabiliriz?
PNG resimleri yüklemek için başka bir resim nesnesi kullanmak gerekir.
Bu yeni resim nesnesi ile yüklenen resimlerin olduğu exceli
başka bir bilgisayarda açtığınızda eğer o resimlerin klasörü yoksa resimleri tabloda göstermez.

İki resim nesnesininde kendi göre eksileri var, seçim sizin...

.
 

byfika

Altın Üye
Altın Üye
Katılım
15 Ağustos 2009
Mesajlar
499
Excel Vers. ve Dili
Excel Vers. ve Dili : Ofis 2016 Tr
Altın Üyelik Bitiş Tarihi
13.09.2027
Merhabalar,
Alttaki kodu dener misiniz?

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [b1:b65536]) Is Nothing Then Exit Sub
yatay = -1
dikey = 0
Dim s1
Set s1 = Sheets(ActiveSheet.Name)
deg1 = 0
hucre = ActiveWindow.RangeSelection.Address(False, False)
For i = 1 To Len(hucre)
If Mid(hucre, i, 1) = ":" Then
deg1 = 1
Exit For
Exit Sub
End If
Next
If deg1 = 0 Then
Adres = Worksheets(ActiveSheet.Name).Cells(Target.Row + dikey, Target.Column + yatay).Address
Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
yer = Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column).Address
If yer = Adres Then
Picture.Delete
Exit For
End If
End If
Next Picture
ReDim birler$(50)
birler$(1) = "png": birler$(2) = "jpg"
birler$(3) = "gif": birler$(4) = "bmp"
For j = 1 To 4
If CreateObject("Scripting.FileSystemObject").FileExists(ThisWorkbook.Path & "\STOKLAR\" & Target.Value & "." & birler(j)) = True Then
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\STOKLAR\" & Target.Value & "." & birler(j)).Select
Selection.Top = Val(Target.Offset(dikey, yatay).Top + 4)
Selection.Left = Val(Target.Offset(dikey, yatay).Left + 4)
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Val(Target.Offset(dikey, yatay).Height - 6)
Selection.ShapeRange.Width = Val(Target.Offset(dikey, yatay).Width - 6)
Cells(Target.Row + 1, Target.Column).Select
Exit For
End If
Next
End If
End Sub
 
Katılım
29 Haziran 2018
Mesajlar
297
Excel Vers. ve Dili
2016 TÜRKÇE
Sayın Byfika Merhaba,

Son verdiğiniz kod sorunsuz çalıştı çok çok teşekkür ederim, diğer ilgilenen arkadaşlara da sonsuz teşekkürler.
 

byfika

Altın Üye
Altın Üye
Katılım
15 Ağustos 2009
Mesajlar
499
Excel Vers. ve Dili
Excel Vers. ve Dili : Ofis 2016 Tr
Altın Üyelik Bitiş Tarihi
13.09.2027
Rica ederim. Geri dönüşünüz için ben teşekkür ederim.
İyi çalışmalar...
 
Katılım
29 Haziran 2018
Mesajlar
297
Excel Vers. ve Dili
2016 TÜRKÇE
Sayın Byfika Tekrar Merhaba. 2 gündür yukarıdaki kodları gerçek dosyamda sorunsuz kullanıyorum. İşimi çok kolaylaştırdınız. Rabbim de sizin işlerinizi kolaylaştırsın.

Bu iki günlük kullanımda daha önce aklıma gelmeyen bir durumla karşılaştım. Şöyle ki: B sütununa malzeme kodlarını elle girince veya tek hücreyi kopyala yapıştır yapınca kod sorunsuz çalışırken birden fazla hücreyi kopyalayıp yapıştırınca çalışmıyor. Ancak hücrelere F2 ile girip enter yapınca çalışıyor. Bazen 300 ürün kopyala yapıştır yapıyorum. Sonra F2 ile girip enter.

Eğer mümkün ise çoklu kopyala yapıştırın kodları çalıştırabilmesi için kodlarda gerekli değişikliği yapabilir misiniz? Saygılar.
 
Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Altın Üyelik Bitiş Tarihi
19-10-2021
Sayın Byfika Tekrar Merhaba. 2 gündür yukarıdaki kodları gerçek dosyamda sorunsuz kullanıyorum. İşimi çok kolaylaştırdınız. Rabbim de sizin işlerinizi kolaylaştırsın.

Bu iki günlük kullanımda daha önce aklıma gelmeyen bir durumla karşılaştım. Şöyle ki: B sütununa malzeme kodlarını elle girince veya tek hücreyi kopyala yapıştır yapınca kod sorunsuz çalışırken birden fazla hücreyi kopyalayıp yapıştırınca çalışmıyor. Ancak hücrelere F2 ile girip enter yapınca çalışıyor. Bazen 300 ürün kopyala yapıştır yapıyorum. Sonra F2 ile girip enter.

Eğer mümkün ise çoklu kopyala yapıştırın kodları çalıştırabilmesi için kodlarda gerekli değişikliği yapabilir misiniz? Saygılar.
Deneyiniz
Klasör yolunu kendinize göre uyarlayınız
Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
son = 3
ReDim uzanti(son)
uzanti(1) = ".png"
uzanti(2) = ".jpg"
uzanti(3) = ".gif"

With Application
    .DisplayAlerts = False: .ScreenUpdating = False: .Calculation = xlCalculationAutomatic
End With
Sheets("sayfa1").Pictures.Delete
Klasor = "C:\Users\metin\Desktop\RESİM ÇALIŞMASI\"

Set fso = CreateObject("Scripting.FileSystemObject")
For i = 1 To Cells(Rows.Count, "B").End(3).Row
isim = Cells(i, 2).Value
deg = 0

For j = 1 To son
If fso.FileExists(Klasor & isim & uzanti(j)) = True Then
Set pc = ActiveSheet.Pictures.Insert(Klasor & isim & uzanti(j)) '<-- dikkat

With pc '<---
    .Top = Cells(i, 1).Top + 2
    .Left = Cells(i, 1).Left + 2
    .ShapeRange.LockAspectRatio = msoFalse
    .ShapeRange.Height = Cells(i, 1).Height - 4
    .ShapeRange.Width = Cells(i, 1).Width - 4
   
End With
deg = 1

Exit For
Else

End If
Next
Next
End Sub
 
Son düzenleme:
Katılım
29 Haziran 2018
Mesajlar
297
Excel Vers. ve Dili
2016 TÜRKÇE
Sayın metin_0606 ilginize teşekkür ederim.

Dosya yolunu uyarlayınca kodlar çalıştı. Ancak Dosya değişik bilgisayarlarda kullanılacağı için sabit dosya yolu yerine excel dosyasının bulunduğu klasördeki STOKLAR isimli klasörden almalı. Bunun için klasör yolu nasıl tanımlanmalı.

Bir de sizin çalışmanızda yanlışlıkla bir resim çağrıldıktan sonra aynı hücreye başka bir resim çağrılınca resimler üst üste bindi. Önceki silinip te yeni resim gelmesi daha güzel olmaz mıydı? Saygılar.
 
Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Altın Üyelik Bitiş Tarihi
19-10-2021
Sayın metin_0606 ilginize teşekkür ederim.

Dosya yolunu uyarlayınca kodlar çalıştı. Ancak Dosya değişik bilgisayarlarda kullanılacağı için sabit dosya yolu yerine excel dosyasının bulunduğu klasördeki STOKLAR isimli klasörden almalı. Bunun için klasör yolu nasıl tanımlanmalı.

Bir de sizin çalışmanızda yanlışlıkla bir resim çağrıldıktan sonra aynı hücreye başka bir resim çağrılınca resimler üst üste bindi. Önceki silinip te yeni resim gelmesi daha güzel olmaz mıydı? Saygılar.
Klasor = ThisWorkbook.Path & "\"
klasör yolunu bu şekilde değiştiriniz. resimlerle excel dosyası stoklar klasörünün içinde olacak. Bu şekilde stoklar klasörünü hangi bilgisayara atarsanız atın çalışacaktır. Resimlerin üst üste gelmesi olayınde ben kendi pc de denediğim böyle sorun vermiyor. Resimleri değişiklik halinde siliyor ve altta resim kalmıyor. Yeni resim geliyor. Yazmış olduğum kodu tekrar kontrol ediniz.
Sheets("sayfa1").Pictures.Delete
burada safya1yazan yere kendi sayfa adını yazınız. muhtemelen bundan dolayı yapıyordur.
 
Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Altın Üyelik Bitiş Tarihi
19-10-2021
Sayın metin_0606 ilginize teşekkür ederim.

Dosya yolunu uyarlayınca kodlar çalıştı. Ancak Dosya değişik bilgisayarlarda kullanılacağı için sabit dosya yolu yerine excel dosyasının bulunduğu klasördeki STOKLAR isimli klasörden almalı. Bunun için klasör yolu nasıl tanımlanmalı.

Bir de sizin çalışmanızda yanlışlıkla bir resim çağrıldıktan sonra aynı hücreye başka bir resim çağrılınca resimler üst üste bindi. Önceki silinip te yeni resim gelmesi daha güzel olmaz mıydı? Saygılar.
Klasor = ThisWorkbook.Path & "\"
klasör yolunu bu şekilde değiştiriniz. resimlerle excel dosyası stoklar klasörünün içinde olacak. Bu şekilde stoklar klasörünü hangi bilgisayara atarsanız atın çalışacaktır. Resimlerin üst üste gelmesi olayınde ben kendi pc de denediğim böyle sorun vermiyor. Resimleri değişiklik halinde siliyor ve altta resim kalmıyor. Yeni resim geliyor. Yazmış olduğum kodu tekrar kontrol ediniz.
Sheets("sayfa1").Pictures.Delete
burada safya1yazan yere kendi sayfa adını yazınız. muhtemelen bundan dolayı yapıyordur.
 
Katılım
29 Haziran 2018
Mesajlar
297
Excel Vers. ve Dili
2016 TÜRKÇE
Sayın metin_0606 ilginize teşekkür ederim. Kodda önerdiğiniz değişiklikleri yapıp kullanmaya başladım. Şimdilik gayet güzel çalışıyor. Sorun çıkarsa tekrar bildiririm. Saygılar.
 
Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Altın Üyelik Bitiş Tarihi
19-10-2021
Sayın metin_0606 ilginize teşekkür ederim. Kodda önerdiğiniz değişiklikleri yapıp kullanmaya başladım. Şimdilik gayet güzel çalışıyor. Sorun çıkarsa tekrar bildiririm. Saygılar.
İyi çalışmalar
 
Üst