Soru Hücre İçi Resim Ekleme Sorunu

[Turkbey41]

Merhaba,

Ayarlar isimli sayfada A4:B10 hücrelerini birleştirdim. Hücre içine resim yerleştirmek istiyorum ama yaptığım tüm makrolarda hücre üzerine ekliyor.

Bu konu için vba kodu paylaşabilecek kimse varsa çok teşekkür ederim.

Örnek Dosya Linki : ornek-dosya-1.xlsm - 16 KB

Kolay gelsin.

 

[Muzaffer Ali]

Merhaba.
Excel 2019 versiyonunda hücre içine resim eklenemiyor.

 

[Turkbey41]

Normal Ekle kısmından resim ekleden ekleyebiliyorum. Ben bunun makro ile yapılmasını istiyorum.

 

[Muzaffer Ali]

Deneyiniz.

Sub Test()
    Dim Rsm As Object
    Dim ResimYolu As String
    
    ResimYolu = "C:\Foto1.jpg" 'Buraya kendi fotoğrafınızın yolunu girin.
    
    Set Rsm = ActiveSheet.Pictures.Insert(ResimYolu)
    Rsm.Left = Range("A4").MergeArea.Left
    Rsm.Top = Range("A4").Top
    Rsm.Height = Range("A4").MergeArea.Height
End Sub

 

[Turkbey41]

Hocam teşekkür ederim ama dosya yolunu kod içinde istemiyorum. düğmeye tıklandığında bilgisayardan herhangi bir resmi seçip yükleyebilmek istiyorum.

Deneyiniz.

Sub Test()
    Dim Rsm As Object
    Dim ResimYolu As String
   
    ResimYolu = "C:\Foto1.jpg" 'Buraya kendi fotoğrafınızın yolunu girin.
   
    Set Rsm = ActiveSheet.Pictures.Insert(ResimYolu)
    Rsm.Left = Range("A4").MergeArea.Left
    Rsm.Top = Range("A4").Top
    Rsm.Height = Range("A4").MergeArea.Height
End Sub

 

[Muzaffer Ali]

Bu kodu kullanın.

Sub Test()
    Dim Rsm As Object
    Dim ResimYolu As String
    
    ResimYolu = Application.GetOpenFilename()
    If ResimYolu = "" Or ResimYolu = False Then Exit Sub
    
    Set Rsm = ActiveSheet.Pictures.Insert(ResimYolu)
    Rsm.Left = Range("A4").MergeArea.Left
    Rsm.Top = Range("A4").Top
    Rsm.Height = Range("A4").MergeArea.Height
End Sub

 

[Turkbey41]

Teşekkür ederim ama görseli yine hücrelerin üzerine ekledi. Ben resmi hücre içine eklemek istiyorum. Filtreme yaparken ilgili satırdaki resmin de değişmesini istiyorum.

Bu kodu kullanın.

Sub Test()
    Dim Rsm As Object
    Dim ResimYolu As String
   
    ResimYolu = Application.GetOpenFilename()
    If ResimYolu = "" Or ResimYolu = False Then Exit Sub
   
    Set Rsm = ActiveSheet.Pictures.Insert(ResimYolu)
    Rsm.Left = Range("A4").MergeArea.Left
    Rsm.Top = Range("A4").Top
    Rsm.Height = Range("A4").MergeArea.Height
End Sub

 

[Muzaffer Ali]

Merhaba.
Excel 2019 versiyonunda hücre içine resim eklenemiyor.

Yukarıda böyle söylemiştim. Sizin Excel versiyonu da 2019 olduğuna göre hücre içine resim ekleyemezsiniz. Kod ile, makro ile yada menüden hiçbir şekilde hücre içine ekleyemezsiniz.

 

[khthonik]

Sub InsertPicture()
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

Sheets("Ayarlar").Select
Adres = Sheets("Ayarlar").Range("A4:B10").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 - 4
.Width = Range(Adres).Width - 4
.Top = Range(Adres).Top + 2
.Left = Range(Adres).Left + 2
.Placement = xlMoveAndSize
End With

Set pic = Nothing

End Sub

 

[Turkbey41]

Hocam çok teşekkür ederim ama yine hücrelerin üzerine ekledi. Belirtilen boyutta ve doğru yere ekledi ama hücre içine gömülü olmadı. Olmadı başka çözüm bulacağım.

Sub InsertPicture()
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

Sheets("Ayarlar").Select
Adres = Sheets("Ayarlar").Range("A4:B10").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 - 4
.Width = Range(Adres).Width - 4
.Top = Range(Adres).Top + 2
.Left = Range(Adres).Left + 2
.Placement = xlMoveAndSize
End With

Set pic = Nothing

End Sub

 

[Korhan Ayhan]

Teşekkür ederim ama görseli yine hücrelerin üzerine ekledi. Ben resmi hücre içine eklemek istiyorum. Filtreme yaparken ilgili satırdaki resmin de değişmesini istiyorum.

Videoyu inceleyiniz.

- YouTube

Enjoy the videos and music you love, upload original content, and share it all with friends, family, and the world on YouTube.

youtube.com

 

[Turkbey41]

Teşekkür ederim harika bir video. Ama benim istediğim bu işlemleri makro ile tek seferde yapsın.

Videoyu inceleyiniz.

- YouTube

Enjoy the videos and music you love, upload original content, and share it all with friends, family, and the world on YouTube.

youtube.com

 

[Korhan Ayhan]

Sayfadaki tüm resimler için videoda bahsi geçen ayarları aşağıdaki kodla yapabilirsiniz.

Option Explicit

Sub Editing_All_Picture_()
    Dim My_Picture As Object

    For Each My_Picture In ActiveSheet.Pictures
        My_Picture.ShapeRange.LockAspectRatio = msoFalse
        My_Picture.Placement = xlMoveAndSize
    Next
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Turkbey41]

Hocam sayfaya resmi yükledikten sonra bu makroyu çalıştırınca resmi hücre içinde hala sürüklenebiliyor.

 

[Korhan Ayhan]

Mesajımda bunu ifade etmiştim...

Videoda anlatılan özelliklerin makro kodudur..

Eğer siz resmin hareket etmesini istemiyorsanız aşağıdaki kod satırını bir sonrakiyle değiştirebilirsiniz.

My_Picture.Placement = xlMoveAndSize

Olması gereken;

My_Picture.Placement = xlMove

 

[Turkbey41]

@Korhan Ayhan Hocam teşekkür ederim. Örnek dosya ekliyorum. Burada resmin birleştirilmiş hücrelere eklenmesi gerekiyor. (A4:B10).

Ayrıca üstte resim yüklemek için üstteki makro butonu ile resim yüklenebilecek, ikinci bir makro ile de resim hücre içine yerleştirilecek. Tek makro ile mümkün değilse iki farklı makro ile de olmasında sorun yok.

Şimdiden teşekkür ederim.

Örnek Dosya Linki : ornek-dosya-1.xlsm - 16 KB

 

[Korhan Ayhan]

Merhaba,

Deneyiniz.

Option Explicit

Sub Insert_Picture()
    Dim My_Cell As Range
    Dim Select_Shape As Variant
    Dim My_Shape As Variant
    
    Select_Shape = Application.GetOpenFilename _
    ("Pictures (*.gif; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", _
    , "Lütfen Eklemek İstediğiniz Resim Dosyasını Seçiniz...")

    If Select_Shape = False Then Exit Sub
    
    Set My_Cell = Range("A4:B10")
    
    For Each My_Shape In ActiveSheet.Shapes
        If Not Intersect(My_Shape.TopLeftCell, My_Cell) Is Nothing Then
            My_Shape.Delete
        End If
    Next
   
    Set My_Shape = ActiveSheet.Pictures.Insert(Select_Shape)
    
    With My_Shape
        .Name = "Picture 1"
        .ShapeRange.LockAspectRatio = msoFalse
        .Left = My_Cell.Left
        .Top = My_Cell.Top
        .Height = My_Cell.Height
        .Width = My_Cell.Width
        .ShapeRange.LockAspectRatio = msoTrue
    End With
        
    For Each My_Shape In ActiveSheet.Shapes
        DoEvents
        My_Shape.Select
        DoEvents
        My_Shape.PlacePictureInCell
    Next

    Application.CommandBars("Format Object").Visible = False

    Set My_Shape = Nothing
    Set My_Cell = Nothing
End Sub

 

[Turkbey41]

@Korhan Ayhan hocam teşekkür ederim ama resmi yüklediğimde hala sağa sola sürüklenebiliyor.

 

[Korhan Ayhan]

Ben Ofis 365 sürümünü kullanıyorum. Resim hücre içine gömüldükten sonra dediğiniz sürükleme olayı bende olmuyor.