'Save Picture as PPM (P6 binary format)
'    for Excel 7.0 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 "SaveAsPPM" macro.


Option Explicit

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

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 Const GHND = &H42

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 GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal wBytes As Long) As Long
Private Declare Function GlobalFree 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

Private Function CopyClipboardDIB(ByRef hMem As Long, ByRef lpBuf As Long, ByRef iMemSize As Long) As Long
    Dim hMem2 As Long
    Dim lpBuf2 As Long
    Dim iRet As Long

    CopyClipboardDIB = 0

    On Error GoTo ErrorHandler

    If IsClipboardFormatAvailable(CF_DIB) = 0 Then
        Exit Function
    End If

    If OpenClipboard(0) = 0 Then
        Exit Function
    End If

    hMem2 = GetClipboardData(CF_DIB)
    If hMem2 = 0 Then
        GoTo ErrorHandler
    End If

    lpBuf2 = GlobalLock(hMem2)
    If lpBuf2 = 0 Then
        GoTo ErrorHandler
    End If

    iMemSize = GlobalSize(hMem2)

    hMem = GlobalAlloc(GHND, iMemSize)
    If hMem = 0 Then
        GoTo ErrorHandler
    End If

    lpBuf = GlobalLock(hMem)
    If lpBuf = 0 Then
        GoTo ErrorHandler
    End If

    MoveMemory ByVal lpBuf, ByVal lpBuf2, iMemSize

    iRet = GlobalUnlock(hMem2)
    If iRet <> 0 Then
        GoTo ErrorHandler
    End If
    hMem2 = 0

    iRet = CloseClipboard()
    If iRet = 0 Then
        GoTo ErrorHandler
    End If

    CopyClipboardDIB = 1

    Exit Function

ErrorHandler:
    If hMem2 <> 0 Then
        iRet = GlobalUnlock(hMem2)
    End If
    iRet = CloseClipboard()
    If hMem <> 0 Then
        iRet = GlobalUnlock(hMem)
        iRet = GlobalFree(hMem)
        hMem = 0
    End If
End Function

Public Function SaveClipboardPPM(ByVal sFileName As String) As Long
    Dim bmi As BITMAPINFOHEADER
    Dim hFile As Long
    Dim iWritten As Long
    Dim hMem As Long
    Dim iMemSize As Long
    Dim lpBuf As Long
    Dim lpNext As Long
    Dim iPal(0 To 255) As Long
    Dim iLineBuf() As Long
    Dim iLineBuf2(0 To 31) As Long
    Dim iLineByte As Long
    Dim iPalSize As Long
    Dim iBitSize As Long
    Dim iRet As Long
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim p As Long
    Dim s As String

    SaveClipboardPPM = 0

    On Error GoTo ErrorHandler

    'Get the DIB on the clipboard.
    iRet = CopyClipboardDIB(hMem, lpBuf, iMemSize)
    If iRet = 0 Then
        Exit Function
    End If

    'Check the size of the DIB.
    If (iMemSize > MAX_BMP_SIZE) Or (iMemSize < 16) Then
        GoTo ErrorHandler
    End If

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

    'Check BitCount.
    Select Case bmi.biBitCount
        Case 1, 4, 8, 24
        Case Else
            GoTo ErrorHandler
    End Select

    'Get the width of the bitmap.
    iLineByte = ((bmi.biBitCount * bmi.biWidth - 1) \ 32 + 1) * 32 \ 8
    ReDim iLineBuf(0 To bmi.biWidth - 1)

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

    'Copy the palette
    If iPalSize > 0 Then
        MoveMemory iPal(0), ByVal (lpBuf + bmi.biSize), iPalSize
        RGBSwap iPal(), iPalSize \ 4 - 1
    End If

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

    'Write the ppm header.
    s = "P6" & Chr$(10) & CStr(bmi.biWidth) & " " & CStr(bmi.biHeight) & Chr$(10) & "255" & Chr$(10)
    For i = 1 To Len(s)
        j = Asc(Mid(s, i, 1))
        iRet = WriteFile(hFile, j, 1, iWritten, 0)
        If iRet = 0 Then
            GoTo ErrorHandler
        End If
    Next

    'Get the pointer.
    lpNext = lpBuf + bmi.biSize + iPalSize + ((bmi.biHeight - 1) * iLineByte)

    'Write the RGB data.
    For i = 0 To bmi.biHeight - 1
        If bmi.biBitCount = 24 Then
            p = lpNext
            For j = 0 To bmi.biWidth - 1
                MoveMemory iLineBuf(0), ByVal p, 3
                RGBSwap iLineBuf(), 0
                iRet = WriteFile(hFile, iLineBuf(0), 3, iWritten, 0)
                If iRet = 0 Then
                    GoTo ErrorHandler
                End If
                p = p + 3
            Next
        Else
            MoveMemory iLineBuf(0), ByVal lpNext, iLineByte
            p = 0
            For j = 0 To iLineByte \ 4 - 1
                BitDiv iLineBuf(j), iLineBuf2(), bmi.biBitCount
                For k = 0 To 32 \ bmi.biBitCount - 1
                    p = p + 1
                    If p > bmi.biWidth Then
                        Exit For
                    End If
                    iRet = WriteFile(hFile, iPal(iLineBuf2(k)), 3, iWritten, 0)
                    If iRet = 0 Then
                        GoTo ErrorHandler
                    End If
                Next
            Next
        End If
        lpNext = lpNext - iLineByte
    Next

    iRet = CloseHandle(hFile)
    If iRet = 0 Then
        GoTo ErrorHandler
    End If
    hFile = 0

    iRet = GlobalUnlock(hMem)
    iRet = GlobalFree(hMem)
    hMem = 0

    SaveClipboardPPM = 1
    Exit Function

ErrorHandler:
    If hFile <> 0 Then
        iRet = CloseHandle(hFile)
    End If
    If hMem <> 0 Then
        iRet = GlobalUnlock(hMem)
        iRet = GlobalFree(hMem)
    End If
    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 SaveAsPPM()
    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:="PPM (*.ppm),*.ppm," & _
        "All files (*.*),*.*", Title:=sAppName)
    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 = SaveClipboardPPM(vFileName)

    Select Case iRet
        Case 1
            MsgBox "The picture was saved.", vbInformation, sAppName
        Case 3
            MsgBox "Too large picture.", vbExclamation, sAppName
        Case Else
            MsgBox "Unexpected error.", vbExclamation, sAppName
    End Select
End Sub

Function BitDiv(ByVal l As Long, a() As Long, ByVal bitCount As Long) As Long
    Dim i As Long
    Dim j As Long
    Dim n As Long

    n = 32 \ bitCount - 1

    If l And &H80000000 Then
        a(n) = 2 ^ (bitCount - 1)
    Else
        a(n) = 0
    End If
    l = l And &H7FFFFFFF
    If bitCount > 1 Then
        j = 2 ^ (32 - bitCount)
        a(n) = a(n) Or CLng(l \ j)
        l = l Mod j
    End If

    For i = n - 1 To 0 Step -1
        j = 2 ^ (i * bitCount)
        a(i) = l \ j
        l = l Mod j
    Next
End Function

Function RGBSwap(a() As Long, ByVal n As Long) As Long
    Dim i As Long
    For i = 0 To n
        a(i) = ((a(i) And &HFF0000) \ &H10000) Or (a(i) And &HFF00&) Or ((a(i) And &HFF&) * &H10000)
    Next
End Function