Code:
Option ExplicitPrivate Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" ( _
ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32.dll" ( _
ByVal hWnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" ( _
ByVal wFormat As Integer) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
ByRef PicDesc As uPicDesc, _
ByRef RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
ByRef IPic As IPicture) As Long
Declare Function CopyEnhMetaFile Lib "gdi32.dll" Alias "CopyEnhMetaFileA" ( _
ByVal hemfSrc As Long, _
ByVal lpszFile As String) As Long
Declare Function CopyImage Lib "user32.dll" ( _
ByVal handle As Long, _
ByVal un1 As Long, _
ByVal n1 As Long, _
ByVal n2 As Long, _
ByVal un2 As Long) As Long
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
ByVal DirPath As String) 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
lngSize As Long
lngType As Long
lnghPic As Long
lnghPal As Long
End Type
Private Const E_ABORT = &H80004004
Private Const E_ACCESSDENIED = &H80070005
Private Const E_FAIL = &H80004005
Private Const E_HANDLE = &H80070006
Private Const E_INVALIDARG = &H80070057
Private Const E_NOINTERFACE = &H80004002
Private Const E_NOTIMPL = &H80004001
Private Const E_OUTOFMEMORY = &H8007000E
Private Const E_POINTER = &H80004003
Private Const E_UNEXPECTED = &H8000FFFF
Private Const S_OK = &H0
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 FOLDER_NAME = "C:\TEMP\"
Private Const FILE_NAME = "Image.bmp"
Public Sub Save_Image()
Dim vntPicture As Variant
Dim lngReturn As Long
Selection.CopyPicture xlScreen, xlBitmap
Set vntPicture = Paste_Picture(xlBitmap)
If Not vntPicture Is Nothing Then
lngReturn = MakeSureDirectoryPathExists(FOLDER_NAME)
If lngReturn = 0 Then
MsgBox "Unalble to create folder: '" & FOLDER_NAME & "'.", vbCritical, "Error"
Else
stdole.StdFunctions.SavePicture vntPicture, FOLDER_NAME & FILE_NAME
End If
Else
MsgBox "Not possible to save picture.", vbCritical, "Error"
End If
End Sub
Function Paste_Picture(Optional lXlPicType As Long = xlPicture) As IPicture
Dim lngReturn As Long, hPtr As Long, hPal As Long
Dim lngPicType As Long, hCopy As Long
lngPicType = IIf(lXlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)
If IsClipboardFormatAvailable(lngPicType) <> 0 Then
lngReturn = OpenClipboard(Application.hWnd)
If lngReturn > 0 Then
hPtr = GetClipboardData(lngPicType)
If lngPicType = CF_BITMAP Then
hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Else
hCopy = CopyEnhMetaFile(hPtr, vbNullString)
End If
Call CloseClipboard
If hPtr <> 0 Then Set Paste_Picture = Create_Picture(hCopy, 0, lngPicType)
End If
End If
End Function
Private Function Create_Picture( _
ByVal lnghPic As Long, _
ByVal lnghPal As Long, _
ByVal lngPicType As Long) As IPicture
Const PICTYPE_BITMAP = 1
Const PICTYPE_ENHMETAFILE = 4
Dim lngReturn 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
.lngSize = Len(uPicInfo)
.lngType = PICTYPE_BITMAP
.lnghPic = lnghPic
.lnghPal = lnghPal
End With
lngReturn = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
If lngReturn <> 0 Then MsgBox "Error occure" & OLEError(lngReturn), vbCritical, "Error"
Set Create_Picture = IPic
End Function
Private Function OLEError(lErrNum As Long) As String
Select Case lErrNum
Case E_ABORT: OLEError = " Aborted"
Case E_ACCESSDENIED: OLEError = " Access Denied"
Case E_FAIL: OLEError = " General Failure"
Case E_HANDLE: OLEError = " Bad/Missing Handle"
Case E_INVALIDARG: OLEError = " Invalid Argument"
Case E_NOINTERFACE: OLEError = " No Interface"
Case E_NOTIMPL: OLEError = " Not Implemented"
Case E_OUTOFMEMORY: OLEError = " Out of Memory"
Case E_POINTER: OLEError = " Invalid Pointer"
Case E_UNEXPECTED: OLEError = " Unknown Error"
Case S_OK: OLEError = " Success!"
End Select
End Function
Foren auf CAD.de (alle Foren)
| 
