Kodu Revize Etmek İçin Yardım (Resim Orijinal Boyutuyla gelsin)

[BedriA]

Arkadaşlar,

Aşağıdaki kod ile resimleri hücrelere yerleştiriyorum.
Yerleştirirken resmin boyutunu hücreye göre büyütmesin, küçültmesin,
sadece sol ve üst kenarlara hizalasın istiyorum.

Bunun için aşağıdaki kodda nasıl bir değişiklik yapmam gerekiyor acaba?


Selam ve saygılarımla.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Sheets("20k").Select

If Sheets("20k").Range("a1") = "x" And Sheets("20k").Range("b1") = "y" Then

If Intersect(Target, [D2:D100,G2:F100]) Is Nothing Then Exit Sub
yatay = 1 ' bu kadar hücre sağa kayacak
dikey = 0  ' bu kadar hücre aşağıya kayacak
Dim s1
Set s1 = Sheets(ActiveSheet.Name)
If InStr(Trim(ActiveWindow.RangeSelection.Address), ":") = 0 Then
Set Adres = s1.Cells(Target.Row + dikey, Target.Column + yatay)

Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then

Set yer = s1.Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column)
If yer.Address = Adres.Address Then
Picture.Delete
Exit For
End If
End If
Next Picture

ReDim uzanti(11)
uzanti(1) = "bmp":        uzanti(2) = "jpg"
uzanti(3) = "gif":        uzanti(4) = "png"
uzanti(5) = "jpeg"

For j = 1 To 5

dosya = ThisWorkbook.Path & "\Azmun\Sorular\" & Target.Value & "." & uzanti(Val(j))

If CreateObject("Scripting.FileSystemObject").FileExists(dosya) = True Then
ad = s1.Pictures.Insert(dosya).Name
s1.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse

s1.Shapes(ad).OLEFormat.Object.Top = Adres.Top
s1.Shapes(ad).OLEFormat.Object.Left = Adres.Left
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width
s1.Shapes(ad).OLEFormat.Object.Name = Target.Address
s1.Cells(Target.Row + 1, Target.Column).Select



Exit For
End If
Next
End If

Else

Exit Sub

End If
End Sub

 

[erdem_emre]

s1.Shapes(ad).OLEFormat.Object.[COLOR="red"]Top[/COLOR] = Adres.[COLOR="Red"]Top[/COLOR]
s1.Shapes(ad).OLEFormat.Object.[COLOR="red"]Left[/COLOR] = Adres[COLOR="red"].Left[/COLOR]
s1.Shapes(ad).OLEFormat.Object.ShapeRange.[COLOR="red"]Height[/COLOR] = Adres.[COLOR="red"]Height[/COLOR]
s1.Shapes(ad).OLEFormat.Object.ShapeRange.[COLOR="red"]Width[/COLOR] = Adres.[COLOR="red"]Width[/COLOR]

Top = üst
Left= sol
Height=yükseklik
Width= genişlik

buna göre istenmeyen bölümün prosedürünü silmek yeterli

 

[BedriA]

s1.Shapes(ad).OLEFormat.Object.[COLOR="red"]Top[/COLOR] = Adres.[COLOR="Red"]Top[/COLOR]
s1.Shapes(ad).OLEFormat.Object.[COLOR="red"]Left[/COLOR] = Adres[COLOR="red"].Left[/COLOR]
s1.Shapes(ad).OLEFormat.Object.ShapeRange.[COLOR="red"]Height[/COLOR] = Adres.[COLOR="red"]Height[/COLOR]
s1.Shapes(ad).OLEFormat.Object.ShapeRange.[COLOR="red"]Width[/COLOR] = Adres.[COLOR="red"]Width[/COLOR]

Top = üst
Left= sol
Height=yükseklik
Width= genişlik

buna göre istenmeyen bölümün prosedürünü silmek yeterli

Bunu denedim ama olmadı. Hücreye sığdırıyor bu şekilde.

 

[erdem_emre]

Kodun bu bölümünü silin

s1.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width

Hala yine istediğiniz olmuyorsa resimlerin piksel değerleri küçük olmalı
Piksel değerleri büyük resimleri ekleyin

 

[BedriA]

Kodun bu bölümünü silin

s1.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width

Hala yine istediğiniz olmuyorsa resimlerin piksel değerleri küçük olmalı
Piksel değerleri büyük resimleri ekleyin

Çok sağolun.
Dediğiniz satırları silince oldu.