qb64-include/savebinarypbm.bm

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) = _RGB32(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
End Sub