Klasörden Resim Çekme /Resimlerin Boyutlandırması

iplikci_80

Altın Üye
Katılım
29 Kasım 2007
Mesajlar
1,110
Excel Vers. ve Dili
excel 2007
M1 hücresindeki sicile göre I1 hücresine resim klasöründeki resimlerden sicile göre resim getiren çalışmada yapmak istediğim resimlerin I1 hücresinin boyutlarına göre getirilmesi hususunda yardımlarınızı rica ediyorum.
 

Ekli dosyalar

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,327
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

C++:
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [M1]) Is Nothing Then Exit Sub
    
    On Error GoTo Git
    
    ActiveSheet.DrawingObjects.Delete
    Dim ResimYolu As Variant
    Dim Resim As Object
    
    ResimYolu = ActiveWorkbook.Path & "\" & Range("M1") & ".jpg"
    Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)
    
    With Range("I1:K2")
        Resim.ShapeRange.LockAspectRatio = msoFalse
        Resim.Top = .Top
        Resim.Left = .Left
        Resim.Height = .Height
        Resim.Width = .Width
    End With
Git:
End Sub
 

iplikci_80

Altın Üye
Katılım
29 Kasım 2007
Mesajlar
1,110
Excel Vers. ve Dili
excel 2007
Korhan Bey ilginize teşekkür ederim. Mevcut kodları giriş sayfasına yazdığımız sicile göre resim gelecek şeklide revize edilmesi hususunda yardımlarınız rica edebilir miyim.
 

Ekli dosyalar

iplikci_80

Altın Üye
Katılım
29 Kasım 2007
Mesajlar
1,110
Excel Vers. ve Dili
excel 2007
Bu çalışmada giriş sayfasına yazdığımız sicile göre resim getiren kod mevcut. Yapmak istediğim şey resim klasöründeki resimleri 1 şeklinde değilde 0001 şeklinde isimlendirdiğim zaman mevcut kodların çalışmasını sağlamak ve Kitap1 çalışmasını resim klasöründe değilde farklı yerde kullanmak istiyorum kodların revize edilmesi hususunda yardımlarınızı rica ediyorum.
 

Ekli dosyalar

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,327
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
O zaman GİRİŞ sayfasındaki A2 hücresinin biçimini METİN olarak ayarladıktan sonra hücreye örnek olarak 0001 şeklinde veri girişi yapınız.
 

iplikci_80

Altın Üye
Katılım
29 Kasım 2007
Mesajlar
1,110
Excel Vers. ve Dili
excel 2007
Korhan Bey EK'te ki gibi Kitap1 çalışmasını resim klasöründe değilde farklı yerde kullanmak istiyorum bu yönde mevcut kodların revize edilmesi hususunda yardımlarınızı rica edebilir miyim.
 

Ekli dosyalar

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,327
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Kodlarda revize yapmanıza gerek yok.

Siz A2 hücresinin biçimini METİN olarak değiştirip hücreye 0001 gibi giriş yaparsanız kodlar çalışacaktır. Tabi kodların hata vermemesi için resim dosyalarının isimleride aynı şekilde olmalıdır. Yani 0001.jpg gibi olmalıdır.
 

burhancavus61

Altın Üye
Katılım
13 Mayıs 2005
Mesajlar
756
Excel Vers. ve Dili
2010 Türkçe
Korhan Hocam sizin makroyu kendime uyarladım. Bir sorunum var eğer aranan resim yok ise klasör içindeki "RESİM YOK" resmini çağırabilirmiyiz.
Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
    ActiveSheet.Unprotect

    If Intersect(Target, [N1]) Is Nothing Then Exit Sub
    
    On Error GoTo Git
    
    Dim ResimYolu As Variant
    Dim Resim As Object
    
    
    DrawingObjects.Delete
    
    ResimYolu = ActiveWorkbook.Path & "\" & Range("N1") & ".jpg"
    Set Resim = Pictures.Insert(ResimYolu)
    
    With Range("J3:K3")
        Resim.ShapeRange.LockAspectRatio = msoFalse
        Resim.Top = .Top
        Resim.Left = .Left
        Resim.Height = .Height
        Resim.Width = .Width
    End With
Git:
    
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,327
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

C++:
Private Sub Worksheet_Change(ByVal Target As Range)
    ActiveSheet.Unprotect

    If Intersect(Target, [N1]) Is Nothing Then Exit Sub
    
    On Error GoTo Git
    
    Dim ResimYolu As Variant
    Dim Resim As Object
    
    
    DrawingObjects.Delete
    
    ResimYolu = ActiveWorkbook.Path & "\" & Range("N1") & ".jpg"
    If Dir(ResimYolu) = "" Then ResimYolu = ActiveWorkbook.Path & "\RESİM YOK.jpg"
    
    Set Resim = Pictures.Insert(ResimYolu)
    
    With Range("J3:K3")
        Resim.ShapeRange.LockAspectRatio = msoFalse
        Resim.Top = .Top
        Resim.Left = .Left
        Resim.Height = .Height
        Resim.Width = .Width
    End With
Git:
    
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
 
Katılım
2 Eylül 2014
Mesajlar
144
Excel Vers. ve Dili
2016 Türkce 64bit
Merhabalar.
Konu çözüldümü bilmüyorum ama alternatif olarak bu formülüde kullanabilirsiniz.
Kendi dosyanıza ve adres yolunuza uygulamanız lazım. Değişmeniz ve dikkat etmeniz gerekenleride aşağıda listeledim

Aşağıdaki koda göre ;
  • B sütunundaki kod ile resmin adı aynı olmalı
  • B23-B80 arasına bakıp resimleri karşılık gelen G sütununa ekler
  • C:\Users\Kullanıcı\Desktop\RESİMLER Resimlerin olduğu klasör yolu
  • U sütununa resimlerin exceldeki adlarını getirttir – Bu ada göre G sütunundaki resmi siler.
  • Resim boyutlandırmada + - sayılar belirterek resmin konumunu ayarla.
  • Resimlerin olduğu klasörde "bos" adı ile bir resim koyarsanız resmi bulunmayan kod için bu resmi getirir.
  • Resimler jpg formatında olmalıdır.
Not : Eğer dosyanızda satır sayısı fazla ise muhakkak resim boyutlarını küçültün. Aksi takdirde hem çok fazla kasacaktır hem dosya kullanılamaz hale gelecektir. ( PIXresizer Kullanabilirsiniz )



Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo CIKIS

If Intersect(Target, [B23:B80]) Is Nothing Then Exit Sub


Satir = Target.Row
a = RESIM_SIL(Satir)

If Range("B" & Satir).Value = "" Then Exit Sub
a = RESIM_EKLE(Satir)


Exit Sub

CIKIS:
    MsgBox Err.Description
End Sub
Public Function RESIM_EKLE(pSatir)
On Error GoTo Hata

Dim ResimYolu, dosyaVarmi As Variant
Dim Resim As Object

ResimYolu = "C:\Users\Kullanıcı\Desktop\RESİMLER\" & Range("B" & pSatir).Value & ".jpg"
dosyaVarmi = Dir(ResimYolu)

If dosyaVarmi = "" Then
    ResimYolu = "C:\Users\Kullanıcı\Desktop\RESİMLER\bos.jpg"
End If
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)
    ' Resim boyutlama
    
    Range("U" & pSatir).Value = Resim.Name
    With Range("G" & pSatir)
    
    Resim.ShapeRange.LockAspectRatio = msoFalse
    Resim.Left = .Left + 2
    Resim.Top = .Top + 1
    Resim.Height = .Height - 2
    Resim.Width = .Width - 5
        
    End With

Exit Function

Hata:
    MsgBox "Hata Oluştu" & vbNewLine & Err.Description
End Function

Public Function RESIM_SIL(pSatir)
On Error GoTo Hata

    ActiveSheet.Shapes.Range(Array(Range("U" & pSatir).Value)).Select
    Selection.Delete

Hata:
    Range("U" & pSatir).Value = ""
End Function
 

burhancavus61

Altın Üye
Katılım
13 Mayıs 2005
Mesajlar
756
Excel Vers. ve Dili
2010 Türkçe
Merhaba ThaLees
Mesajınızı yeni farkettim ama çok güzel işime yarayan bir kod oldu teşekkür ederim.
 

burhancavus61

Altın Üye
Katılım
13 Mayıs 2005
Mesajlar
756
Excel Vers. ve Dili
2010 Türkçe
Sayın ThaLees
Bu kodları satıra dönüştürebilirmiyiz peki. Siz satır satır eklemişsiniz ben kolonlara doğru yatay resim eklemek istiyorum.

Merhabalar.
Konu çözüldümü bilmüyorum ama alternatif olarak bu formülüde kullanabilirsiniz.
Kendi dosyanıza ve adres yolunuza uygulamanız lazım. Değişmeniz ve dikkat etmeniz gerekenleride aşağıda listeledim

Aşağıdaki koda göre ;
  • B sütunundaki kod ile resmin adı aynı olmalı
  • B23-B80 arasına bakıp resimleri karşılık gelen G sütununa ekler
  • C:\Users\Kullanıcı\Desktop\RESİMLER Resimlerin olduğu klasör yolu
  • U sütununa resimlerin exceldeki adlarını getirttir – Bu ada göre G sütunundaki resmi siler.
  • Resim boyutlandırmada + - sayılar belirterek resmin konumunu ayarla.
  • Resimlerin olduğu klasörde "bos" adı ile bir resim koyarsanız resmi bulunmayan kod için bu resmi getirir.
  • Resimler jpg formatında olmalıdır.
Not : Eğer dosyanızda satır sayısı fazla ise muhakkak resim boyutlarını küçültün. Aksi takdirde hem çok fazla kasacaktır hem dosya kullanılamaz hale gelecektir. ( PIXresizer Kullanabilirsiniz )



Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo CIKIS

If Intersect(Target, [B23:B80]) Is Nothing Then Exit Sub


Satir = Target.Row
a = RESIM_SIL(Satir)

If Range("B" & Satir).Value = "" Then Exit Sub
a = RESIM_EKLE(Satir)


Exit Sub

CIKIS:
    MsgBox Err.Description
End Sub
Public Function RESIM_EKLE(pSatir)
On Error GoTo Hata

Dim ResimYolu, dosyaVarmi As Variant
Dim Resim As Object

ResimYolu = "C:\Users\Kullanıcı\Desktop\RESİMLER\" & Range("B" & pSatir).Value & ".jpg"
dosyaVarmi = Dir(ResimYolu)

If dosyaVarmi = "" Then
    ResimYolu = "C:\Users\Kullanıcı\Desktop\RESİMLER\bos.jpg"
End If
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)
    ' Resim boyutlama
   
    Range("U" & pSatir).Value = Resim.Name
    With Range("G" & pSatir)
   
    Resim.ShapeRange.LockAspectRatio = msoFalse
    Resim.Left = .Left + 2
    Resim.Top = .Top + 1
    Resim.Height = .Height - 2
    Resim.Width = .Width - 5
       
    End With

Exit Function

Hata:
    MsgBox "Hata Oluştu" & vbNewLine & Err.Description
End Function

Public Function RESIM_SIL(pSatir)
On Error GoTo Hata

    ActiveSheet.Shapes.Range(Array(Range("U" & pSatir).Value)).Select
    Selection.Delete

Hata:
    Range("U" & pSatir).Value = ""
End Function
 

burhancavus61

Altın Üye
Katılım
13 Mayıs 2005
Mesajlar
756
Excel Vers. ve Dili
2010 Türkçe
Aşağı doğru satır satır isim seçip resim ekleyebiliyorum. Bunu yatay yapmak istiyorum klasör sırtlığı için. Personelin resimlerini ekleyeceğim.
 
Katılım
9 Eylül 2010
Mesajlar
855
Excel Vers. ve Dili
2016&2019&2021 TR
Merhabalar. Korhan Beyin kodu sayfadaki tüm nesneleri siliyor. Bunun yerine sadece I1:k1 deki resmi silmesi için kodu revize edebilir miyiz. Resimleri dosya yolundan değilde farklı klasörden alması için yolda nasıl değişiklik yapmalıyım. Şimdiden teşekkürler
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,327
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Merhaba,

Linkteki paylaştığım kodu deneyiniz.

 

mustafakoker

MUSTAFA KÖKER
Altın Üye
Katılım
20 Haziran 2008
Mesajlar
697
Excel Vers. ve Dili
Microsoft Office ev ve iş 2019
Merhaba Arkadaşlar;
Benzer bir sorunum var kodları siteden bulum kendime göre uyarlamaya çalıştım fakat bazı yerlerde hata alıyorum.
Userform1deki Listbox click olayında seçtiğim satırdaki bilgilerin textboxlara gelmesi ve image1 deki resimnin de değişmesi
2.sorum ise TXTARA texboxındaki Sipariş numarasını yazdığımda Listboxta araması ve clik lediğimde yine ilgili textboxlara bilgilerin gelmesi konusunda yardımcı olursanız sevinirim.
Not eğer aranan resim yok ise Resim yok .jpg image1e gelmesi de gerekiyor.

Kod:
Private Sub TexARA_Change() 'Sipariş numarası ara

resimYol = ThisWorkbook.Path & "\Resimler\"
Resimler = Dir(resimYol & "*.*")
resim = 0
While Resimler <> ""
DoEvents
resimlerAd = Mid(Resimler, 1, Len(Resimler) - 4)
If resimlerAd = Me.TexARA.Text Then
Me.Image1.Picture = LoadPicture(resimYol & Resimler)
resim = 1
End If
Resimler = Dir
Wend
If resim = 0 Then Me.Image1.Picture = LoadPicture(resimYol & "RESİM YOK.jpg")

End Sub
 

Ekli dosyalar

Üst