- Katılım
- 24 Temmuz 2019
- Mesajlar
- 413
- Excel Vers. ve Dili
- EXCEL 2010 TÜRKÇE
- Altın Üyelik Bitiş Tarihi
- 25-12-2023
Kod:
#If Win64 Then
Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" _
(ByVal lpLibFileName As String) As LongPtr
Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
Private Declare PtrSafe Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" _
(PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
Private Declare PtrSafe Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" _
(PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As LongPtr
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" _
(ByVal hemfSrc As LongPtr, ByVal lpszFile As String) As LongPtr
Private Declare PtrSafe Function CopyImage Lib "user32" _
(ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, _
ByVal un2 As Long) As LongPtr
#ElseIf Win32 Then
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" _
(ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" _
(PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
Private Declare Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" _
(PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () 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 imageType As Long, ByVal NewWidth As Long, ByVal NewHeight As Long, _
ByVal lFlags As Long) As Long
#End If
'
#If Win64 Then
Private Type uPicDesc
Size As Long
Type As Long
hPic As LongPtr
hPal As LongPtr
End Type
#ElseIf Win32 Then
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
#End If
'
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'
Private Const CF_BITMAP = 2
Private Const CF_PALETTE = 9
Private Const CF_ENHMETAFILE = 14
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4
Private Const PICTYPE_BITMAP = 1
Private Const PICTYPE_ENHMETAFILE = 4
'
Private Sub GetPicture()
Dim hWndClipboard As Long, lPicType As Long
Dim uPicinfo As uPicDesc, iPic As IPicture
Dim IID_IDispatch As GUID
#If Win64 Then
Dim hPtr As LongPtr, hCopy As LongPtr, hPal As LongPtr, hLib As LongPtr, RetVal As LongPtr
#Else
Dim hPtr As Long, hCopy As Long, hPal As Long, hLib As Long, RetVal As Long
#End If
On Error GoTo errHandler:
If IsClipboardFormatAvailable(CF_BITMAP) <> 0 Then
lPicType = CF_BITMAP
ElseIf IsClipboardFormatAvailable(CF_ENHMETAFILE) <> 0 Then
lPicType = CF_ENHMETAFILE
End If
hWndClipboard = OpenClipboard(0&)
If hWndClipboard > 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
CloseClipboard
If hPtr = 0 Then Exit Sub
With IID_IDispatch
.Data1 = &H20400
.Data2 = 0
.Data3 = 0
.Data4(0) = &HC0
.Data4(1) = 0
.Data4(2) = 0
.Data4(3) = 0
.Data4(4) = 0
.Data4(5) = 0
.Data4(6) = 0
.Data4(7) = &H46
End With
With uPicinfo
.Size = Len(uPicinfo)
.Type = IIf(lPicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)
.hPic = hCopy
.hPal = 0
End With
hLib = LoadLibrary("oleAut32.dll")
If hLib <> 0 Then
RetVal = OleCreatePictureIndirectAut(uPicinfo, IID_IDispatch, True, iPic)
Else
RetVal = OleCreatePictureIndirectPro(uPicinfo, IID_IDispatch, True, iPic)
End If
FreeLibrary hLib
If RetVal <> 0 Then Exit Sub
Set Frame1.Picture = iPic
Else
MsgBox "Sayfadan kopyalanamadı"
Exit Sub
End If
errHandler:
CloseClipboard
If Err.Number <> &H0 Then MsgBox getStatus(Err.Number)
End Sub
'
Private Function getStatus(lngErrNum As Long) As String
Const error_ABORT As Long = &H80004004
Const error_ACCESSDENIED As Long = &H80070005
Const error_FAIL As Long = &H80004005
Const error_HANDLE As Long = &H80070006
Const error_INVALIDARG As Long = &H80070057
Const error_NOINTERFACE As Long = &H80004002
Const error_NOTIMPL As Long = &H80004001
Const error_OUTOFMEMORY As Long = &H8007000E
Const error_POINTER As Long = &H80004003
Const error_UNEXPECTED As Long = &H8000FFFF
Const status_OK As Long = &H0
Select Case lngErrNum
Case error_ABORT
' getStatus = "Aborted"
getStatus = "İşlem sonlandırılamadı"
Case error_ACCESSDENIED
' getStatus = "Access Denied"
getStatus = "Erişim engellendi"
Case error_FAIL
' getStatus = "General Failure"
getStatus = "Genel HATA!"
Case error_HANDLE
' getStatus = "Bad/Missing Handle"
getStatus = "Geçersiz hWnd"
Case error_INVALIDARG
' getStatus = "Invalid Argument"
getStatus = "Geçersiz argüman"
Case error_NOINTERFACE
' getStatus = "No Interface"
getStatus = "Arayüz bulunamadı"
Case error_NOTIMPL
' getStatus = "Not Implemented"
getStatus = "Uygulanmadı"
Case error_OUTOFMEMORY
' getStatus = "Out of Memory"
getStatus = "Yetersiz hafıza"
Case error_POINTER
' getStatus = "Invalid Pointer"
getStatus = "Geçersiz bir değişken tanımlaması"
Case error_UNEXPECTED
' getStatus = "Unknown Error"
getStatus = "Bilinmeyen HATA"
Case status_OK
' getStatus = "Success!"
getStatus = "Başarılı!"
Case Else
getStatus = "Error No: " & Err.Number & vbCrLf & vbCrLf & _
"Description: " & Err.Description & vbCrLf & vbCrLf & _
"Source: " & Err.Source
End Select
End Function
Private Sub CommandButton1_Click()
Dim NoG As Integer, picRange As Range
Dim heightTitleBar As Integer, widthSides As Integer
Frame1.ScrollBars = fmScrollBarsHorizontal
NoG = Sheets("AS").Range("C" & Rows.Count).End(xlUp).Row
Set picRange = Sheets("AS").Range("A1:AM16")
Frame1.ScrollWidth = picRange.Width
Frame1.PictureSizeMode = fmPictureSizeModeStretch
picRange.CopyPicture xlScreen, xlBitmap
Call GetPicture
Set picRange = Nothing
Frame1.PictureSizeMode = fmPictureSizeModeClip
End SubNot: CommandButton1 e bağlı kod örnek uygulama içindir ve aynı dosyadan görüntü almaktadır.