'Save Picture as BMP
'    for Excel 95 or later for Windows

'Insert a new module, copy the following code and paste to the module.
'Select cell range or drawing object, and run "SaveAsBMP" macro.


Option Explicit

Private Const sAppName As String = "Save Picture as BMP"

Private Const MAX_BMP_SIZE As Long = 1000000
Private Const MAX_CELL As Long = 5000

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


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

    If IsClipboardFormatAvailable(CF_DIB) = 0 Then Exit Function

    If OpenClipboard(0) = 0 Then Exit Function

    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 > MAX_BMP_SIZE Then
        SaveClipboardDIB = 3
        GoTo Exit_GlobalUnlock
    End If
    If iMemSize < 16 Then
        GoTo Exit_GlobalUnlock
    End If

    'Get BITMAPINFOHEADER.
    MoveMemory bmi, ByVal lpBuffer, 4
    MoveMemory bmi, ByVal lpBuffer, bmi.biSize

    'Get BitCount.
    Select Case bmi.biBitCount
        Case 1, 4, 8
            GoTo DirectOutput
        Case 24
            iRet = MsgBox("Decrease color from 24-bits to 8-bits?", _
                vbYesNo Or vbQuestion, sAppName)
            If iRet = vbYes Then
                GoTo Decrease24to8
            Else
                GoTo DirectOutput
            End If
    End Select

    GoTo Exit_GlobalUnlock


DirectOutput:

    On Error GoTo ErrorHandler1

    'Get the size of the palette.
    If bmi.biBitCount = 24 Then
        iPalSize = 0
    ElseIf bmi.biClrUsed = 0 Then
        iPalSize = (2 ^ bmi.biBitCount) * 4
    Else
        iPalSize = bmi.biClrUsed * 4
    End If

    'Get the size of the bits.
    iBitSize = bmi.biHeight * ((bmi.biWidth * bmi.biBitCount - 1) \ 32 + 1) * 4

    'Get the size of the DIB.
    iDIBSize = bmi.biSize + iPalSize + iBitSize
    If iDIBSize > iMemSize Then GoTo Exit_GlobalUnlock

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

    'Create the file.
    hFile = CreateFile(sFileName, GENERIC_WRITE, 0, 0, CREATE_ALWAYS, _
        FILE_ATTRIBUTE_ARCHIVE, 0)
    If hFile = INVALID_HANDLE_VALUE Then GoTo Exit_GlobalUnlock

    'Write the file.
    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

    'Initialize the palette.
    pal(0) = 0
    For i = 1 To 255
        pal(i) = &hffffff
    Next

    'Get the size of the picture.
    iWidth = ((bmi.biWidth - 1) \ 4 + 1) * 4
    iHeight = bmi.biHeight
    iBitSize = iHeight * iWidth

    'Dimension the array of the bits.
    ReDim bitArray(0 To (iWidth \ 2) * iHeight - 1)

    'Get the size of the pad.
    iPadSize = ((bmi.biWidth * 3 - 1) \ 4 + 1) * 4 - bmi.biWidth * 3

    'Get the address of the bits.
    lpNext = lpBuffer + bmi.biSize

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

            'Get the index of the array of the bits.
            iIndex = (i * iWidth + j) \ 2

            'Get a RGB data.
            MoveMemory iRGB, ByVal lpNext, 3
            lpNext = lpNext + 3

            'Search the palette.
            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

            'Set the index of the palette.
            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

        'Increase the pointer by the pad.
        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

    'Fill BITMAPINFOHEADER.
    With bmi
        .biSize = 40
        .biBitCount = 8
        .biSizeImage = iBitSize
    End With

    'Fill 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

    'Create the file.
    hFile = CreateFile(sFileName, GENERIC_WRITE, 0, 0, CREATE_ALWAYS, _
        FILE_ATTRIBUTE_ARCHIVE, 0)
    If hFile = INVALID_HANDLE_VALUE Then GoTo Exit_Function

    'Write the file.
    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 SelectionCopyPicture(iFormat As Long) As Boolean
    Dim iLineNo As Integer
    Dim iStatus As Integer

    On Error GoTo ErrorHandler

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

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

    iLineNo = 3
    Selection.CopyPicture Appearance:=xlScreen, _
        Format:=iFormat
    SelectionCopyPicture = True

    Exit Function

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


Private Function CheckCopyBitmap() As Long
    Dim iRet As Long
    CheckCopyBitmap = 0
    iRet = MsgBox("Copy the picture of selected object?", _
        vbExclamation Or vbYesNoCancel, sAppName)

    If iRet = vbCancel Then
        Exit Function
    End If

    If iRet = vbYes Then
        If TypeName(Selection) = "Range" Then
            If Selection.Count > MAX_CELL Then
                MsgBox "Too large picture.", vbExclamation, sAppName
                Exit Function
            End If
        End If
        If Not SelectionCopyPicture(xlBitmap) Then
            MsgBox "Error copying the picture of selected object.", _
                vbExclamation, sAppName
            Exit Function
        End If
    End If
    CheckCopyBitmap = 1
End Function


Public Sub SaveAsBMP()
    Dim iRet As Long
    Dim vFileName As Variant

    If CheckCopyBitmap() = 0 Then
        Exit Sub
    End If

    If IsClipboardFormatAvailable(CF_DIB) = 0 Then
        MsgBox "No picture in clipboard.", vbExclamation, sAppName
        Exit Sub
    End If

    vFileName = Application.GetSaveAsFilename( _
        InitialFilename:="", _
        FileFilter:="Windows Bitmap (*.bmp),*.bmp,All files (*.*),*.*")
    If VarType(vFileName) = vbBoolean Then Exit Sub
    If Dir$(vFileName) <> "" Then
        iRet = MsgBox("The file '" & vFileName & _
            "' already exists. Replace existing file?", _
            vbExclamation Or vbOKCancel Or vbDefaultButton2, sAppName)
        If iRet <> vbOK Then Exit Sub
    End If

    iRet = SaveClipboardDIB(vFileName)

    Select Case iRet
        Case 0
            MsgBox "The picture was saved.", vbInformation, sAppName
        Case 2
            MsgBox "Error in decreasing from 24-bits to 8-bits.", _
                vbExclamation, sAppName
        Case 3
            MsgBox "Too large picture.", vbExclamation, sAppName
        Case Else
            MsgBox "Unexpected error.", vbExclamation, sAppName
    End Select
End Sub