10-25-2023, 08:18 PM
Newest version. Nothing has changed in the two control programs but I added the means to export the drawn image as a basic source file that will include a subroutine full of _printstring commands to print the image drawn because... well why not?
Code: (Select All)
'Ascii Clipdoodle V 0.5
'an ascii doodle pad that opens control panel apps in other window
'
'
'loadtextimage and savetextimage from SMcNeil at https://qb64phoenix.com/forum/showthread.php?tid=2022
'
'pickclip04.exe and colorpick1604.exe must be compiled before this program will function properly
Dim Shared reflag
reflag = -1
Dim Shared helpscreen As Long
Dim Shared twd, tht
Type colchr
chr As _Unsigned _Byte
' blink As _Unsigned _Byte 'if directly changing blink bit a vlaue of 255 will turn the blink bit on
bg As _Unsigned _Byte 'can direcrtly assing vlaues of 0 to 15
fg As _Unsigned _Byte 'can directly assign values of 0 to 31
End Type
Dim gc As colchr
Dim ga As colchr
twd = 80: tht = 25
helpscreen = _NewImage(twd, tht, 0)
Dim Shared mainscreen As Long
mainscreen = _NewImage(80, 25, 0) 'default size text screen. feel free to change it.
Screen mainscreen
_Title "Ascii ClipDoodle"
Cls
'open cdoodle.tlk
write_msg "ClipDoodleOn"
Sleep 1
'_Clipboard$ = "ClipDoodleOn" ' "clears" clipboard for use
Shell _DontWait "pickclip04.exe" ' Open the pickclip control panel
Shell _DontWait "colorpick1604.exe" ' Open the colorpick16 control panel
_ControlChr Off
AK = 42
Do
_Limit 100
Do While _MouseInput 'mouse status changes only
_Limit 2000
x = _MouseX
y = _MouseY
px = _MouseX: py = _MouseY
If _MouseButton(1) Then
_PrintString (x, y), brush$
End If
Loop
kk$ = InKey$
Select Case kk$
Case "t", "T" 'type on current line with current color characteristics
_KeyClear
Do
Do
_Limit 60
tk$ = InKey$
Loop Until tk$ <> ""
If tk$ = Chr$(8) Then
tk$ = ""
px = px - 1
End If
If tk$ <> Chr$(13) And tk$ <> "" Then
_PrintString (px, py), tk$
px = px + 1
If px > _Width Then tk$ = Chr$(13) 'exit type input if attempting to type outside screen
End If
Loop Until tk$ = Chr$(13)
Case "S" 'save text screen
filef = 0
file$ = _SaveFileDialog$("Save File", "", "*.SAV", "SAved text screen")
If file$ <> "" Then
filef = 1
_MessageBox "Information", "File will be saved to " + file$
End If
If filef = 1 Then
SaveTextImage 0, file$
_MessageBox "Image SAved", "Text Images SAVED to " + file$
End If
filef = 0
Case "L", "O" 'load text screen
file$ = _OpenFileDialog$("Open File", "", "*.SAV", "SAVed text screen", -1)
If file$ <> "" Then
_MessageBox "Information", "You selected " + file$
'mainscreen = LoadTextImage(file$)
Screen LoadTextImage(file$)
tht = _Height
twd = _Width
End If
Case "C" 'clear screen
cc = _MessageBox("CLEAR SCREEN", "Are you sure you want to clear the screen? The image will be lost if it has not been saved. ", "yesnocancel", "warning", 0)
If cc = 1 Then Cls
Case Chr$(27)
cc = _MessageBox("QUIT !", "Are you sure you wish to QUIT? The image will be lost if it has not been saved. ", "yesnocancel", "warning", 0)
If cc = 1 Then Else kk$ = ""
Case "J" 'save as jpeg
filef = 0
file$ = _SaveFileDialog$("Save File", "", "*.JPG", "JPEG Image")
If file$ <> "" Then
filef = 1
_MessageBox "Information", "File will be saved to " + file$
End If
If filef = 1 Then
_SaveImage file$, 0, "JPG"
_MessageBox "JPEG SAved", "Text Images SAVED to " + file$
End If
filef = 0
Case "B" 'scan the image and output a set of traditional basic commands to a file
filef = 0
file$ = _SaveFileDialog$("Save as Basic", "", "*.BAS", "Basic Source Code")
If file$ <> "" Then filef = 1
If filef = 1 Then
Open file$ For Output As #22
subname$ = Mid$(file$, _InStrRev(file$, "\") + 1)
Print #22, "'" + subname$ + " prints a colored ascii image drawn in aclipdoodle_05"
Print #22, "'Screen _newimage(" + Str$(_Width(ti&)) + "," + Str$(_Height(ti&)) + ", 0)"
subname$ = "Print_" + Left$(subname$, Len(subname$) - 4)
Print #22, "'" + subname$ + " 1,1"
Print #22, "sub " + subname$ + "(px,py)"
Print #22, "' color 0,0 is treated as transparent if character 32 is being printed, adjust comments if desired"
Print #22, " _controlchr off "
getcolchr 0, 1, 1, ga
lc = ga.chr: lf = ga.fg: lb = ga.bg
For y = 1 To tht
rl = 0
For x = 1 To twd
getcolchr 0, x, y, gc
If gc.chr = lc And gc.fg = lf And gc.bg = lb Then
rl = rl + 1
Else
If lf = 0 And lb = 0 And lc = 32 Then
Print #22, "'color " + Str$(lf) + "," + Str$(lb) + ": _printstring(px+" + Str$(x - (rl + 1)) + ",py+" + Str$(y - 1) + ")," + " string$(" + Str$(rl) + "," + Str$(lc) + ")"
Else
Print #22, "color " + Str$(lf) + "," + Str$(lb) + ": _printstring(px+" + Str$(x - (rl + 1)) + ",py+" + Str$(y - 1) + ")," + " string$(" + Str$(rl) + "," + Str$(lc) + ")"
End If
rl = 1
lc = gc.chr: lf = gc.fg: lb = gc.bg
End If
Next x
If lf = 0 And lb = 0 And lc = 32 Then
Print #22, "'color " + Str$(lf) + "," + Str$(lb) + ": _printstring(px+" + Str$(x - (rl + 1)) + ",py+" + Str$(y - 1) + ")," + " string$(" + Str$(rl) + "," + Str$(lc) + ")"
Else
Print #22, "color " + Str$(lf) + "," + Str$(lb) + ": _printstring(px+" + Str$(x - (rl + 1)) + ",py+" + Str$(y - 1) + ")," + " string$(" + Str$(rl) + "," + Str$(lc) + ")"
End If
Next y
Print #22, "end sub"
Close #22
_MessageBox "Image Saved", " Created Basic Source file " + file$
End If
filef = 0
Case "R"
do_resize
Case "?" 'help
do_help
End Select
ik$ = get_msg$
If Left$(ik$, 2) = "AC" Then AK = Val(Right$(ik$, Len(ik$) - 2))
If Left$(ik$, 2) = "CK" Then
ff$ = " "
n = 2
Do
n = n + 1
A$ = Mid$(ik$, n, 1)
If A$ <> "/" Then ff$ = ff$ + A$
Loop Until A$ = "/"
bb$ = ""
Do
A$ = Mid$(ik$, n, 1)
If A$ <> "/" Then bb$ = bb$ + A$
n = n + 1
Loop Until n > Len(ik$)
FG = Val(ff$): BG = Val(bb$)
Color FG, BG
End If
brush$ = Chr$(AK)
Loop Until kk$ = Chr$(27)
write_msg "QUITCOLORPICK16"
Sleep 1
write_msg "QUITCLIPPICK"
System
Sub do_help
ls& = _Dest
Screen helpscreen
Cls
Print "HELP"
Print "------------------"
Print "use mouse to draw with ascii characters"
Print "select character to draw and colors from control panels"
Print " "
Print " <ESC> to quit program"
Print " t,T - To type a line of text in colors picked"
Print
Print " S - To Save Screen"
Print " L,O - to Load Saved Screen"
Print " J -save as jpeg file."
Print " B - export image as a standard qb64 Basic source file "
Print " C - to clear screen"
Print
Print "press any key to continue"
Sleep
Screen ls&
End Sub
Sub do_resize
ls& = _Dest
Screen helpscreen
Cls
Print "Resize"
Print "------------------"
Print "Current size "
Print "width "; twd, "Height "; tht
Print "Enter new coordinates"
Input "Width "; twd
Input "Height"; tht
_FreeImage ls&
Screen _NewImage(twd, tht, 0)
End Sub
Function LoadTextImage& (SaveFile As String) 'create and load to a new Screen 0 screen with our saved image
Dim As Integer Wide, Tall, Flag: Wide = 80: Tall = 25: Flag = 0
Dim As String ImageData
Dim As _MEM M
f = FreeFile
Open SaveFile For Binary As #f
compress$ = Space$(LOF(f))
Get #f, 1, compress$
Close #f
temp$ = _Inflate$(compress$)
Flag = Asc(temp$, 1): p = 2
If Flag And 1 Then Wide = CVI(Mid$(temp$, p, 2)): p = p + 2
If Flag And 2 Then Tall = CVI(Mid$(temp$, p, 2)): p = p + 2
If Flag And 4 Then _Blink On Else _Blink Off
If Flag And 8 Then _Font Asc(temp$, p): p = p + 1
ImageData = Mid$(temp$, p)
TempImage = _NewImage(Wide, Tall, 0)
M = _MemImage(TempImage): _MemPut M, M.OFFSET, ImageData: _MemFree M
LoadTextImage = TempImage
End Function
Sub SaveTextImage (ImageHandle As Long, SaveFile As String)
Dim As Integer Wide, Tall, Flag
Dim As Long ImageSize
Dim As String ImageData
Dim As _MEM M
If _PixelSize(ImageHandle) <> 0 Then Error 5: Exit Sub 'only text images for this routine
M = _MemImage(ImageHandle)
Wide = _Width(ImageHandle): Tall = _Height(ImageHandle)
temp$ = "0" 'placeholder for our finalized image flag which holds custom information
If Wide <> 80 Then Flag = Flag + 1: temp$ = temp$ + MKI$(Wide)
If Tall <> 25 Then Flag = Flag + 2: temp$ = temp$ + MKI$(Tall)
If _Blink Then Flag = Flag + 4 'Set a flag saying that this image uses _Blink
Select Case _Font(ImageHandle)
Case 8: Flag = Flag + 8: temp$ = temp$ + Chr$(8)
Case 9: Flag = Flag + 8: temp$ = temp$ + Chr$(9)
Case 14: Flag = Flag + 8: temp$ = temp$ + Chr$(14)
Case 15: Flag = Flag + 8: temp$ = temp$ + Chr$(15)
Case 16 '16 needs no flag as it's the default for screen 0
Case 17: Flag = Flag + 8: temp$ = temp$ + Chr$(17)
Case Else
'To be added once we get a _MemFont to retrieve custom font data back from QB64PE
End Select
ImageSize = Wide * Tall * 2
ImageData = Space$(ImageSize): _MemGet M, M.OFFSET, ImageData: _MemFree M
temp$ = temp$ + ImageData
Mid$(temp$, 1) = Chr$(Flag) 'replace our placeholder with the proper value of the custom flag
compress$ = _Deflate$(temp$)
f = FreeFile
Open SaveFile For Output As #f: Close #f
Open SaveFile For Binary As #f: Put #f, 1, compress$: Close #f
End Sub
Sub write_msg (m$)
Open "cdoodle.tlk" For Output As #11
Print #11, m$
Close #11
End Sub
Function get_msg$
'-----------------------------------------------
'get intraprogram messages
'----------------------------------------------
Open "cdoodle.tlk" For Input As #11
' Line Input #11, g$
If Not EOF(11) Then Line Input #11, g$
Close #11
get_msg$ = g$
End Function
Function thebit$ (n, sb, eb)
'grabs bits from starting bit SB to end bit eb
If eb > sb Then Exit Function
a$ = ""
For b = sb To eb Step -1
If _ReadBit(n, b) = 0 Then a$ = a$ + "0" Else a$ = a$ + "1"
Next b
thebit$ = a$
End Function
Sub getcolchr (ii&, x, y, gc As colchr)
'get the character at screen location x,y and store the vlaues for the charcater, foregroundcolor, backgroundcolor, and blink bit
Dim o As _MEM
o = _MemImage(ii&)
w = (_Width(ii&)) * 2
tc = (y - 1) * w + (x - 1) * 2
c1 = _MemGet(o, o.OFFSET + tc + 1, _Unsigned _Byte)
ccb$ = thebit$(c1, 6, 4)
bg = Val("&B" + ccb$)
ccf$ = thebit$(c1, 3, 0)
fg = Val("&B" + ccf$)
' bb = _ReadBit(c1, 7)
ch = _MemGet(o, o.OFFSET + tc, _Unsigned _Byte)
gc.chr = ch
gc.bg = bg
gc.fg = fg
' gc.blink = bb
_MemFree o
End Sub
Sub putcolchr (x, y, gc As colchr, ii&)
'put the character held in gc with charcter, foregroundcolor.backgroundcolor, and blink bit
Dim o As _MEM
' ii& = _Dest
o = _MemImage(ii&)
w = (_Width(ii&)) * 2
tc = (y - 1) * w + (x - 1) * 2
ch = gc.chr
fg = Val("&b" + thebit$(gc.fg, 3, 0))
bg = Val("&b" + thebit$(gc.bg, 2, 0))
' bb = _ReadBit(gc.blink, 7)
If gc.fg > 15 Then
bb = 1
End If
c = bb * 128 + fg + bg * 16
_MemPut o, o.OFFSET + tc, ch As _UNSIGNED _BYTE
_MemPut o, o.OFFSET + tc + 1, c As _UNSIGNED _BYTE
_MemFree o
End Sub