Rastgele kopyanan resmi belirlenen hücre ölçülerine uygun hale getirip yapıştırma

[MESUT K]

Herkese Merhaba

excel dışında kopyaladığım bir imaj/resmi buton yardımı ile istediğim alana yapıştırmak istiyorum

Bilen üstadlarımdan yardım istiyorum.Saygılarımla

 

[MESUT K]

 

[yunus788]

Aşağıdaki kod daha önce forumda paylaşılmıştı, hücreye çift tıklayarak resim seçiyorsunuz ve o hücrenin boyutlarına göre otomatik sığdırılarak resim yukleniyor.Veya sizin istediğiniz alandaki hücreleri birleştirerek tek bir resim sığdırabilirsiniz örnek dosya ekte.

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")
'sPicture = ActiveCell.Value ' bu seçilirse aktif hücredeki adresteki resim yüklenir. yada hücre adresi belirtilirse o adresteki resim yüklenir

If sPicture = "False" Then Exit Sub
Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic
.ShapeRange.LockAspectRatio = msoFalse
.Height = Target.Offset(0, 0).MergeArea.Height
.Width = Target.Offset(0, 0).MergeArea.Width
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.Placement = xlMoveAndSize
End With
Set pic = Nothing
Range("F1").Select
End Sub

 

[Haluk]

Clipboard'da önceden kopyalanmış bir resim varsa;

Sub Test()
    Range("B3").PasteSpecial
    ActiveSheet.Shapes(Selection.Name).Width = Range("B3:F3").Width
    ActiveSheet.Shapes(Selection.Name).Height = Range("B3:B15").Height
    Selection.ShapeRange.LockAspectRatio = msoFalse
End Sub

.

 

[MESUT K]

Clipboard'da önceden kopyalanmış bir resim varsa;

Sub Test()
    Range("B3").PasteSpecial
    ActiveSheet.Shapes(Selection.Name).Width = Range("B3:F3").Width
    ActiveSheet.Shapes(Selection.Name).Height = Range("B3:B15").Height
    Selection.ShapeRange.LockAspectRatio = msoFalse
End Sub

.

Verdiğiniz kod tam istediğim gibi çalışıyor.butona bastığımda tam sarı alanın ortasına yerleştirebilirmiyiz.istediğim şekilde boyutu küçültüyor birde ortalarsa tamamdır

 

[MESUT K]

Aşağıdaki kod daha önce forumda paylaşılmıştı, hücreye çift tıklayarak resim seçiyorsunuz ve o hücrenin boyutlarına göre otomatik sığdırılarak resim yukleniyor.Veya sizin istediğiniz alandaki hücreleri birleştirerek tek bir resim sığdırabilirsiniz örnek dosya ekte.

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")
'sPicture = ActiveCell.Value ' bu seçilirse aktif hücredeki adresteki resim yüklenir. yada hücre adresi belirtilirse o adresteki resim yüklenir

If sPicture = "False" Then Exit Sub
Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic
.ShapeRange.LockAspectRatio = msoFalse
.Height = Target.Offset(0, 0).MergeArea.Height
.Width = Target.Offset(0, 0).MergeArea.Width
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.Placement = xlMoveAndSize
End With
Set pic = Nothing
Range("F1").Select
End Sub

Yardımınız ve ilginiz için çok teşekkür ederim kod tam işimi görmedi

 

[Haluk]

Hücre adreslerini kendinize göre değiştirerek küçültüp, yerleştirebilirsiniz.....