savebinarypbm.bm

$if saveBinaryPBM = undefined then
$let saveBinaryPBM = defined
' ## Save binary PBM
' * Syntax: ``SaveBinaryPBM(ImageHandle as Long, Filename As String)``
' ### Info
' * Saves any image to Monochrome binary PBM image file.
' * All colors other than black will be white
Sub saveBinaryPBM (handle As Long, filename As String)
    Dim imgwidth As Long
    Dim imgheight As Long
    Dim oldsource As Long
    Dim header As String
    Dim y As _Unsigned Long
    Dim x As _Unsigned Long
    Dim bytecount As _Unsigned Long
    Dim ff As Long
    Dim c As _Byte
    Dim outbyte As _Unsigned _Byte
    oldsource = _Source
    _Source handle
    imgwidth = _Width(handle)
    imgheight = _Height(handle)
    ff = FreeFile
    Open filename For Binary As #ff
    header = "P4" + Chr$(10)
    header = header + "# Created with QB64" + Chr$(10)
    header = header + LTrim$(Str$(imgwidth) + Str$(imgheight)) + Chr$(10)
    Put #1, , header
    For y = 0 To imgheight - 1
        For x = 0 To imgwidth - 1
            c = (Point(x, y) = _RGB(0, 0, 0))
            If c <> 0 Then
                outbyte = _SetBit(outbyte, 7 - (bytecount Mod 8))
            Else
                outbyte = _ResetBit(outbyte, 7 - (bytecount Mod 8))
            End If
            If bytecount Mod 8 = 7 Then
                Put #ff, , outbyte
            End If
            bytecount = bytecount + 1
        Next
    Next
    If (imgheight * imgwidth) Mod 8 <> 0 Then Put #1, , outbyte
    Close #ff
    _Source oldsource
End Sub
$end if