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

[iplikci_80]

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]

Deneyiniz.

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]

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]

Deneyiniz.

 

[iplikci_80]

Korhan Bey çok teşekkür ederim.

 

[iplikci_80]

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]

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]

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]

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]

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.

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]

Deneyiniz.

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]

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

 

[ThaLees]

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 )

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]

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

 

[burhancavus61]

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 )

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]

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]

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]

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]

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]

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.

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