Image nesnesine resim yapıştırmak?

[dEdE]

Merhaba Xl Dostları,

Aşağıdaki kodlarla sayfanın bir bölümünün resmini belleğe alıyorum. Bu resmi -harici bir dosya olarak kaydetmeden- UserForm üzerindeki Image1 nesnesine yapıştırabilir miyim?

Private Sub CommandButton1_Click()
    Range("A1:D8").Select
    Selection.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
    'Kopyaladığım bu resmi Userform üzerindeki Image1 nesnsesine yapıştırmak için nasıl bir kod yazmalıyım.
End Sub

 

[dEdE]

Merhaba,

Galiba Excel'in çıkmaz tünellerinden birine girdim.

 

[hamitcan]

Aşağıdaki linki inceleyin.
http://www.excel.web.tr/f48/secili-hucre-aralyoyny-resim-jpeg-olarak-kaydetme-t106905.html

 

[dEdE]

Teşekkürler Sayın Hamitcan,

Belirttiğiniz linki soruyu sormadan önce incelemiştim. Oradaki kodlarla resmi kaydedip, LoadPicture ile Image nesnesine aldıktan sonra Kill komutu ile siliyorum.
Sorun /Soru:
Her resim için HDD başvurmadan,- kopyalanan resmi bir dosya olarak kaydetmeden -bellekten Userform üzerindeki Image nesnesine yükleyebilir/yapıştırabilir miyiz?

Bu mümkün olursa; resimi kaydet/sil işlemine gerek kalmayacak, HDD ye başvurulmadığı için işlem süresi de kısalacak.

Teşekkürler.

 

[dEdE]

Özür dilerim, internetteki bir sorun nedeniyle mesaj 2. kez gönderildi.
Mükerrer mesaj
Tarafımdan silindi.

 

[snx111]

Banada lazım olmuştu. Hatta excelin içindeki dosyadan direk yapıştırayım diye düşünmüştüm onda bile Çare bulamadım..
Korhan beyin cevabıda hayır olmuştur..
Copy paste mecburen

Demeye kalmadı Halit beyin cevabı geldi

 

[halit3]

Merhaba Xl Dostları,

Aşağıdaki kodlarla sayfanın bir bölümünün resmini belleğe alıyorum. Bu resmi -harici bir dosya olarak kaydetmeden- UserForm üzerindeki Image1 nesnesine yapıştırabilir miyim?

Private Sub CommandButton1_Click()
    Range("A1:D8").Select
    Selection.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
    'Kopyaladığım bu resmi Userform üzerindeki Image1 nesnsesine yapıştırmak için nasıl bir kod yazmalıyım.
End Sub

Bir adet userform aç üstüne 1 adet image nesnesi ve CommandButton düğmesi ekle ve userformu açarken showmodal özelliğini false yap ve sayfada belli alanı bloke et ve komut düğmesine tıkla

Option Compare Text
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 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
 
Const CF_BITMAP = 2
Const CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
 
Function PastePicture(Optional lXlPicType As Long = xlPicture) As IPicture
Dim h As Long, hPicAvail As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long
lPicType = IIf(lXlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)
hPicAvail = IsClipboardFormatAvailable(lPicType)
If hPicAvail <> 0 Then
h = OpenClipboard(0&)
If h > 0 Then
hPtr = GetClipboardData(lPicType)
If lPicType = CF_BITMAP Then
hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Else
hCopy = CopyEnhMetaFile(hPtr, vbNullString)
End If
h = CloseClipboard
If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, lPicType)
End If
End If
End Function
Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture
Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture
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(lPicType = CF_BITMAP, 1, 4)
.hPic = hPic
.hPal = IIf(lPicType = CF_BITMAP, hPal, 0)
End With
r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
If r <> 0 Then Debug.Print "Create Picture: " & fnOLEError(r)
Set CreatePicture = IPic
End Function
Private Function fnOLEError(lErrNum As Long) As String
Select Case lErrNum
Case &H80004004
fnOLEError = " Aborted"
Case &H80070005
fnOLEError = " Access Denied"
Case &H80004005
fnOLEError = " General Failure"
Case &H80070006
fnOLEError = " Bad/Missing Handle"
Case &H80070057
fnOLEError = " Invalid Argument"
Case &H80004002
fnOLEError = " No Interface"
Case &H80004001
fnOLEError = " Not Implemented"
Case &H8007000E
fnOLEError = " Out of Memory"
Case &H80004003
fnOLEError = " Invalid Pointer"
Case &H8000FFFF
fnOLEError = " Unknown Error"
Case &H0
fnOLEError = " Success!"
End Select
End Function
 
Private Sub CommandButton1_Click()
Dim obMetafile As Long, lPicType As Long, oPic
lPicType = IIf(obMetafile, xlPicture, xlBitmap)
Range(ActiveWindow.RangeSelection.Address).CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Set oPic = PastePicture(lPicType)
Image1.Picture = oPic
End Sub

 

[Zeki Gürsoy]

Sanırım yaşlanıyorsunuz sayın dEdE Daha önce sormuş, ve yanıt almışsınız...

http://www.excel.web.tr/f48/secilen-aralyoyn-resmini-userform-uzerinde-gormek-t63962.html

 

[dEdE]

Sanırım yaşlanıyorsunuz sayın dEdE Daha önce sormuş, ve yanıt almışsınız...

Haklısınız Sayın Gürsoy,

Ancak "Sanırım.. " kısmı yanlış.
Yaşlandığım filan yok. Bu dünyaya geleli sace 61 yıl oldu.
Şaka bir tarafa, forumdaki mesajlarıma bakarsanız tam olarak 3 yıl 1 ay 27 gün hiç mesaj yaz(a)madığımı göreceksiniz.
İşin ilginç yanı konuyu hatırlamama karşın forumda yaptığım aramada bulamamış olmam.

Galiba yaşlılık böyle bir şey.
Teşekkürler.

Hoşçakalın.