• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Soru Hücre İçi Resim Ekleme Sorunu

T

Turkbey41

Katılım
23 Mayıs 2018
Mesajlar
105
Excel Vers. ve Dili
2019 Türkçe
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.
 
Son düzenleme:
Merhaba.
Excel 2019 versiyonunda hücre içine resim eklenemiyor.
 
Normal Ekle kısmından resim ekleden ekleyebiliyorum. Ben bunun makro ile yapılmasını istiyorum.
 
Deneyiniz.
Kod: 
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
 
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.

Muzaffer Ali' Alıntı:
Deneyiniz.
Kod: 
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
Genişletmek için tıkla ...
 
Bu kodu kullanın.

Kod: 
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
 
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.

Muzaffer Ali' Alıntı:
Bu kodu kullanın.

Kod: 
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
Genişletmek için tıkla ...
 
Muzaffer Ali' Alıntı:
Merhaba.
Excel 2019 versiyonunda hücre içine resim eklenemiyor.
Genişletmek için tıkla ...

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.
 
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
 
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.

khthonik' Alıntı:
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
Genişletmek için tıkla ...
 
Turkbey41' Alıntı:
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.
Genişletmek için tıkla ...

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 youtube.com
 
Sayfadaki tüm resimler için videoda bahsi geçen ayarları aşağıdaki kodla yapabilirsiniz.

C++: 
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
 
Hocam sayfaya resmi yükledikten sonra bu makroyu çalıştırınca resmi hücre içinde hala sürüklenebiliyor.
 
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
 
@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
 
Merhaba,

Deneyiniz.

C++: 
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
 
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.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst