çift tıklama ile hücre boyutunda resim ekleme

[huseyinvurkan]

Arkadaşlar ekteki dosyada A1 hücresine çift tıklama ile resim ilave edilebilmekte. Ancak diğer hücrelere eklenen resimler hücre boyutunda olmamaktadır. Benim yapmak istediğim hangi hücreye çift tıklayarak resim almışsak aldığımız resimler o hücrelerin boyutunda olması. Bunun için kodlarda nasıl bir değişiklik yapılmalı. Şimdiden teşekkürler.

 

[huseyinvurkan]

cevabı mümkün olmayan bir soru mu? sordum diye merak ediyorum

 

[Merhum İdris SERDAR]

.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim sPicture As String, pic As Picture

sPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", _
, "Select Picture to Import")

If sPicture = "False" Then Exit Sub

Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic
.ShapeRange.LockAspectRatio = msoFalse
[COLOR="Red"].Height = ActiveCell.Height * 18
.Width = ActiveCell.Width * 5[/COLOR]
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.Placement = xlMoveAndSize
End With

Set pic = Nothing
End Sub

Bunu deneyin.

.

 

[tahsinanarat]

Aşağıdaki kodu deneyin

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim sPicture As String, pic As Picture
sPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", _
, "Select Picture to Import")
If sPicture = "False" Then Exit Sub
Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic
.ShapeRange.LockAspectRatio = msoFalse
[COLOR=red].Height = Target.Offset(0, 0).MergeArea.Height[/COLOR]
[COLOR=red].Width = Target.Offset(0, 0).MergeArea.Width[/COLOR]
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.Placement = xlMoveAndSize
End With
Set pic = Nothing
Range("F1").Select
End Sub

 

[huseyinvurkan]

Sayın yurttaş ve Sayın tahsinanarat ilgi ve emeğinize teşekkür ederim. saygılar

 

[sekhil]

hocam teşekkürler.. sayfanın her yerinde çift tıkladığımda resim dosyası çağırmakta
yazı eklemek/düzenlemek istediğimde çift tıkladığımda da resim çağırıyor haklı olarak

yalnızca A1:A1000 arası gibi bir değişken eklemek mümkün olurmu

yani resimi koydugum sütun genellikle A1 sütunu o yuzden diğerlerinde pasif olsun istiyorum

 

[Korhan Ayhan]

Koda aşağıdaki satırı ekleyerek sonuca gidebilirsiniz.

2. satıra ekleyip deneyiniz.

If Intersect(Target, Range("A1:A1000")) Is Nothing Then Exit Sub

 

[mahmut_m72]

arkadaşlar verdiğiniz kod çok işime yaradı elinize sağlık ancak gördüğünüz gibi dik çekilen resimlerde sorun var bunu nasıl düzelteceğiz

 

[Korhan Ayhan]

İki farklı kod paylaşılmış hangisinde bu sorunu yaşadınız?

 

[mahmut_m72]

İki farklı kod paylaşılmış hangisinde bu sorunu yaşadınız?

ikincisini kullandım üstadım tahsinanarat'ınkini

 

[Korhan Ayhan]

Ben şimdi denedim. Bir problem yaşamadım.

 

[mahmut_m72]

ben de tekrar tekrar deniyorum olmuyor malesef

 

[Korhan Ayhan]

Kullandığınız resim ve excel dosyasını sıkıştırıp foruma ekleyin bende deneme yapayım.

 

[mahmut_m72]

Kullandığınız resim ve excel dosyasını sıkıştırıp foruma ekleyin bende deneme yapayım.

üstad resimlerin boyutu büyüktü foruma yükleyemedim paint le %50 küçülttüm resmi bu sefer makro çalıştı. sanırım orjinal boyutu büyük olan dik fotoğraflarda sorun

 

[mahmut_m72]

başka resimlerle de denediğimde hep aynı

 

[mahmut_m72]

resimlere tıkladığımda dikey olanla yatay olanın tutamaçları farklı taraflarda bilmem bir anlam ifade ediyor mu

 

[Korhan Ayhan]

Birleştirilmiş hücrelerde de deneme yaptım. Bende sorun olmuyor.