Sayfadan userform'a resim ekleme

Erdem Akdemir · 20 Ağustos 2014

Merhaba,

Sayfa1'de yer alan "Resim 1" isimli resmi userform'da image1'de nasıl gösterebilirim.

Murat OSMA · 20 Ağustos 2014

Bu kodları kullanabilirsiniz;

Kod:

[FONT="Trebuchet MS"]Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Private Type uPicDesc
    Size As Long
Type As Long
    hPic As Long
    hPal As Long
End Type
Private Declare Function IsClipboardFormatAvailable Lib "user32" ( _
        ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" ( _
        ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" ( _
        ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
        PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, _
        IPic As IPicture) As Long
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" ( _
        ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, _
        ByVal un1 As Long, ByVal n1 As Long, _
        ByVal n2 As Long, ByVal un2 As Long) As Long
Private Sub UserForm_Activate()
    Me.ComboBox1.ListIndex = 0
End Sub
Private Sub UserForm_Initialize()
Dim pic As Shape
    For Each pic In ActiveSheet.Shapes
        If pic.Type = msoPicture Then
            Me.ComboBox1.AddItem pic.Name
        End If
    Next pic
End Sub
Private Sub ComboBox1_Change()
    rTemp = ThisWorkbook.Path & "\" & Me.ComboBox1.Text & ".jpg"
    SavePicture PictureFromObject(ActiveSheet.Shapes(Me.ComboBox1.Text)), rTemp
    Me.Image1.Picture = LoadPicture(rTemp)
    Dim rtime As Date
    rtime = DateAdd("s", 10, Now())
    Kill rTemp
End Sub
Function PictureFromObject(Target As Object) As IPictureDisp
Dim hPtr As Long, PicType As Long, hCopy As Long
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Const PICTYPE_BITMAP = 1
Const PICTYPE_ENHMETAFILE = 4
    Target.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    PicType = IIf(IsClipboardFormatAvailable(CF_BITMAP) <> 0, _
            CF_BITMAP, CF_ENHMETAFILE)
    If IsClipboardFormatAvailable(PicType) <> 0 Then
        If OpenClipboard(0) > 0 Then
            hPtr = GetClipboardData(PicType)
            If PicType = CF_BITMAP Then
                hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
            Else
                hCopy = CopyEnhMetaFile(hPtr, vbNullString)
            End If
            CloseClipboard
            If hPtr <> 0 Then
                Dim uPicInfo As uPicDesc, IID_IDispatch As GUID, _
                        IPic As IPictureDisp
                With IID_IDispatch
                    .Data1 = &H7BF80980
                    .Data2 = &HBF32
                    .Data3 = &H101A
                    .Data4(0) = &H8B
                    .Data4(1) = &HBB
                    .Data4(2) = &H0
                    .Data4(3) = &HAA
                    .Data4(4) = &H0
                    .Data4(5) = &H30
                    .Data4(6) = &HC
                    .Data4(7) = &HAB
                End With
                With uPicInfo
                    .Size = Len(uPicInfo)
                    .Type = IIf(PicType = CF_BITMAP, _
                            PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)
                    .hPic = hCopy
                End With
                OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic
                Set PictureFromObject = IPic
            End If
        End If
    End If
End Function[/FONT]

Kod:

[FONT="Trebuchet MS"]Not: Sisteminize göre [COLOR="Red"]32Bit[/COLOR] olan [COLOR="red"]API[/COLOR]'leri [COLOR="red"]64Bit [/COLOR]olarak değiştirmeniz gerekebilir. [/FONT]

Örnek dosyayı da ekliyorum.

Erdem Akdemir · 20 Ağustos 2014

Murat hocam selamlar. Bir tane resim eklemek için neden bu kadar uzun bir kod gerekiyor.

Erdem Akdemir · 20 Ağustos 2014

32 bit Apileri 64 bit olarak nasıl değiştirebilirim.

halit3 · 20 Ağustos 2014

Alternatif link
ilgili link deki dosyanın userfom4 formunu irdeleyiniz.

http://www.excel.web.tr/f128/resim-gosterme-secenekleri-t90172.html

Murat OSMA · 21 Eylül 2014

kuvari' Alıntı:
Murat hocam selamlar. Bir tane resim eklemek için neden bu kadar uzun bir kod gerekiyor.

Image nesnesi her resim türünü kabul etmez, örneğin; .png formatı.
Kodlarda sayfadaki resim türü ne olursa olsun onu, kabul edilebilir olan .bmp formatına dönüştürüp Image nesnesine öyle ekliyoruz.

kuvari' Alıntı:
32 bit Apileri 64 bit olarak nasıl değiştirebilirim.

Ek'teki dosyayı indirip, API ismini arama yaparak bulduğunuz satırı kodlardaki satır ile değiştirebilirsiniz.

BedriA · 1 Temmuz 2017

Murat OSMA' Alıntı:

Bu kodları kullanabilirsiniz;

Kod:

[FONT="Trebuchet MS"]Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Private Type uPicDesc
    Size As Long
Type As Long
    hPic As Long
    hPal As Long
End Type
Private Declare Function IsClipboardFormatAvailable Lib "user32" ( _
        ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" ( _
        ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" ( _
        ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
        PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, _
        IPic As IPicture) As Long
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" ( _
        ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, _
        ByVal un1 As Long, ByVal n1 As Long, _
        ByVal n2 As Long, ByVal un2 As Long) As Long
Private Sub UserForm_Activate()
    Me.ComboBox1.ListIndex = 0
End Sub
Private Sub UserForm_Initialize()
Dim pic As Shape
    For Each pic In ActiveSheet.Shapes
        If pic.Type = msoPicture Then
            Me.ComboBox1.AddItem pic.Name
        End If
    Next pic
End Sub
Private Sub ComboBox1_Change()
    rTemp = ThisWorkbook.Path & "\" & Me.ComboBox1.Text & ".jpg"
    SavePicture PictureFromObject(ActiveSheet.Shapes(Me.ComboBox1.Text)), rTemp
    Me.Image1.Picture = LoadPicture(rTemp)
    Dim rtime As Date
    rtime = DateAdd("s", 10, Now())
    Kill rTemp
End Sub
Function PictureFromObject(Target As Object) As IPictureDisp
Dim hPtr As Long, PicType As Long, hCopy As Long
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Const PICTYPE_BITMAP = 1
Const PICTYPE_ENHMETAFILE = 4
    Target.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    PicType = IIf(IsClipboardFormatAvailable(CF_BITMAP) <> 0, _
            CF_BITMAP, CF_ENHMETAFILE)
    If IsClipboardFormatAvailable(PicType) <> 0 Then
        If OpenClipboard(0) > 0 Then
            hPtr = GetClipboardData(PicType)
            If PicType = CF_BITMAP Then
                hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
            Else
                hCopy = CopyEnhMetaFile(hPtr, vbNullString)
            End If
            CloseClipboard
            If hPtr <> 0 Then
                Dim uPicInfo As uPicDesc, IID_IDispatch As GUID, _
                        IPic As IPictureDisp
                With IID_IDispatch
                    .Data1 = &H7BF80980
                    .Data2 = &HBF32
                    .Data3 = &H101A
                    .Data4(0) = &H8B
                    .Data4(1) = &HBB
                    .Data4(2) = &H0
                    .Data4(3) = &HAA
                    .Data4(4) = &H0
                    .Data4(5) = &H30
                    .Data4(6) = &HC
                    .Data4(7) = &HAB
                End With
                With uPicInfo
                    .Size = Len(uPicInfo)
                    .Type = IIf(PicType = CF_BITMAP, _
                            PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)
                    .hPic = hCopy
                End With
                OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic
                Set PictureFromObject = IPic
            End If
        End If
    End If
End Function[/FONT]

Kod:

[FONT="Trebuchet MS"]Not: Sisteminize göre [COLOR="Red"]32Bit[/COLOR] olan [COLOR="red"]API[/COLOR]'leri [COLOR="red"]64Bit [/COLOR]olarak değiştirmeniz gerekebilir. [/FONT]

Örnek dosyayı da ekliyorum.

Murat Hocam,

Microsoft Equation 3.0 ile oluşturulan nesneyi de dönüştürüp bu kod ile görüntülemek mümkün mü?

Bunun yanı sıra, Combobox yerine SpinButton ile görüntülemek daha güzel olmaz mı?

tamer42 · Pazar saat 21:29'de

Murat OSMA' Alıntı:
Image nesnesi her resim türünü kabul etmez, örneğin; .png formatı.
Kodlarda sayfadaki resim türü ne olursa olsun onu, kabul edilebilir olan .bmp formatına dönüştürüp Image nesnesine öyle ekliyoruz.

Ek'teki dosyayı indirip, API ismini arama yaparak bulduğunuz satırı kodlardaki satır ile değiştirebilirsiniz.

Murat Hocam selamlar,
Öncelikle geçmiş bayramınız kutlu olsun;
Aşağıdaki satırda; ekli ekran görüntüsündeki hata mesajını veriyor.

Kod:

 OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic

Nasıl bir çözüm yolu öneririrsiniz.
Teşekkürler.

Korhan Ayhan · Pazartesi saat 01:03'de

Burada konuyla ilgili bazı bilgiler paylaşılmıştır. Sayfayı Türkçe'ye çevirip inceleyebilirsiniz.

Redirecting

tamer42 · Pazartesi saat 15:10'de

Korhan Ayhan' Alıntı:
Burada konuyla ilgili bazı bilgiler paylaşılmıştır. Sayfayı Türkçe'ye çevirip inceleyebilirsiniz.

Redirecting

Korhan Hocam teşekkürler,
ilgili siteyi inceledim yalnız bir türlü çözüme ulaşamadım.
Her şeyden önce sayfa içinde bulunan bir resimi userform' a getirmek bu kadar zor mudur?
Sayfada bulunan bir Grafiğiaşağıdaki kod çağırarak çok kolayca Userform' a getirebiliyoruz, yalnız resim olunca getiremiyoruz.
Sayfadaki resimler resim_1 , resim_2, resim-3, ...... şeklinde isimlendirilmiş durumda;

Şöyle bir durum olabilir mi? sayfaya boş bir Chart eklesek, bu chart' ın arka planını bu sayfadaki bir resim ile değiştirerek, Aşağıdaki fonksiyon ile Chart' ı Userform'a yüklesek olamaz mı?

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

Kod:

Public Sub LoadChart()

    Dim sTempFile As String
    Dim oChart As chart

    sTempFile = Environ("temp") & "\temp.gif"

    Set oChart = Worksheets("Rapor").ChartObjects("Chart-1").chart

    oChart.Export FileName:=sTempFile, FilterName:="GIF"

    frmMain.ImgChart.Picture = LoadPicture(sTempFile)

    frmMain.Repaint   '<<<<<

    Kill sTempFile

End Sub

Korhan Ayhan · Pazartesi saat 15:31'de

Bu bahsettiklerinizi deneyerek sonucu bizlerle paylaşabilirsiniz.

tamer42 · Pazartesi saat 17:11'de

Korhan Ayhan' Alıntı:
Bu bahsettiklerinizi deneyerek sonucu bizlerle paylaşabilirsiniz.

Korhan Hocam ekli dosyada; ekli ekran görüntüsündeki hata mesajını alıyorum.
yardımlarınız için şimdiden teşekkürler,

Korhan Ayhan · Pazartesi saat 17:17'de

İnceleyiniz...

Arama Sonuçları

Biolightant · Bugün 09:56

Merhaba, alternatif çözümü bu soruya yazacakken başka soruya cevap yazmışım
ilgili konu: https://www.excel.web.tr/threads/sayfadan-userforma-resim-ekleme.195913/#post-1195208

Sayfadan userform'a resim ekleme

Erdem Akdemir

Destek Ekibi

Murat OSMA

Altın Üye

Ekli dosyalar

Erdem Akdemir

Destek Ekibi

Erdem Akdemir

Destek Ekibi

halit3

Uzman

Murat OSMA

Altın Üye

Ekli dosyalar

BedriA

tamer42

Destek Ekibi

Ekli dosyalar

Korhan Ayhan

Administrator

tamer42

Destek Ekibi

Korhan Ayhan

Administrator

tamer42

Destek Ekibi

Ekli dosyalar

Korhan Ayhan

Administrator

Biolightant