'選択オブジェクトの画像をビットマップファイルへ保存するマクロ

'クリップボードに登録されたDIBをそのままファイルへ保存します。
'24ビットの場合は8ビットへの変換を試みます。

Option Explicit

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 IsClipboardFormatAvailable Lib "user32" ( _
    ByVal wFormat As Long) 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


'クリップボードにDIBがあるかチェックする関数
Public Function IsClipboardFormatDIB()
    IsClipboardFormatDIB = _
        (IsClipboardFormatAvailable(CF_DIB) <> 0)
End Function


'クリップボードのDIBをファイルへ保存する関数
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, lpNext As Long

    Dim bitArray() As Integer
    Dim pal(0 To 255) As Long
    Dim iPalIndex As Integer
    Dim iRGB As Long, iLast As Long, iIndex As Long
    Dim iWidth As Long, iHeight As Long, iPadSize As Long
    Dim iPalSize As Long, iBitSize As Long, iDIBSize As Long
    Dim iStatus As Long
    Dim iRet As Long
    Dim i As Long, j As Long, k As Long

    iStatus = 0
    SaveClipboardDIB = -1

    On Error GoTo ErrorHandler1

    'DIBがあるかチェック
    If IsClipboardFormatAvailable(CF_DIB) = 0 Then Exit Function

    'クリップボードのオープン
    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

    'ビットカウントをチェック
    Select Case bmi.biBitCount
        Case 1, 4, 8
            GoTo DirectOutput
        Case 24
            GoTo Decrease24to8
    End Select

    GoTo exit_GlobalUnlock


DirectOutput:

    On Error GoTo ErrorHandler1

    'パレットのバイト数を計算
    If bmi.biClrUsed = 0 Then
        iPalSize = (2 ^ bmi.biBitCount) * 4
    Else
        iPalSize = bmi.biClrUsed * 4
    End If

    'ビットマップのバイト数を計算
    iBitSize = bmi.biHeight * ((bmi.biWidth * bmi.biBitCount - 1) \ 32 + 1) * 4

    'DIBのバイト数をチェック
    iDIBSize = bmi.biSize + iPalSize + iBitSize
    If iDIBSize > iMemSize Then GoTo exit_GlobalUnlock

    'BITMAPFILEHEADERの作成
    bmh(0) = &h4d42
    i = 14 + iDIBSize
    MoveMemory bmh(1), i, 4
    i = 14 + bmi.biSize + iPalSize
    MoveMemory bmh(5), i, 4

    'ファイルの作成
    hFile = CreateFile(sFileName, GENERIC_WRITE, 0, 0, CREATE_ALWAYS, _
        FILE_ATTRIBUTE_ARCHIVE, 0)
    If hFile = INVALID_HANDLE_VALUE Then GoTo exit_GlobalUnlock

    'ファイル出力
    iRet = WriteFile(hFile, bmh(0), 14, iWritten, 0)
    If iRet = 0 Then GoTo exit_CloseFile
    iRet = WriteFile(hFile, ByVal lpBuffer, iDIBSize, iWritten, 0)
    If iRet = 0 Then GoTo exit_CloseFile

    iRet = CloseHandle(hFile)
    If iRet = 0 Then GoTo exit_GlobalUnlock
    hFile = 0

    iRet = GlobalUnlock(hglb)
    If iRet <> 0 Then GoTo exit_CloseClipboard
    hglb = 0

    iRet = CloseClipboard()
    If iRet = 0 Then GoTo exit_Function

    SaveClipboardDIB = 0
    Exit Function


Decrease24to8:

    On Error GoTo ErrorHandler2

    'パレットの初期化
    pal(0) = 0
    For i = 1 To 255
        pal(i) = &hffffff
    Next

    '8ビットデータのサイズを計算
    iWidth = ((bmi.biWidth - 1) \ 4 + 1) * 4
    iHeight = bmi.biHeight
    iBitSize = iHeight * iWidth

    '8ビットデータの配列の割り当て
    ReDim bitArray(0 To (iWidth \ 2) * iHeight - 1)

    'パディングのサイズを計算
    iPadSize = ((bmi.biWidth * 3 - 1) \ 4 + 1) * 4 - bmi.biWidth * 3

    'ビットデータの開始アドレスを取得
    lpNext = lpBuffer + bmi.biSize

    iLast = 0
    For i = 0 To bmi.biHeight - 1
        For j = 0 To bmi.biWidth - 1

            '配列インデックスの作成
            iIndex = (i * iWidth + j) \ 2

            '24ビットデータを取得
            MoveMemory iRGB, ByVal lpNext, 3
            lpNext = lpNext + 3

            'パレットの検索
            If iRGB = &hffffff Then
                iPalIndex = 255
            Else
                iPalIndex = -1
                For k = 0 To iLast
                    If pal(k) = iRGB Then
                        iPalIndex = k
                        Exit For
                    End If
                Next
                If iPalIndex = -1 Then
                    If iLast = 254 Then
                        iPalIndex = 255
                        iStatus = 2
                    Else
                        iLast = iLast + 1
                        pal(iLast) = iRGB
                        iPalIndex = iLast
                    End If
                End If
            End If

            '8ビットデータを設定
            If (j And &h1) = 0 Then
                bitArray(iIndex) = iPalIndex
            Else
                If (iPalIndex And &h80) = 0 Then
                    bitArray(iIndex) = (iPalIndex * &h100) Or bitArray(iIndex)
                Else
                    bitArray(iIndex) = ((iPalIndex And &h7f) * &h100) _
                        Or &h8000 Or bitArray(iIndex)
                End If
            End If
        Next

        'パディング部分を空読み
        lpNext = lpNext + iPadSize
    Next

    'グローバルメモリのロックを解除
    iRet = GlobalUnlock(hglb)
    If iRet <> 0 Then GoTo exit_CloseClipboard2
    hglb = 0

    'クリップボードをクローズ
    iRet = CloseClipboard()
    If iRet = 0 Then Exit Function


    On Error GoTo ErrorHandler3

    iPalSize = (2 ^ 8) * 4

    'BITMAPINFOHEADERの作成
    With bmi
        .biSize = 40
        .biBitCount = 8
        .biSizeImage = iBitSize
    End With

    'BITMAPFILEHEADERの作成
    bmh(0) = &h4d42
    i = 14 + bmi.biSize + iPalSize + iBitSize
    MoveMemory bmh(1), i, 4
    i = 14 + bmi.biSize + iPalSize
    MoveMemory bmh(5), i, 4

    'ファイルの作成
    hFile = CreateFile(sFileName, GENERIC_WRITE, 0, 0, CREATE_ALWAYS, _
        FILE_ATTRIBUTE_ARCHIVE, 0)
    If hFile = INVALID_HANDLE_VALUE Then GoTo exit_Function

    'ファイル出力
    iRet = WriteFile(hFile, bmh(0), 14, iWritten, 0)
    If iRet = 0 Then GoTo exit_CloseFile2
    iRet = WriteFile(hFile, bmi, bmi.biSize, iWritten, 0)
    If iRet = 0 Then GoTo exit_CloseFile2
    iRet = WriteFile(hFile, pal(0), iPalSize, iWritten, 0)
    If iRet = 0 Then GoTo exit_CloseFile2
    iRet = WriteFile(hFile, bitArray(0), iBitSize, iWritten, 0)
    If iRet = 0 Then GoTo exit_CloseFile2

    iRet = CloseHandle(hFile)
    If iRet = 0 Then GoTo exit_Function
    hFile = 0

    SaveClipboardDIB = iStatus
    Exit Function

exit_CloseFile:
    iRet = CloseHandle(hFile)
    hFile = 0
exit_GlobalUnlock:
    iRet = GlobalUnlock(hglb)
    hglb = 0
exit_CloseClipboard:
    iRet = CloseClipboard()
    Exit Function

exit_GlobalUnlock2:
    iRet = GlobalUnlock(hglb)
    hglb = 0
exit_CloseClipboard2:
    iRet = CloseClipboard()
    Exit Function

exit_CloseFile2:
    iRet = CloseHandle(hFile)
    hFile = 0
    Exit Function

exit_Function:
    Exit Function

ErrorHandler1:
    If (hFile <> 0) And (hFile <> INVALID_HANDLE_VALUE) Then _
        iRet = CloseHandle(hFile)
    If hglb <> 0 Then iRet = GlobalUnlock(hglb)
    iRet = CloseClipboard()
    Exit Function

ErrorHandler2:
    If hglb <> 0 Then iRet = GlobalUnlock(hglb)
    iRet = CloseClipboard()
    Exit Function

ErrorHandler3:
    If (hFile <> 0) And (hFile <> INVALID_HANDLE_VALUE) Then _
        iRet = CloseHandle(hFile)
    Exit Function

End Function


'選択オブジェクトの画像をコピーする関数
'グラフがアクティブのときはグラフ全体をコピーします。

Private Function SelectionCopyBitmap() As Boolean
    Dim iLineNo As Integer, iStatus As Integer

    On Error GoTo ErrorHandler

    iLineNo = 1
    If Not (ActiveChart Is Nothing) Then
        ActiveChart.CopyPicture Appearance:=xlScreen, _
            Format:=xlBitmap, Size:=xlScreen
        SelectionCopyBitmap = True
        Exit Function
    End If

    iLineNo = 2
    iStatus = 0
    Selection.CopyPicture Appearance:=xlScreen, _
        Format:=xlBitmap, Size:=xlScreen
    If iStatus = 0 Then
        SelectionCopyBitmap = True
        Exit Function
    End If

    iLineNo = 3
    Selection.CopyPicture Appearance:=xlScreen, _
        Format:=xlBitmap
    SelectionCopyBitmap = True

    Exit Function

ErrorHandler:
    Select Case iLineNo
        Case 2
            iStatus = 1
            Resume Next
        Case Else
            SelectionCopyBitmap = False
            Exit Function
    End Select
End Function


'選択オブジェクトの画像をビットマップファイルへ保存するマクロ
Public Sub SaveAsBMP()
    Const MyTitle As String = "画像コピーをビットマップファイルへ保存"
    Dim iRet As Long
    Dim vFileName As Variant

    iRet = MsgBox("選択オブジェクトの画像をコピーしますか？", _
        vbExclamation Or vbYesNoCancel, MyTitle)
    If iRet = vbCancel Then Exit Sub
    If iRet = vbYes Then
        If Not SelectionCopyBitmap() Then
            MsgBox "選択オブジェクトの画像コピーに失敗しました。", _
                vbExclamation, MyTitle
            Exit Sub
        End If
    End If

    If Not IsClipboardFormatDIB() Then
        MsgBox "クリップボードにビットマップ(DIB)がありません。", _
            vbExclamation, MyTitle
        Exit Sub
    End If

    vFileName = Application.GetSaveAsFilename( _
        InitialFilename:="", _
        FileFilter:=StrConv("Windows ビットマップファイル (*.bmp),*.bmp," & _
        "すべてのファイル (*.*),*.*", vbNarrow), Title:=MyTitle)
    If VarType(vFileName) = vbBoolean Then Exit Sub
    If Dir$(vFileName) <> "" Then
        iRet = MsgBox("ファイルは既に存在します。上書きしますか？", _
            vbExclamation Or vbOKCancel Or vbDefaultButton2, MyTitle)
        If iRet <> vbOK Then Exit Sub
    End If

    iRet = SaveClipboardDIB(vFileName)
    Select Case iRet
        Case 0
            MsgBox "ビットマップを保存しました。", vbInformation, MyTitle
        Case 2
            MsgBox "24ビットから8ビットへの変換ができませんでした。", vbExclamation, MyTitle
        Case Else
            MsgBox "エラーが発生しました。", vbExclamation, MyTitle
    End Select
End Sub