Sol üst köşesi sabitlenmiş resim getirme

[Tevfik_Kursun]

Merhaba Arkadaşlar,
Ekli dosyadaki makro, daha önce Halit3 Hocamın hazırladığı bir çalışma idi. Aynı büyüklükteki resimleri dört köşesi sabitlenmiş (aynı) bölgeye getiriyor. Bu çalışma farklı büyüklükte resimlerden oluşuyor. Sadece soldan ve üstten dayayabilmek için makroda nasıl bir değişiklik yapmalıyım. (Sol üst köşeyi E13 hücresine getirerek göstermek için)
Saygılarımla

 

[halit3]

Bunu denermisiniz.

Sub resim_getir()

sat1 = 13
sat2 = 21
sut1 = "E"
sut2 = "M"

Set Adres = Range(Cells(sat1, sut1), Cells(sat2, sut2))
Set Adres2 = Cells(sat2, sut2)
Dim yer
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes

If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
yer = Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column).Address

yer1 = Adres2.Address
If yer = yer1 Then
Picture.Delete
Exit For
End If
End If
Next Picture

son = 6
ReDim uzanti(son)
uzanti(1) = ".jpg"
uzanti(2) = ".JPG"
uzanti(3) = ".bmp"
uzanti(4) = ".BMP"
uzanti(5) = ".gif"
uzanti(6) = ".GİF"

Klasor = ThisWorkbook.Path & "\GeoFoto\"

isim = Cells(9, "E").Value

For j = 1 To son
Dosya = Klasor & isim & uzanti(j)
If CreateObject("Scripting.FileSystemObject").FileExists(Klasor & isim & uzanti(j)) = True Then
'ActiveSheet.Shapes.AddPicture Dosya, msoFalse, msoCTrue, Adres.Left + 2, Adres.Top + 2, Adres.Width - 4, Adres.Height - 4
ad = ActiveSheet.Pictures.Insert(Dosya).Name
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
ActiveSheet.Shapes(ad).OLEFormat.Object.Top = Adres.Top + 2
ActiveSheet.Shapes(ad).OLEFormat.Object.Left = Adres.Left + 2
'ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height - 2
'ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width - 2
ActiveSheet.Cells(8, "G").Select
Exit For
End If
Next
'MsgBox "İşlem tamam"
End Sub

 

[Tevfik_Kursun]

İlginize çok teşekkür ederim Halit3 Hocam,
Denedim güzel çalışıyor. Yalnız yeni resim getirirken mevcut resmi silmiyor. Bunu da ekler misiniz, lütfen?
Saygılarımla

 

[Tevfik_Kursun]

Merhaba Halit3 Hocam,

Sub Resim_Sil()
Dim Picture As Object
    For Each Picture In ActiveSheet.Shapes
    If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
        Picture.Delete
        Exit For
    End If
    Next Picture
End Sub

Bu makroyu buldum sanırım bunu da siz hazırlamıştınız. İş gördü.
Tekrar ilginize çok teşekkür ederim.
Saygılarımla

 

[halit3]

kod:

Sub resim_getir()

sat1 = 13
sut1 = "E"

Set Adres = Cells(sat1, sut1)

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
If Adres.Address = Picture.TopLeftCell.Address Then
Picture.Delete
Exit For
End If
End If
Next Picture


son = 6
ReDim uzanti(son)
uzanti(1) = ".jpg"
uzanti(2) = ".JPG"
uzanti(3) = ".bmp"
uzanti(4) = ".BMP"
uzanti(5) = ".gif"
uzanti(6) = ".GİF"

Klasor = ThisWorkbook.Path & "\GeoFoto\"

isim = Cells(9, "E").Value

For j = 1 To son
Dosya = Klasor & isim & uzanti(j)
If CreateObject("Scripting.FileSystemObject").FileExists(Klasor & isim & uzanti(j)) = True Then
ad = ActiveSheet.Pictures.Insert(Dosya).Name
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
ActiveSheet.Shapes(ad).OLEFormat.Object.Top = Adres.Top + 2
ActiveSheet.Shapes(ad).OLEFormat.Object.Left = Adres.Left + 2
ActiveSheet.Cells(8, "G").Select
Exit For
End If
Next
End Sub

 

[Tevfik_Kursun]

Tekrar teşekkür ederim.
Saygılarımla