'http://exceler.blog68.fc2.com/
Dim fileopen As String
Private Const CF_DIB = 8
Private Const INVALID_HANDLE_VALUE = -1
Private Const GENERIC_WRITE = &H40000000
Private Const CREATE_ALWAYS = &H2
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMEM As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMEM As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMEM As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" ( _
ByVal lpszName As String, ByVal dwAccess As Long, _
ByVal dwShareMode As Long, ByVal lpsa As Long, _
ByVal dwCreate As Long, ByVal dwAttrsAndFlags As Long, _
ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function WriteFile Lib "kernel32" ( _
ByVal hFile As Long, ByRef lpBuffer As Any, _
ByVal nNumberOfBytesToWrite As Long, ByRef lpNumberOfBytesWritten As Long, _
ByVal lpOverlapped As Long) As Long
Private Declare Sub MoveMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" ( _
ByVal wFormat As Long) As Long
Sub test()
SaveClipboardDIB ("c:\saveCB_API.bmp")
End Sub
Public Function SaveClipboardDIB(ByVal sFileName As String) As Long
Dim bmi As BITMAPINFOHEADER
Dim bmh(0 To 7) As Integer
Dim hFile As Long, iWritten As Long
Dim hglb As Long, iMemSize As Long
Dim lpBuffer As Long, iDIBSize As Long
Dim Ret As Long
Dim i As Long
'On Error GoTo ErrorHandler1
'クリップボードのオープン
If OpenClipboard(0) = 0 Then Exit Function
'DIBのメモリハンドルを取得
hglb = GetClipboardData(CF_DIB)
If hglb = 0 Then GoTo exit_CloseClipboard
'グローバルメモリのロック
lpBuffer = GlobalLock(hglb)
If lpBuffer = 0 Then GoTo exit_CloseClipboard
If lpBuffer < 0 Then GoTo exit_GlobalUnlock
'グローバルメモリのサイズのチェック
iMemSize = GlobalSize(hglb)
If iMemSize > 10000000 Then GoTo exit_GlobalUnlock
If iMemSize < 16 Then GoTo exit_GlobalUnlock
'BITMAPINFOHEADERの取得
MoveMemory bmi, ByVal lpBuffer, 4
MoveMemory bmi, ByVal lpBuffer, bmi.biSize
iDIBSize = iMemSize
'BITMAPFILEHEADERの作成
bmh(0) = &H4D42
i = 14 + iDIBSize
MoveMemory bmh(1), i, 4
i = 14 + bmi.biSize '
MoveMemory bmh(5), i, 4
'ファイルの作成
hFile = CreateFile(sFileName, GENERIC_WRITE, 0, 0, CREATE_ALWAYS, FILE_ATTRIBUTE_ARCHIVE, 0)
Ret = WriteFile(hFile, bmh(0), 14, iWritten, 0)
Ret = WriteFile(hFile, ByVal lpBuffer, iDIBSize, iWritten, 0)
If Ret = 0 Then GoTo exit_CloseFile
Ret = CloseHandle(hFile)
If Ret = 0 Then GoTo exit_GlobalUnlock
hFile = 0
Ret = GlobalUnlock(hglb)
If Ret <> 0 Then GoTo exit_CloseClipboard
hglb = 0
Ret = CloseClipboard()
Exit Function
exit_CloseFile:
Ret = CloseHandle(hFile)
hFile = 0
exit_GlobalUnlock:
Ret = GlobalUnlock(hglb)
hglb = 0
exit_CloseClipboard:
Ret = CloseClipboard()
Exit Function
exit_Function:
Exit Function
ErrorHandler1:
If (hFile <> 0) And (hFile <> INVALID_HANDLE_VALUE) Then Ret = CloseHandle(hFile)
If hglb Then Ret = GlobalUnlock(hglb)
Ret = CloseClipboard()
Exit Function
End Function