Excel hücresine formül ile resim alma

[tamer42]

Merhaba,

"C:\Temp\"
klasörü altında isimlendirilmiş jpeg resimler mevcut,
Ekli dosyada "A" sütununda yazılmış dosya adlarına (*.jpg) göre B sütununa formül yoluyla gelmesi,

teşekkürler,
iyi Çalışmalar.

 

[tamer42]

Merhaba,

"C:\Temp\"
klasörü altında isimlendirilmiş jpeg resimler mevcut,
Ekli dosyada "A" sütununda yazılmış dosya adlarına (*.jpg) göre B sütununa formül yoluyla gelmesi,

teşekkürler,
iyi Çalışmalar.

Arkadaşlar tekrar merhaba,

Bu konuyla ilgili IMAGE fonkisyonu buldum ama sanırım Microsoft 365 de çalışıyor,
bu fonksiyonu kod ile kullanıcı tanımlı fonksiyon olarak oluşturamaz mıyız?

https://www.ablebits.com/office-addins-blog/excel-image-function/


Teşekkürler,
iyi geceler.

 

[Korhan Ayhan]

Aşağıdaki fonksiyon geliştirilebilir.

=K_PICTURE(Resim_Dosya_Yolu;Resim_Adı;Resim Boyutu;Resim_Yüksekliği;Resim_Genişliği)

Kalın yazı fontu ile belirtilen parametreler opsiyoneldir. Yani boş bırakabilirsiniz.

Resim_Adı = Sayfada resime vermek istediğiniz isimdir. (Örnek Resim-1)
Resim_Boyutu = 0-1-2-3 parametrelerine göre çalışır.

0 = Hücreye resmin orjinal boyutuna sadık kalarak küçülterek sığdırır. Resim dikey ve yataydan hücrenin ortasında görünür.
1 = Hücreyi doldurarak resmi konumlandırır.
2 = Resmi orjinal boyutu ile hücreye ekler.
3 = Kişisel ölçü vererek resmi siz boyutlandırabilirsiniz. (Varsayılan olarak 100x100 olarak ayarladım.)

Spoyler: Excel Resim Fonksiyonu (KTF-UDF)

Option Explicit

Function K_PICTURE(File_Path As String, _
                   Optional Picture_Name As Variant = "", _
                   Optional Picture_Size As Byte = 0, _
                   Optional Picture_Height As Double = 100, _
                   Optional Picture_Width As Double = 100)
    
    Dim My_Picture As Variant, Rng As Range
    
    Application.ScreenUpdating = False
    Application.Volatile True
    
    Set Rng = Range(Application.Caller.Address)
    
    For Each My_Picture In Sheets(Application.Caller.Parent.Name).Shapes
        If TypeName(My_Picture.OLEFormat.Object) = "Picture" Then
            If Not Intersect(My_Picture.TopLeftCell, Rng) Is Nothing Then
                My_Picture.Delete
            End If
        End If
    Next

    Set My_Picture = ActiveSheet.Pictures.Insert(File_Path)
 
    With My_Picture
        .Name = IIf(Picture_Name <> "", Picture_Name, .Name)
        Select Case Picture_Size
            Case 0
                .ShapeRange.LockAspectRatio = msoTrue
                .Height = Rng.Offset(0, 0).MergeArea.Height
                .Top = Rng.Top + Rng.Height / 2 - .Height / 2
                .Left = Rng.Left + Rng.Width / 2 - .Width / 2
                .Placement = xlMoveAndSize
            Case 1
                .ShapeRange.LockAspectRatio = msoFalse
                .Height = Rng.Offset(0, 0).MergeArea.Height
                .Width = Rng.Offset(0, 0).MergeArea.Width
                .Top = Rng.Top
                .Left = Rng.Left
                .Placement = xlMoveAndSize
            Case 2
                .ShapeRange.LockAspectRatio = msoTrue
            Case 3
                .ShapeRange.LockAspectRatio = msoFalse
                .Height = Picture_Height
                .Width = Picture_Width
                .Top = Rng.Top + Rng.Height / 2 - .Height / 2
                .Left = Rng.Left + Rng.Width / 2 - .Width / 2
                .Placement = xlMoveAndSize
        End Select
    End With
    
    Set Rng = Nothing
    Set My_Picture = Nothing
    
    Application.ScreenUpdating = True
End Function

 

[tamer42]

Koray Hocam çok teşekkürler,
iyi ki varsınız!

 

[turgayzeynep]

Hocam tasarlayamadım kafam karıştı
c1 hücresinde foto ekle resmi olcak ve tıklayınca masa üstünden fotoyu eklemam lazım kısacası hocam sizdan rıcam c1 hücresine göre bir formül yazürmısınız

 

[Korhan Ayhan]

Dosyaniza boş bir modül ekleyiniz.

Önerdiğim fonksiyon kodlarını eklediğiniz modüle yapıştırınız. Son olarak dosyanızı Makro İçerebilen Excel Çalışma Kitabı biçiminde kayıt edin.

Daha sonra resmi getirmek istediğiniz hucreye =K_PICTURE(C1) şeklinde yazıp sonuç alabilirsiniz.

C1 hücresinde resmin bulunduğu klasör yolunun yazılı olduğunu varsaydım.

Örnek;
C:\Resimler\

 

[turgayzeynep]

Ya hocam Allah aşkına Allah rızası için şunu bir Düzgünce bir kod yazıp bana bir atar mısınız bir türlü tasarlayamadım
Fotoyu masa üstünden alacam hocam c1 hücre

 

[turgayzeynep]

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim p As Object, t As Double, l As Double, w As Double, h As Double Sheets(1).Pictures.Delete Application.Dialogs(xlDialogInsertPicture).Show Set p = ActiveSheet.Pictures(1) With Range("D1") t = .Top l = .Left w = .Offset(0, .Columns.Count).Left - .Left h = .Offset(.Rows.Count, 0).Top - .Top End With With p .Top = t .Left = l .Width = w .Height = h End With With [D1] Shapes(1).Left = .Left + ((.Width - Shapes(1).Width) / 2) Shapes(1).Top = .Top + ((.Height - Shapes(1).Height) / 2) End With End Sub


Hocam fotografın hücreye göre otomatik sığmasını istiyorum makroyu uyarlayıp atarmısınız

 

[yusuf1284]

Ben böyle bişey yapmıştım.

Sub foto_getir_1()
'' ilk olarak yüklü olan Resimleri silelim DİKKAT Sayfada olan tüm objeleri siler
   ActiveSheet.DrawingObjects.Delete


''herhangi bir hata oluşursa Çıkış labelına git
On Error GoTo Çıkış:
Dim ResimDosyaYolu As String
Dim Resim As Object


For i = 2 To 74
  
    If i > 73 Then
        Exit Sub
    End If
  
    If Range("M" & i + 1).Value = "" Then
        GoTo sonraki
    End If
  
    ResimDosyaYolu = ActiveWorkbook.Path & "\" & "PER_FOTO" & "\" & Range("M" & i + 1) & ".jpg"

    'dosya yok ise hataya düşmemek için aşağıdaki kontrolü yapıyoruz.
    If DosyaVarmi(ResimDosyaYolu) Then
         ResimDosyaYolu = ActiveWorkbook.Path & "\" & "PER_FOTO" & "\" & Range("M" & i + 1) & ".jpg"
        Else
           ResimDosyaYolu = ActiveWorkbook.Path & "\" & "PER_FOTO" & "\yok.jpg"
    End If
      
'    'resmi oluşturuyoruz.
     Set Resim = ActiveSheet.Pictures.Insert(ResimDosyaYolu)
     'Resmi boyutlandırıyoruz
     With Range("A" & i)
        Resim.Top = .Top + 1
        Resim.Left = .Left + 1
        Resim.Height = .Height + 15
        Resim.Width = .Width + 17
     End With
i = i + 3
sonraki:
Next i

Çıkış:
End Sub