excelde dosyadan direkt resim ekleme

[esrkeskin]

arkadaslar bir klasörümde 200 resim var, bunlari exele 6 sutun olacak sekilde alt alta resmin isimleriyle birlikte ve 4*2 cm boyutunda kücülterek s1ralamas1n1 yapacak makro laz1m

yani bir butona t1kladigimda c://deneme deki tüm resimler 6 sutun halinde küçük boyutta alt alta isimleriyle birlikte getirsin..

bek çok urastim hiç geli_me salayamadim

yardimci olurmusunuz...

 

[xxcell]

Resim eklemek için;

Set sayfa= Worksheets(1)
sayfa.Shapes.AddPicture "c:\ornek.bmp", True, True, 100, 100, 70, 70

' parametreleri = Dosya Adı , Link? , Dökümanla Kayıt?, Sol, Üst, Genişlik, Uzunluk


Tabi siz önce dosyalarınızı bulmak istiyorsunuz.
dosyaları da otomatik bulsun istiyorsanız,

With Application.FileSearch
    .LookIn = "C:\deneme"
    .Filename = "*.gif"
    If .Execute > 0 Then
        
        For i = 1 To .FoundFiles.Count
            
            Dosya = .FoundFiles(i)

Worksheets(1).Shapes.AddPicture Dosya, True, True, 100, 100, 70, 70


        Next i
    Else
        MsgBox "Dosya Bulunamadı "
    End If
End With

Not. Ne yazıkki evdeki excele FILESEARCH objesi yuklu olmadığı için
deneyemedim ama teknik böyle bişey. Denerseniz başarılı olabileceğiniz düşünüyorum.

İkinci hatırlatma;

Muhtemelen ilgili resimleri üst üste getirecektir. Hücrelere yayma işi için
resmin Solu ve üstünü hücreye hizalatın. Ve hücrenin genişlik ve uzunluğunu
resme eşitleyin.

 

[esrkeskin]

xxcell çok tesekkür ederim, yalniz örnek yap1p göndersen çok makbüle geçer , yine beceremedim....

 

[engine]

İstediğini yanlış anlamadıysam bu örnek işini görür.Ölçülendirmeleri kendin yaparsın.

Sub resimekleme()
'

With Application.FileSearch
.LookIn = "c://deneme"
.Filename = "*.jpg"
If .Execute > 0 Then
x = 0
d = 0
For i = 1 To .FoundFiles.Count

x = 1 + Int(i / 6)
d = i Mod 6
Dosya = .FoundFiles(i)
Worksheets(1).Shapes.AddPicture Dosya, True, True, d * 100, x * 100, 70, 40
Next i
End If
End With

End Sub


Saygılarımla.

 

[xxcell]

Kusura bakma vakitsizlikten cevabı yarım bırakmıştım.

Şu filesearch herbilgisayarda hazır kurulu değil (en azından benim evde :mrgreen: )

Çalışma prensibi olarak Sık Kullanmadığım Komutları;
özellikle excel'in kendi help'inden bulup uygulamaya geçiriyorum.

filesearch işyerimde sorunsuz çalıştığı için alternatif aramayı
aklıma getirmemiştim. sonra bizim emektar DIR komutu aklıma geldi.

aşağıdaki kodu çalıştırınca bende ilgili dizindeki tüm resimleri
güzelce excele ekledi.

İşini göreceğini umuyorum

Sub dizindeki_tum_resimleri_excele_ekleme()


Dim dosya
Dim i As Integer
dizin = "c:\users\public\pictures\sample Pictures\"
dosya = Dir(dizin & "*.jpg*")
satir = 1
sutun = 1
resim_genislik = 60
resim_yukseklik = 110
While dosya <> ""

konum_sol = Cells(satir, sutun).Width * (sutun - 1)
konum_ust = Cells(satir, sutun).Height * (satir - 1)
Cells(satir, sutun).ColumnWidth = 12
Cells(satir, sutun).RowHeight = 115

ActiveSheet.Shapes.AddPicture dizin & [dosya], True, True, konum_sol + 4, konum_ust + 4, resim_genislik, resim_yukseklik

Application.Wait Now + TimeValue("00:00:01")

dosya = Dir
If sutun = 6 Then
sutun = 1
satir = satir + 1
Else
sutun = sutun + 1
End If

Wend

End Sub

 

[esrkeskin]

tesekkurler

 

[xxcell]

Özel Mesaj ile isteğiniz üzere üstteki kod aşağıdaki şekilde geliştirilmiştir.

Sub dizindeki_tum_resimleri_excele_ekleme()

Dim dosya
Dim i As Integer
dizin = "c:\users\public\pictures\sample Pictures\"
dosya = Dir(dizin & "*.jpg")
satir = 1
sutun = 1
resim_genislik = 60
resim_yukseklik = 110
konum_sol = Cells(satir, sutun).Width * (sutun - 1)
konum_ust = Cells(satir, sutun).Height * (satir - 1)
While dosya <> ""

Cells(satir, sutun).ColumnWidth = 12
Cells(satir, sutun).RowHeight = 115

ActiveSheet.Shapes.AddPicture dizin & [dosya], True, True, konum_sol + 4, konum_ust + 4, resim_genislik, resim_yukseklik

Application.Wait Now + TimeValue("00:00:01")
Cells(satir + 1, sutun) = dosya
dosya = Dir
If sutun = 6 Then
sutun = 1
konum_ust = konum_ust + Cells(satir, sutun).Height
konum_ust = konum_ust + Cells(satir + 1, sutun).Height
satir = satir + 2
konum_sol = 0
Else
konum_sol = konum_sol + Cells(satir, sutun).Width
sutun = sutun + 1
End If


Wend

End Sub

 

[comondante]

hocam ellerine sağlık bana da 500 adet resimi alt alta yazdıracak bir kod lazım tek sutunda açıklamaların yanına koyacak resim boyutlarını ben ayarlaya bilirim

 

[ozhancik]

Özel Mesaj ile isteğiniz üzere üstteki kod aşağıdaki şekilde geliştirilmiştir.

Sub dizindeki_tum_resimleri_excele_ekleme()

Dim dosya
Dim i As Integer
dizin = "c:\users\public\pictures\sample Pictures\"
dosya = Dir(dizin & "*.jpg")
satir = 1
sutun = 1
resim_genislik = 60
resim_yukseklik = 110
konum_sol = Cells(satir, sutun).Width * (sutun - 1)
konum_ust = Cells(satir, sutun).Height * (satir - 1)
While dosya <> ""

Cells(satir, sutun).ColumnWidth = 12
Cells(satir, sutun).RowHeight = 115

ActiveSheet.Shapes.AddPicture dizin & [dosya], True, True, konum_sol + 4, konum_ust + 4, resim_genislik, resim_yukseklik

Application.Wait Now + TimeValue("00:00:01")
Cells(satir + 1, sutun) = dosya
dosya = Dir
If sutun = 6 Then
sutun = 1
konum_ust = konum_ust + Cells(satir, sutun).Height
konum_ust = konum_ust + Cells(satir + 1, sutun).Height
satir = satir + 2
konum_sol = 0
Else
konum_sol = konum_sol + Cells(satir, sutun).Width
sutun = sutun + 1
End If


Wend

End Sub

Çok güzel bir kod teşekkür ederim. şimdi bu kodda ben resimleri istiyorumki F sütununa dizsin ama A sütunundaki xxxxx rakkamı ile eşleşen resimleri aynı satıra dizsin.

 

[tahsinanarat]

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, [A1:a65536]) Is Nothing Then Exit Sub
If Target.Row Mod 2 = 2 Then Exit Sub
On Error GoTo hata
For i = 1 To ActiveSheet.Shapes.Count
If ActiveSheet.Shapes(i).Left = Target.Offset(0, 5).Left _
And ActiveSheet.Shapes(i).Top = Target.Offset(0, 5).Top Then
ActiveSheet.Shapes(i).Delete
End If
Next i
hata:
On Error GoTo son
ActiveSheet.Pictures.Insert("d:\foto\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(0, 5).Top
Selection.Left = Target.Offset(0, 5).Left
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Target.Offset(0, 5).Height
Selection.ShapeRange.Width = Target.Offset(0, 5).Width
Target.Select
son:
End Sub
Sub Ekle_Nesne_TumSil()
ActiveSheet.DrawingObjects.Delete
End Sub


Not: kodlar evvelce bu siteden temin edilmiştir.

 

[ozhancik]

Tahsin bey bu kod hata vermedi ama çalışmadıda A sütununa konumunu belirttiğim yerdeki dosya ismini yazdım yine olmadı

Edit ; yapmak istediğim şudur aslında. Biz muhasebe programında stok dökümü alıyoruz. aynı stok kodlarındada resimler mevcut. şimdi excel olarak aldığımız stok dökümüne öyle bir makro olacakki A1 sütunundaki kodlara karşılık gelen resimler o satırın sonunda belirleyeceğimiz boyutlarda otomatik olarak getirebilecek.


foumdaki örneklere baktım onlar farklı sistem ile çalışıyor

 

[tahsinanarat]

a sutununuda kodların bulunduğu hücrelere f2 enterla girdiğinizde yada kodu yazdığınız anda hücre çıkışında resim gelecektir
ancak toplu halde gelmesini istiyorsanız kodlarda bir düzenleme, yada f2 işlemini a sutunurda dolu olan hücrelerde yaptırmak için ayrıa bir kod yazılıp bir butona bağlanabilir.


Bu kodu çalıştırarak resimlerin gelmesini sağlayabilirsiniz.
(yukarıdaki kodlar sayfanın kod bölümünde olmalı)
Modüle;
Sub VERİLERİ_DÜZENLE()
[A1].Select
For X = 1 To [A65536].End(3).Row + 1
Application.SendKeys "{F2}"
Application.SendKeys "{ENTER}"
Next
End Sub

 

[ozhancik]

verileri düzenleme makrosu çalışıyor fakat


Varsayılan
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, [A1:a65536]) Is Nothing Then Exit Sub
If Target.Row Mod 2 = 2 Then Exit Sub
On Error GoTo hata
For i = 1 To ActiveSheet.Shapes.Count
If ActiveSheet.Shapes(i).Left = Target.Offset(0, 5).Left _
And ActiveSheet.Shapes(i).Top = Target.Offset(0, 5).Top Then
ActiveSheet.Shapes(i).Delete
End If
Next i
hata:
On Error GoTo son
ActiveSheet.Pictures.Insert("d:\foto\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(0, 5).Top
Selection.Left = Target.Offset(0, 5).Left
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Target.Offset(0, 5).Height
Selection.ShapeRange.Width = Target.Offset(0, 5).Width
Target.Select
son:
End Sub
Sub Ekle_Nesne_TumSil()
ActiveSheet.DrawingObjects.Delete
End Sub


yukarıdaki makro çalışmıyor . bunu hangi sütuna sıralayacağımızı ve boyutlarını nerden düzenleyebilirim.