otomatik resim boyutlandırma

[ebebe41]

merhabalar
bu konuyu çok araştırdım forumda ve internette,ancak istediğim gibi bir makro bulamadım.yardımcı olursanız sevinirim.
Ekteki excel dosyasında örnek olarak 2 tane sheet var.
Her sheett in sol altında göründüğü gibi logo var.bu logo sabit kalacak.
Sorum şu:
Exceldeki sheetlerdeki birleştirilmiş "yeşil" alana resim eklemek istiyorum. (A8 B18)
Ancak resim ekle dediğimde o alana otomatik yerleşsin.Ben manuel içine sığdırmaya çalışmayayım.
Elimdeki excel dosyasında 30-40 tane sheet var.her sheetin yeşil alanına farklı resim eklemem gerekiyor

excel linki aşağıda

http://dosya.co/gx0v46s2rwaf/şablon2.xlsx.html

ekran görüntüsü
https://ibb.co/j22e0L

 

[ebebe41]

aşağıdaki makroyu buldum ama yeşil alanı tıklayıp çalıştırdığımda bazı resimleri o alana otomatik boyutlandırıyor.
ama bazı resimleri de rastgele bi alana boyutsuz koyuyor.

Private Sub CommandButton1_Click()

Dosya = Application.GetOpenFilename("All Files (*.*),*.*.")
If Dosya = False Then
MsgBox "Veri alınacak dosyayı seçmediniz.", vbInformation, "DİKKAT"
Exit Sub
Else
End If

Set Adres = Range(ActiveWindow.RangeSelection.Address)
ActiveSheet.Pictures.Insert(Dosya).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Top = Adres.Top + 2
Selection.Left = Adres.Left + 2
Selection.ShapeRange.Height = Adres.Height - 3
Selection.ShapeRange.Width = Adres.Width - 3
Cells(1, 1).Select

End Sub

 

[muygun]

Merhaba;

Boş bir modüle;

Sub seçili_hücreye_resim_ekle()
Dosya = Application.GetOpenFilename("All Files (*.*),*.*.")
If Dosya = False Then
MsgBox "Veri alınacak dosyayı seçmediniz.", vbInformation, "DİKKAT"
Exit Sub
Else
End If
Set Alan = Range("a8:b18")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, Alan) Is Nothing Then
resimm.Delete
End If
Next
Set Alan = Nothing
Cells(8, "a").Select
Set Adres = Range(ActiveWindow.RangeSelection.Address)
ActiveSheet.Pictures.Insert(Dosya).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Top = Adres.Top + 2
Selection.Left = Adres.Left + 2
Selection.ShapeRange.Height = Adres.Height - 3
Selection.ShapeRange.Width = Adres.Width - 3
Cells(1, 1).Select
End Sub

Kodlarını yerleştirerek bir butona bağlayın.
İyi çalışmalar.

 

[ebebe41]

merhaba
öncelikle teşekkür ederim.
ancak şöyle bir sorunum var,resmi ekleyince resmi döndürerek yerleştiriyor.
yani 90 derece sola gibi.resimlerin orjinaline baktım ama onlar normal.
excel içinden resimi çevirince de bu sefer de alandan dışarı çıkıyor.

 

[muygun]

Merhaba;
Öncelikle kendi denemelerimde böyle bir sonuçla karşılaşmadım.
Ayrıca kodlarınıza dokunmadan sadece;

Set Alan = Range("a8:b18")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, Alan) Is Nothing Then
resimm.Delete
End If
Next
Set Alan = Nothing
Cells(8, "a").Select

aralığını ekledim.
Eklediğim 7 satır kod eski resmi siler
8. satır ise A8 hücresini seçer.

Siz önceden döndürülmemiş bir resim seçerek (çekilmiş haliyle kalmış) deneme yapın.
Sonuç alırsanız resimlerinizi bir editör ile açarak döndürmeniz ve kaydetmeniz gerekecek.

 

[ebebe41]

evet ilginçtir ki başka bilgisayardan aynı resmi denediğimde döndürmüyor.
döndürmeyen 2016
döndüren ise 2010. versiyonla alakalı mıdır anlamadım.
bunu bi şekilde çözeceğim mecburen
elinize sağlık aşağı yukarı istediğim gibi oldu ve çok işime yaradı.

 

[u.L.a.s]

merhaba

ilgili dosyayı bende indirip inceledim. affınıza mahcuben yaptığım deneme şu şekilde. width geniş height dar olan fotolar yani yatay fotolarda yerleşmede sorun olmuyor. ama dikey çekilmiş bir fotoysa yani cep telefonu biliyorsunuz genelde width kısmı dar height kısmı daha uzun olan fotolar çektiğinden. ve sizin fotolarınızda bu tarz bir foto olduğundan seçtiğiniz fotoları yan döndürüyor.

muygun üstadım Incramentrotation 90 gibi bir kod ile deneyeyim dedim ama bulunduğu hücreden farklı bir yere konumlandırdı resmi. tamam döndürdü ama hani saatin 9 noktasında olması gereken resmi 12 noktasına taşımış gibi bir şey oldu.

arkadaşında istediği sanırım böyle birşey.

Edit : son mesajı yeni gördüm evet bende 2010 da denemiştim. ama 2016 elimde olmadığından deneyemedim.

 

[ebebe41]

not:evet dediğiniz gibi eklemeye çalıştığım bütün fotolar cep telefonuyla çekilmiş.

 

[euphrates55]

gezinirken karşılaştığım müthiş bir kod. çok güzel olmuş. ellerinize sağlık. peki bu 3. mesajdaki kodu, tüm fotoları hep aynı klasörden aldığımızı düşünürsek ve her bir fotonun adı değişik olduğunu da düşünürsek. resmi koyduğumuz hücredeki fotoğrafın c2 de yazan adına göre değişmesi mümkün mü? yani c2 de ne yazıyorsa o klasörde o isimdeki fotoyu bulup değiştirecek şekilde yapabilir miyiz. excelin neler yapabildiğini gördükçe biz basic kullanıcılar böyle fantazileri soruyoruz ama artık kusura bakmazsınız umarım. belki oluyordur.

 

[muygun]

gezinirken karşılaştığım müthiş bir kod. çok güzel olmuş. ellerinize sağlık. peki bu 3. mesajdaki kodu, tüm fotoları hep aynı klasörden aldığımızı düşünürsek ve her bir fotonun adı değişik olduğunu da düşünürsek. resmi koyduğumuz hücredeki fotoğrafın c2 de yazan adına göre değişmesi mümkün mü? yani c2 de ne yazıyorsa o klasörde o isimdeki fotoyu bulup değiştirecek şekilde yapabilir miyiz. excelin neler yapabildiğini gördükçe biz basic kullanıcılar böyle fantazileri soruyoruz ama artık kusura bakmazsınız umarım. belki oluyordur.

Sanırım istediğiniz sayfaya yerleştirilmiş resim adlarına göre bir klasörden resim getirmek.
örnek dosya eklerseniz elbette yapılabilir.
örnek dosyanızı;
http://dosya.co/
adresine ekleyerek indirme linkini burada paylaşın.