excelde dosyadan direkt resim ekleme

E

esrkeskin

Katılım
19 Mayıs 2007
Mesajlar
5
Excel Vers. ve Dili
2003
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...
 
X

xxcell

Katılım
25 Nisan 2007
Mesajlar
459
Excel Vers. ve Dili
2007
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,

Kod: 
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.
 
E

esrkeskin

Katılım
19 Mayıs 2007
Mesajlar
5
Excel Vers. ve Dili
2003
xxcell çok tesekkür ederim, yalniz örnek yap1p göndersen çok makbüle geçer , yine beceremedim.... :)
 
E

engine

Katılım
19 Mayıs 2007
Mesajlar
2
Excel Vers. ve Dili
2003
ingilizce
İ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.
 
X

xxcell

Katılım
25 Nisan 2007
Mesajlar
459
Excel Vers. ve Dili
2007
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

Kod: 
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
 
X

xxcell

Katılım
25 Nisan 2007
Mesajlar
459
Excel Vers. ve Dili
2007
&#214;zel Mesaj ile iste&#287;iniz &#252;zere &#252;stteki kod a&#351;a&#287;&#305;daki &#351;ekilde geli&#351;tirilmi&#351;tir.

Kod: 
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
 
C

comondante

Katılım
13 Ekim 2008
Mesajlar
1
Excel Vers. ve Dili
2007 eng standart
hocam ellerine sa&#287;l&#305;k bana da 500 adet resimi alt alta yazd&#305;racak bir kod laz&#305;m tek sutunda a&#231;&#305;klamalar&#305;n yan&#305;na koyacak resim boyutlar&#305;n&#305; ben ayarlaya bilirim
 
O

ozhancik

Katılım
14 Temmuz 2008
Mesajlar
3
Excel Vers. ve Dili
tr
xxcell' Alıntı:
Özel Mesaj ile isteğiniz üzere üstteki kod aşağıdaki şekilde geliştirilmiştir.

Kod: 
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
Genişletmek için tıkla ...
Ç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.
 
T

tahsinanarat

Altın Üye
Katılım
14 Mart 2005
Mesajlar
2,175
Excel Vers. ve Dili
Ofis 2019 Türkçe
Altın Üyelik Bitiş Tarihi
27-05-2028
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.
 
O

ozhancik

Katılım
14 Temmuz 2008
Mesajlar
3
Excel Vers. ve Dili
tr
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 :(
 
Son düzenleme:
T

tahsinanarat

Altın Üye
Katılım
14 Mart 2005
Mesajlar
2,175
Excel Vers. ve Dili
Ofis 2019 Türkçe
Altın Üyelik Bitiş Tarihi
27-05-2028
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
 
O

ozhancik

Katılım
14 Temmuz 2008
Mesajlar
3
Excel Vers. ve Dili
tr
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.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst