VBAからGDI+を使う資料集
inet上の達人の方々から御教示いただいたコードを少しアレンジさせてもらっています(切り貼りとも言います)。
  1. ホーム
  2. Collection
  3. CB→BMP保存


クリップボード→BMPファイル保存


'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