Klasördeki tüm resimleri Excel sayfasına eklemek.

[Muhammet Okumuş]

Arkadaşlar merhaba. Bir Excel dosyası üzerinde çalışıyorum. Yapmak istediğim masaüstü veya her hangi bir yerde bulunan klasör içindeki tüm resimleri sayfanın BA1 hücresine eklemek istiyorum.

 

[EmrExcel16]

Merhaba dosya ile aynı klasör içindeki resimleri A1 hücresine getirir.

Option Explicit
Sub Ayni_Klasor_Resimler()
Dim MyPath, ResimYolu, Resim, Res, x, i
Dim uzanti()
For Each Res In ActiveSheet.Shapes
    If Res.Name <> "Button 5" Then
        Res.Delete
    End If
Next
'ActiveSheet.DrawingObjects.Delete
Set MyPath = CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path)
   
ReDim uzanti(3)
uzanti(1) = "*.jpg*": uzanti(2) = "*.gif*": uzanti(3) = "*.png*"

For x = 1 To 3
   
    ResimYolu = Dir(MyPath & Application.PathSeparator & uzanti(Val(x)), vbDirectory)

    Do While ResimYolu <> ""
        If ResimYolu = ThisWorkbook.Name Then GoTo git:
            i = i + 1
            Set Resim = ActiveSheet.Pictures.Insert(MyPath & "/" & ResimYolu)
            With Range("A1")
                Resim.ShapeRange.LockAspectRatio = msoFalse
                Resim.Height = .MergeArea.Height - 0.2
                Resim.Width = .MergeArea.Width - 0.2
                Resim.Top = .Top + 0.2
                Resim.Left = .Left + 0.2
                Resim.Placement = xlMoveAndSize
            End With
git:
        ResimYolu = Dir
    Loop
Next
End Sub

 

[Muhammet Okumuş]

Sn EmrExcel16;
Çok teşekkür ederim.

 

[EmrExcel16]

Sn EmrExcel16;
Çok teşekkür ederim.

Rica ederim , kolay gelsin.

 

[Muhammet Okumuş]

Sn @EmrExcel16
Şöyle bir sorun oluştu. Resimleri klasörden silince Excel dosyasındaki resimlerde kayboluyor. Bu bağlantıyı kaldırabilir miyiz? Resimler klasörden silinince Excel dosyasında kalmalı

 

[Muhammet Okumuş]

Bu yöntemi AddPicture yöntemi ile yapabilir miyiz?

 

[Haluk]

Bu yöntemi AddPicture yöntemi ile yapabilir miyiz?

Bağlantılı resim görüntülenemiyor, Dosya taşımış hatası

Aynı sorunu ben de yaşıyorum. Insert komutu ile resim ekliyorum. Ama resimleri klasörden silince Excel'de görünmüyor. Bu resimleri Excel'e gömmek mümkün mü?

www.excel.web.tr

.

 

[Muhammet Okumuş]

Insert tam istediğim çözüm. Sonuca ulaştım. Ama resimler silinince bir anlamı kalmıyor. Bu resimleri Excel'e gömmek gerekiyor.

 

[Muhammet Okumuş]

 

[Muhammet Okumuş]

Bu tasarımı kodlar ile oluşturuyorum. Insert olayını çözersek yüküm baya hafifleyecek.

 

[Muhammet Okumuş]

@Haluk Resim_Al kodlarını düzenleme imkanınız olabilir mi? Resimlerle ilgili hiç çalışma yapmadım daha önce.

 

[EmrExcel16]

Sn @EmrExcel16
Şöyle bir sorun oluştu. Resimleri klasörden silince Excel dosyasındaki resimlerde kayboluyor. Bu bağlantıyı kaldırabilir miyiz? Resimler klasörden silinince Excel dosyasında kalmalıEkli dosyayı görüntüle 212406

Bu şekilde deneyiniz.

Option Explicit
Sub Ayni_Klasor_Resimler()
Dim MyPath, ResimYolu, Resim, Res, x, i
Dim uzanti()
For Each Res In ActiveSheet.Shapes
    If Res.Name <> "Button 5" Then
        Res.Delete
    End If
Next
'ActiveSheet.DrawingObjects.Delete
Set MyPath = CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path)
    
ReDim uzanti(3)
uzanti(1) = "*.jpg*": uzanti(2) = "*.gif*": uzanti(3) = "*.png*"

For x = 1 To 3
    
    ResimYolu = Dir(MyPath & Application.PathSeparator & uzanti(Val(x)), vbDirectory)

    Do While ResimYolu <> ""
        If ResimYolu = ThisWorkbook.Name Then GoTo git:
            i = i + 1
            Set Resim = ActiveSheet.Shapes.AddPicture(MyPath & "/" & ResimYolu, True, True, 100, 100, 100, 100)
            With Range("A1")
                'Resim.ShapeRange.LockAspectRatio = msoFalse
                Resim.Height = .MergeArea.Height - 0.2
                Resim.Width = .MergeArea.Width - 0.2
                Resim.Top = .Top + 0.2
                Resim.Left = .Left + 0.2
                Resim.Placement = xlMoveAndSize
            End With
git:
        ResimYolu = Dir
    Loop
Next
End Sub

 

[Muhammet Okumuş]

Sn @EmrExcel16 çok teşekkür ederim. Dün gece uzun uğraşlar sonunda sorunu çözdüm. Burda en sağda bulunan iki tane 100 değerin -1 yapınca resim boyutu aynı kalıyor.

 

[EmrExcel16]

Sn @EmrExcel16 çok teşekkür ederim. Dün gece uzun uğraşlar sonunda sorunu çözdüm. Burda en sağda bulunan iki tane 100 değerin -1 yapınca resim boyutu aynı kalıyor.

Rica ederim , evet bunu biliyorum , vermiş olduğum kodda verilen bir hücre adresine , hücrenin boyutlarına getiriyor , bilginiz olsun.