$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