marcopasha99
Yeni Üye
- Katılım
- 28 Kas 2021
- Mesajlar
- 1
- En iyi yanıt
- 0
- Puanları
- 1
- Yaş
- 46
- Konum
- İstanbul
- Ad Soyad
- Volkan Akbaba
- Office Vers.
- 2013
eğerli üstadlar,
Bende hücreye göre resimi boyutlandırma hususunda müzdaribim ve yardımlarınızı rica ediyorum.
A1 ile Z5000 hücre aralığında herhangi bir hücreye Resim klasorü icindeki resimlerden birinin adını yazınca otomatik olarak resmi getirsin, örnekteki gibi kenarlık yapsın ve o hücreye orantılı bir şekilde sığdırmasını istiyorum.
Biraz araştırdım ve aşağıdaki gibi bir kod buldum ama isteğime tam olarak cevap vermedi.
İlginize şimdiden teşekkür ediyorum.
Bende hücreye göre resimi boyutlandırma hususunda müzdaribim ve yardımlarınızı rica ediyorum.
A1 ile Z5000 hücre aralığında herhangi bir hücreye Resim klasorü icindeki resimlerden birinin adını yazınca otomatik olarak resmi getirsin, örnekteki gibi kenarlık yapsın ve o hücreye orantılı bir şekilde sığdırmasını istiyorum.
Biraz araştırdım ve aşağıdaki gibi bir kod buldum ama isteğime tam olarak cevap vermedi.
İlginize şimdiden teşekkür ediyorum.
C++:
Sub Resim_Ekle()
Dim sPicture As String, pic As Picture
sPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", _
, "Select Picture to Import")
If Val(Len(sPicture)) = 0 Then Exit Sub
Adres = ActiveWindow.RangeSelection.Address
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
yer1 = Picture.TopLeftCell.Address
yer2 = (Picture.TopLeftCell.Address & ":" & Picture.BottomRightCell.Address)
If yer1 = Adres Or yer2 = Adres Then
Picture.Delete
Exit For
End If
End If
Next Picture
Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic
.ShapeRange.LockAspectRatio = msoFalse
.Height = Range(Adres).Height - 14
.Width = Range(Adres).Width - 14
.Top = Range(Adres).Top + 7
.Left = Range(Adres).Left + 7
.Placement = xlMoveAndSize
End With
Set pic = Nothing
End Sub
Moderatör tarafında düzenlendi:
