AW: Zelle als Bild speichern beschleunigen
12.02.2011 20:55:37
Nepumuk
Hallo,
die Funktion stand noch in einem anderen Modul als Public, daher ist mir das nicht aufgefallen. So passt es:
' **********************************************************************
' Modul: Modul4 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
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 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 OleCreatePictureIndirect Lib "olepro32.dll" ( _
ByRef PicDesc As uPicDesc, _
ByRef RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
ByRef IPic As IPicture) 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 IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4
Private Function Paste_Picture() As IPicture
Dim lngReturn As Long, lngPointer As Long, lngCopy As Long
If IsClipboardFormatAvailable(xlBitmap) <> 0 Then
lngReturn = OpenClipboard(0&)
If lngReturn > 0 Then
lngPointer = GetClipboardData(CF_BITMAP)
lngCopy = CopyImage(lngPointer, IMAGE_BITMAP, 0&, 0&, LR_COPYRETURNORG)
Call CloseClipboard
If lngPointer <> 0 Then _
Set Paste_Picture = Create_Picture(lngCopy, 0, CF_BITMAP)
End If
End If
End Function
Private Function Create_Picture( _
ByVal lnghPic As Long, _
ByVal lnghPal As Long, _
ByVal lngPicType As Long) As IPicture
Dim lngReturn As Long
Dim udtPicInfo As uPicDesc, udtIID_IDispatch As GUID
Dim objIPicture As IPicture
Const PICTYPE_BITMAP = 1
Const PICTYPE_ENHMETAFILE = 4
With udtIID_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 udtPicInfo
.lngSize = Len(udtPicInfo)
.lngType = PICTYPE_BITMAP
.lnghPic = lnghPic
.lnghPal = lnghPal
End With
lngReturn = OleCreatePictureIndirect(udtPicInfo, udtIID_IDispatch, True, objIPicture)
If lngReturn <> S_OK Then
MsgBox "Error occure " & OLEError(lngReturn), vbCritical, "Error"
Else
Set Create_Picture = objIPicture
End If
End Function
Private Function OLEError(lngErrorNumber As Long) As String
Select Case lngErrorNumber
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"
End Select
End Function
Private Function Save_Picture(strFileName As String) As Boolean
Dim objPicture As Variant
Set objPicture = Paste_Picture()
If Not objPicture Is Nothing Then
Call SavePicture(objPicture, strFileName)
Save_Picture = True
End If
End Function
Public Sub Range_To_Image()
Dim lngRow As Long
With Tabelle1
For lngRow = 32 To 65535
Call EmptyClipboard
.Cells(lngRow, 1).CopyPicture Appearance:=xlScreen, Format:=xlBitmap
If Not Save_Picture("C:\Test\meinBild" & Format(lngRow, "00000") & ".bmp") Then
MsgBox "Not possible to create picture.", vbCritical, "Error"
Exit For
End If
Next
End With
End Sub
Gruß
Nepumuk