Otomatik Resim Ekleme

[Leturc]

Merhaba,

İşyerimizde sürekli olarak resimlerle çalıştığımız için resimleri tek tek eklemek oldukça zahmetli oluyor. Forumda araştırma yaparken Sayın Hamitcan tarafından yazılmış bir koda denk geldim ve oldukça yararlı buldum. Kodu, çözebildiğim ve anlayabildiğim kadarıyla düzenlemeye çalıştıysam da başarılı olamadım.

EK'te bulunan belgede de görebileceğiniz gibi benim resim başlıkları (gri) ve resim kutularım var. Normalde resim kutusunu seçtikten sonra sağda yer alan resim ekle düğmesine basarak resmimi çağırıyor ve otomatik olarak seçtiğim hücreye sığdırıyorum. Bu her ne kadar işimi kolaylaştırmış olsa da oldukça vaktimi alıyor. İşte bu nedenle otomatik ekleyebilir miyim diye düşünürken Hamitcan'ın koduna denk geldim.

Ben şu şekilde düşündüm:

Resim gelecek hücreler içerisine önceden numaraları açarım sonra "Resimleri Al" diye bir düğme eklemek suretiyle kutular içerisindeki rakamlara denk gelen resimleri otomatik yansıtırım.

Ya da bir düğme eklerim, A11 hücresinden sırayla başlayarak resimleri ekler ama bu biraz karmaşık geldi olur mu bilmiyorum.
Resimlerin A12 ardından C 12 sonra A15 ve C15 şeklinde eklenmesini arzu etmiştim.

Bilmiyorum siz bu konunun uzmanları nasıl bir tavsiyede bulunabilirsiniz.

Teşekkür ederim.

 

[Merhum İdris SERDAR]

..

Buradaki örnekleri inceleyin.

http://www.excel.web.tr/f136/personel-bilgileri-resimli-3-rnek-dosya-t22790.html


.

 

[Leturc]

Sayın yurttaş,

cevabınız için teşekkür ederim ama inanın o denli bir bilgiye sahip değilim

Şöyle bir kod buldum ama uyduramadım

Sub yazl()
InsertAllPix Range("A1"), _
"C:\Documents and Settings\yazl\My Pictures\My Directory", _
"*.jpg"
End Sub

Sub InsertAllPix(r As Range, ByVal sDir As String, sFilt As String)
Dim sPic As String
Dim iRow As Long

If Right(sDir, 1) <> "\" Then sDir = sDir & "\"
sPic = Dir(sDir & sFilt)

Do While Len(sPic)
iRow = iRow + 1
With ActiveSheet.Pictures.Insert(sDir & sPic)
.ShapeRange.LockAspectRatio = msoFalse
.Height = r(iRow, 1).Height
.Width = r(iRow, 1).Width
.Top = r(iRow, 1).Top
.Left = r(iRow, 1).Left
.Placement = xlMoveAndSize
End With
sPic = Dir
Loop
End Sub

 

[hamitcan]

Private Sub CommandButton1_Click()
Dim resim As Object
    On Error Resume Next
    ActiveSheet.Shapes([a1]).Delete
    [B1].Select
    ActiveSheet.Pictures.Insert (ThisWorkbook.Path & "\" & [a1])
    Set resim = ActiveSheet.DrawingObjects([a1])
    resim.ShapeRange.Height = ActiveCell.Height
    resim.ShapeRange.Width = ActiveCell.Width
    Set resim = Nothing
End Sub

 

[Leturc]

Sayın Hamitcan,

Teşekkür ederim lakin göndermiş olduğunuz dosyadan herhangi bir işlem yapamadım acaba bende mi sıkıntı var?

 

[hamitcan]

Dosyayı yeniledim bir daha deneyin.

 

[Leturc]

Hamitcan Abi,

Valla ben anlamadım. Yani benim dosyam üzerinden deneyebilir misiniz mümkünatı var ise?

Teşekkürler

 

[hamitcan]

Dosyada eksiklikler tespit ettim ve yeniledim. Bunun yanı sıra, yapmanız gerekenler; A1 hücresine resmin ismini uzantısı ile birlikte girmek ve resim al düğmesine basmak. Resimlerinizin bir kısmı “.bmp”, bir kısmı “.jpg” uzantılı olduğu için hücre içerisine resmin ismini doğru şekilde girmelisiniz. Ayrıca eklediğiniz "rar" dosyası içinde size ait bir Excel dosyası mevcut değil,

 

[Leturc]

Sayın Hamitcan,

İlginiz için çok teşekkür ederim.
Uzantı ile çok zor olacaktır. Ben kutucuklara önceden rakam ekleyerek resimlerimi /resimler/ klasörüne attıktan sonra excel dosyamı açınca bir düğmeye tıklamak suretiyle resimlerimin otomatik olarak gelmesini sağlamak istiyorum.

 

[hamitcan]

Kimisi "bmp" kimisi "jpg" uzantılı. Bunu çözmek için farklı bir kod yazmak gerekiyor. Size önerim tüm resim dosyalarını "jpg" uzantılı yapmanız. Böylece resim ismi girerek bu iş rahatlıkla çözülebilir. Ayrıca gönderdiğim dosyayı rar içinden çıkarıp bir yere kopyalamanız yeterli olacaktır. Verdiğim kod resimlerin bulunduğu klasör yolunu otomatik bulacaktır.

 

[Leturc]

"The Linked Image Cannot be viewed" diyor.

Şimdi benim için sizden aldığım ilk kod çalışıyor. Benim eklediğim xls dosyasına göz atarsanız göreceksiniz. Tek istediğim bir düğme aracılığıyla "DUMP" etmesi resimleri.

 

[hamitcan]

Hücrelerin içine girdiğiniz resim isimlerine göre resimleri getiriyor.

Private Sub CommandButton1_Click()
Dim resim As Object
Dim Rng As Range
ResimleriSil
For Each Rng In Range("a12:b200", "c12:c200")
    Rng.Select
    If Rng = "" Then GoTo 10
    On Error Resume Next
        
        Set resim = ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & ActiveCell)
    If Not resim Is Nothing Then
        resim.ShapeRange.Height = ActiveCell.Height - 50
        resim.ShapeRange.Width = ActiveCell.Width - 50
        Set resim = Nothing
    End If
10
Next
Range("A12").Select
End Sub
Sub ResimleriSil()
    Dim obj As Object
    For Each obj In ActiveSheet.Shapes
        If obj.Name = "CommandButton1" Then GoTo 10
        obj.Delete
10:
    Next
End Sub

 

[Leturc]

Hamitcan hocam ellerine sağlık,

geçen haftadan bu yana benim için çaba sarfediyorsun. Allah razı olsun senden.
Şimdi ben her üç dosyayı da denedim. Ancak her defasında resim ActiveCell dışına gözüküyor.

Acaba aşağıdaki kodu dışarıdan tetikleyecek bir kod var mıdır?

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A11:C65536]) Is Nothing Then Exit Sub
If Target.Row Mod 2 = 2 Then Exit Sub
yatay = 0 ' bu kadar hücre sağa kayacak
dikey = 0
Application.ScreenUpdating = True
On Error Resume Next
For i = 1 To ActiveSheet.Shapes.Count
If ActiveSheet.Shapes(i).Left = Target.Offset(dikey, yatay).Left + 1 _
And ActiveSheet.Shapes(i).Top = Target.Offset(dikey, yatay).Top + 1 Then
ActiveSheet.Shapes(i).Delete
End If
Next i
For j = 1 To 11
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\Resimler\" & Target.Value & "." & resimuzantısı(Val(j))).Select
Next

Selection.Top = Target.Offset(dikey, yatay).Top + 1
Selection.Left = Target.Offset(dikey, yatay).Left + 1
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Target.Offset(dikey, yatay).Height - 1
Selection.ShapeRange.Width = Target.Offset(dikey, yatay).Width - 1
Cells(Target.Row, Target.Column + 2).Select

End Sub

Şimdi yorumlayabildiğim kadarıyla yukarıdaki kod, hücrede herhangi bir değişiklik olduğunda ona göre gidip resmi /resimler/ klasöründe arıyor. Ancak ben bu hücreler içerisine önceden 1-2-3 vs diye numaralar yazmak istiyorum ki resimler klasörüne herhangi bir resim atıp dosyamı açtığımda "Resimleri Al" düğmesine basarak otomatik olarak çeksin resimleri.
Dediğim gibi yukarıdaki kodunuz benim yapmak istediğim iş için ideal. Çünkü rakam yazıyorum anında klasördeki resmi boyutlandırıp ekliyor. Geriye bir tek yukarıda vermiş olduğunuz gibi bir tetikleyici kalıyor sayfayı belirli bir şekilde süzecek.

 

[hamitcan]

Hamitcan hocam ellerine sağlık,

geçen haftadan bu yana benim için çaba sarfediyorsun. Allah razı olsun senden.
Şimdi ben her üç dosyayı da denedim. Ancak her defasında resim ActiveCell dışına gözüküyor.

Acaba aşağıdaki kodu dışarıdan tetikleyecek bir kod var mıdır?



Şimdi yorumlayabildiğim kadarıyla yukarıdaki kod, hücrede herhangi bir değişiklik olduğunda ona göre gidip resmi /resimler/ klasöründe arıyor. Ancak ben bu hücreler içerisine önceden 1-2-3 vs diye numaralar yazmak istiyorum ki resimler klasörüne herhangi bir resim atıp dosyamı açtığımda "Resimleri Al" düğmesine basarak otomatik olarak çeksin resimleri.
Dediğim gibi yukarıdaki kodunuz benim yapmak istediğim iş için ideal. Çünkü rakam yazıyorum anında klasördeki resmi boyutlandırıp ekliyor. Geriye bir tek yukarıda vermiş olduğunuz gibi bir tetikleyici kalıyor sayfayı belirli bir şekilde süzecek.

Bu kodu, ben yazmadım. Benim gönderdiğim mesajdaki kodun mantığı; resim isimlerini uzantıları ile birlikte hücrelere yazma ve düğme yardımıyla resimleri çağırma. Resimlerin klasöre ne zaman eklendiği önemli değil.

 

[paranormal]

Merhaba, bir Dosya hazirlamistim, sizin isteginize uygun mu? bilmiyorum. Yalniz otomatik resim ekleme degil. Resimleri sonradan yüklüyorsunuz. Zaten programi açtiktan sonra Isim kaydederken açiklamayi okuyun.

Resimli Adres Defteri programi bi bakiverin hosunuza giderse kodlarini ayri ayri gönderirim.
Eger hata verirse. Excel den MISSING leri kaldirin.
Kolay gelsin.

 

[paranormal]

Gönderdigim programi bi deneyin, Resimli Adres Defteri galiba sizin isteginize uygun.

 

[Leturc]

@Paranormal ilgine çok teşekkür ederim ama o da olmadı
internette çok güzel kodlar var ama VBA bilgim yok.
İlk sayfada eklediğim dosyada resimleri hücreye veri ekledikçe değil de düğmeye basmak suretiyle çektirmeyi başarabilirsem süper olacak.
Beklemedeyim
Aşağıdaki gibi bir model buldum ne dersiniz?