Resim Boyutunu Sabitleme

[askm]

Aşağıdaki kodlar ile resimleri hücreye getirmekteyim. Yalnız resimler her biri resmin özelliğine göre değişik boyutta çıkmakta. Bu resmin boyutunu sabitleyebilir miyim.

Sub Resim_Ekleme()
Dim p As Object, t As Double, l As Double, w As Double, h As Double

Range("d1").Select
Range("d1").ClearContents

ActiveSheet.Pictures.Delete
Resimadi = LoadPicture("")
Resimadi = Range("B2").Text & ".jpg"


On Error Resume Next
Set pic = ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\FOTOLAR\" & Resimadi)
On Error GoTo 0

ResimDosya = ThisWorkbook.Path & "\FOTOLAR\" & Resimadi


For Each p In ActiveSheet.Pictures
p.Delete
Next

If Dir(ResimDosya) = "" Then
ResimDosya = ThisWorkbook.Path & "\FOTOLAR\ResimYok.jpg"
Set p = ActiveSheet.Pictures.Insert(ResimDosya)
Else
Set p = ActiveSheet.Pictures.Insert(ResimDosya)
End If

Set Rng = ActiveCell

With Range("d1") 'Cells(Target.Row, Target.Column - 2)

t = .Top
l = .Left
w = 120 '.Width '.Offset(0, .Columns.Count).Left - .Left
h = 120 '.Height '.Offset(.Rows.Count, 0).Top - .Top
End With
With p
.Top = t
.Left = l
.Width = 120 'w
.Height = 120 ' h
End With
Set p = Nothing
End Sub

 

[muygun]

Merhaba;
Ekli dosyadaki her iki sayfanın kodlarını inceleyin ve kendi dosyanıza uyarlayın.
İyi çalışmalar.

 

[askm]

Set Rng = Range("d1:d2")
With p
.Height = Rng.Height
.Width = Rng.Width
.Left = Rng.Left
.Top = Rng.Top
End With


bu şekilde deneyince d4 e kadar resim büyüyor.Yani boyu büyük oluyor. Ama d hücresi dışına çıkmıyor.Yapmaya çalıştığım d1:d2 birleştirdim. Bunlara çerçeve çizdim. Bu çerçeve içerisine resmi almak.


With Range("d1:d2")
p.Top = .Top
p.Left = .Left
p.Width = .Width 'w
p.Height = .Height ' h
End With
Bu şekilde yapınca da yükseklik d1:d2 oluyor ama eni küçük oluyor.

 

[askm]

With [D1]
t = Range("d1:d2").Top
l = Range("d1:d2").Left
w = Range("d1:d2").Width ' .Offset(0, .Columns.Count).Left - .Left
h = Range("d1:d2").Height '.Offset(.Rows.Count, 0).Top - .Top

End With
' Position Picture
With p
.ShapeRange.LockAspectRatio = msoFalse
.Top = t
.Left = l
.Width = w
.Height = h
.Placement = xlMoveAndSize
End With

bu kodlar ile yaptım teşekkürler.

 

[Baggwell]

Merhaba;
Ekli dosyadaki her iki sayfanın kodlarını inceleyin ve kendi dosyanıza uyarlayın.
İyi çalışmalar.

Sizin dosyanızda resim al butonuna tıklayınca resimler gidiyor neden öyle oluyor ki

 

[askm]

belirtilen adreste dosya veya resim olmadığı için gidiyor.

 

[askm]

Aşağıdaki şekilde hücredeki fotoları silip yenisini getiriyorum . Yalnız ağa açtığım zaman resim silmiyor ve gelmiyor. Yani makro çalışmıyor. Çalışması için ne yapabilirim.
Sub resimal_1()
Dim resim As Picture, Alan As Range
Set Alan = Range("b1:b11")
For Each resim In ActiveSheet.Pictures
If Not Intersect(resim.TopLeftCell, Alan) Is Nothing Then
resim.Delete
End If
Next
Set Alan = Nothing
Range("B1").Select
Resimadi = LoadPicture("")
Resimadi = Range("a1").Text & ".jpg"

For Each p In ActiveSheet.Pictures
p.Delete
Next

On Error Resume Next
ActiveSheet.Pictures.Insert (ThisWorkbook.Path & "\FOTO\" & Resimadi)

With [D1]
t = Range("d1:d2").Top
l = Range("d1:d2").Left
w = Range("d1:d2").Width ' .Offset(0, .Columns.Count).Left - .Left
h = Range("d1:d2").Height '.Offset(.Rows.Count, 0).Top - .Top

End With
' Position Picture
With p
.ShapeRange.LockAspectRatio = msoFalse
.Top = t
.Left = l
.Width = w
.Height = h
.Placement = xlMoveAndSize
End With


'Selection.ShapeRange.LockAspectRatio = msoFalse
''Selection.ShapeRange.Height = 110
''Selection.ShapeRange.Width = 145
'Selection.ShapeRange.Rotation = 0#
'Range("h1").Select
End Sub

 

[askm]

Paylaşımda neden çalışmıyor kod bilgisi olan var mı.