Sayfadan UserForma Resim Getirme Taşıma - Image Transporter

[Biolightant]

Kodlar Sayfada ki Hücre Resimlerini veya Direk Resimi(Çizimi) Userforma Taşıma işlemini yapar.

Kullanım şekli :
AddressOrShapeName = Sayfada ki Resim(Çizim) ADı veya Hücre ADRESi
TargetImage = Picture si değişecek UserForm üzerinde ki Controlün ADı

Örnek Kullanım :
Call ImageTransporter("A1:C10", Me.Image1)
Call ImageTransporter("EXCEL QR", Me.Image1)

ÖRNEK uygulama Dosyası : ImageTransporter.xlsm

Option Explicit

Private Sub CommandButton1_Click()
    Call ImageTransporter("A1:C10", Me.Image1)
End Sub

Private Sub CommandButton2_Click()
    Call ImageTransporter("EXCEL QR", Me.Image1)
End Sub

Private Sub ImageTransporter(AddressOrShapeName As Variant, TargetImage As Object)
' Orjin by @Korhan Ayhan - www.excel.web.tr
' Revised by biolightant@gmail.com 2025
' Eppur Si Muove

' Kullanım şekli :
' AddressOrShapeName = Sayfada ki Resim(Çizim) ADı veya Hücre ADRESi
' TargetImage = Picture si değişecek UserForm üzerinde ki Controlün ADı
'
' Örnekler :
' Call ImageTransporter("A1:C10", Me.Image1)
' Call ImageTransporter("EXCEL QR", Me.Image1)
  
    Dim HasPictureProperty As Boolean
    Dim TargetObject As Object
    Dim Grafik As Object
  
    Dim FotoAdres As String
    ' Temp dosyasına kaydedilecek resim yolu
    FotoAdres = Environ$("temp") & "\ExcelImage.jpg" ' daha kalitelisi .bmp
  
    Dim SonHucre As Range
    Set SonHucre = Cells(Rows.Count, Columns.Count) ' Gözden ırak
  
    ' TargetImage nesnesinin Picture özelliğine sahip olup olmadığını kontrol et
    On Error Resume Next
        HasPictureProperty = Not IsNull(TargetImage.Picture)
    On Error GoTo 0
  
    If Not HasPictureProperty Then
        MsgBox TargetImage.Name & " Picture özelliğine sahip değil.", vbExclamation, "Hata"
        Exit Sub
    End If
  
    On Error Resume Next
    ' Öncelikle şekil adını kontrol et
    Set TargetObject = ActiveSheet.Shapes(AddressOrShapeName)
    If TargetObject Is Nothing Then
        ' Çoklu Hücre aralığı ("A1:B2,B9:C10") kabul edilmez
        If InStr(1, AddressOrShapeName, ",") = 0 Then
            ' Şekil yoksa hücre adresini kontrol et
            Set TargetObject = Range(AddressOrShapeName)
        End If
    End If
    On Error GoTo 0
  
    If Not TargetObject Is Nothing Then
        ' Resim olarak kopyala, yapıştır ve kes
        TargetObject.CopyPicture xlScreen, xlBitmap
        ActiveSheet.Paste
        Selection.Cut
      
        ' Grafik nesnesi oluştur
        Set Grafik = ActiveSheet.ChartObjects.Add(Left:=SonHucre.Left, Top:=SonHucre.Top, Width:=1, Height:=1)
      
        ' Grafik içine kestiğimiz resmi yapıştırıp
        ' ve resim olarak dışarı çıkart
        With Grafik
            .Activate
            .Chart.Paste
            .Width = TargetObject.Width
            .Height = TargetObject.Height
            .Chart.Export FotoAdres ' Resmi bilgisayara kaydet
            .Delete ' Grafiği sil
        End With
      
        TargetImage.Picture = LoadPicture(FotoAdres) ' Işınla beni, Scotty
      
        ' Geçici dosyayı(resmi) sil
        On Error Resume Next
            Kill FotoAdres
        On Error GoTo 0
    Else
        MsgBox "Geçerli bir AD ya da ADRES giriniz.", vbExclamation, "Hata"
    End If
End Sub

 

[walabi]

Paylaşım için teşekkürler, deniz derya excel.

 

[Biolightant]

Paylaşım için teşekkürler, deniz derya excel

Teşekkürler.