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

iplikci_80 · 11 Eylül 2020

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.

Korhan Ayhan · 11 Eylül 2020

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 · 11 Eylül 2020

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.

Korhan Ayhan · 11 Eylül 2020

Deneyiniz.

iplikci_80 · 11 Eylül 2020

Korhan Bey çok teşekkür ederim.

iplikci_80 · 16 Eylül 2020

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.

Korhan Ayhan · 16 Eylül 2020

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 · 16 Eylül 2020

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.

Korhan Ayhan · 16 Eylül 2020

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 · 14 Ekim 2020

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 · 14 Ekim 2020

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

burhancavus61 · 14 Ekim 2020

Teşekkür ederim hocam emeğinize sağlık.

ThaLees · 15 Ekim 2020

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 · 18 Ekim 2020

Merhaba ThaLees
Mesajınızı yeni farkettim ama çok güzel işime yarayan bir kod oldu teşekkür ederim.

burhancavus61 · 18 Ekim 2020

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.

ThaLees' Alıntı:
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

ThaLees · 19 Ekim 2020

burhancavus' Alıntı:
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.

Maalesef tam olarak anlayamadım. Kolonlara doğru yatay resim derken neyi kastettiniz ?

burhancavus61 · 19 Ekim 2020

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.

tukayf · 26 Ağustos 2022

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 · 27 Ağustos 2022

Merhaba,

Linkteki paylaştığım kodu deneyiniz.

Sadece belli hücrelerdeki resimleri silmek için makro

Merhabalar, Aşağıdaki makro çalışma sayfasındaki bütün resimleri siliyor. Sub Resimleri_sil() ActiveSheet.Shapes.SelectAll Selection.Delete End Sub Sadece A10:B20 arasındakileri silmesini istiyorum. Bir kaç deneme yaptım ama başarısız oldu.

www.excel.web.tr

mustafakoker · 29 Ağustos 2022

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

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

iplikci_80

Ekli dosyalar

Korhan Ayhan

Administrator

iplikci_80

Ekli dosyalar

Korhan Ayhan

Administrator

Ekli dosyalar

iplikci_80

iplikci_80

Ekli dosyalar

Korhan Ayhan

Administrator

iplikci_80

Ekli dosyalar

Korhan Ayhan

Administrator

burhancavus61

Korhan Ayhan

Administrator

burhancavus61

ThaLees

burhancavus61

burhancavus61

ThaLees

burhancavus61

tukayf

Korhan Ayhan

Administrator

Sadece belli hücrelerdeki resimleri silmek için makro

mustafakoker

Ekli dosyalar