Posts: 660
Threads: 142
Joined: Apr 2022
Reputation:
58
10-16-2023, 09:40 PM
(This post was last modified: 10-16-2023, 11:51 PM by James D Jarvis.)
A multi-window program to draw ASCII-art.
The program consists of the main program and 2 other programs that must also be compiled for this to function properly.
sorry V0.2 for Windows only due to the clipboard use. V0.3 doesn't use the clipboard commands
Thanks to SMcNeil for the excellent text screen saving routines.
EDIT: V0.3 entries for all 3 programs are in a later post to this thread. Hopefully it will work on other systems.
![[Image: image.png]](https://i.ibb.co/R3kx1vz/image.png)
Code: (Select All)
'Ascii Clipdoodle V 0.2
'an ascii doodle pad that opens control panel apps in other windows
'
'sorry windows only
'
'loadtextimage and savetextimage from SMcNeil at https://qb64phoenix.com/forum/showthread.php?tid=2022
'
'pickclip.exe and colorpick16.exe must be compiled before this program will function properly
Dim Shared reflag
reflag = -1
Dim Shared helpscreen As Long
Dim Shared twd, tht
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
_Clipboard$ = "ClipDoodleOn" ' "clears" clipboard for use
Shell _DontWait "pickclip.exe" ' Open the pickclip control panel
Shell _DontWait "colorpick16.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
twid = _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 "R"
do_resize
Case "?" 'help
do_help
End Select
ik$ = _Clipboard$
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)
_Clipboard$ = "QUITCOLORPICK16"
Sleep 1
_Clipboard$ = "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 "C - to clear screen"
print "R - to Resize Screen (WARNING : DESTRUCTIVE)"
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
The color picker
Code: (Select All)
'colorpick16 0.2
'
'a color picker for mode 0 screens.
'compile as colorpick16.exe
'
Screen _NewImage(32, 8, 0)
_ScreenMove 600, 400
_Title "colorpick16"
blinkflag = -1
hflag = -1
FB = 0
BB = 0
print_picker FB, BB
Do
_Limit 100
Do While _MouseInput 'mouse status changes only
x = _MouseX
y = _MouseY
If _MouseButton(1) Then
If y >= 1 And y <= 2 Then
fk = (y - 1) * 8 + Int(x / 4) + FB
End If
Color fk, 0
If fk = 0 Then Color fk, 8
_PrintString (12, 4), " "
_PrintString (12, 4), Str$(fk)
If y = 7 Then
bk = Int(x / 4) + BB
End If
Color fk, bk
_PrintString (12, 5), " "
_PrintString (12, 5), Str$(bk)
_Clipboard$ = "CK" + _Trim$(Str$(fk)) + "/" + _Trim$(Str$(bk))
If x = 31 And y = 4 Then
blinkflag = blinkflag * -1
Select Case blinkflag
Case -1
FB = 0
BB = 0
print_picker FB, BB
Case 1
FB = 16
BB = 8
print_picker FB, BB
End Select
End If
End If
Loop
kk$ = InKey$
Select Case kk$
Case "B"
FB = 16
BB = 8
print_picker FB, BB
Case "b"
FB = 0
BB = 0
print_picker FB, BB
Case Chr$(27)
cc = _MessageBox("QUIT !", "Are you sure you wish to QUIT? The program will lose functionality. ", "yesnocancel", "warning", 0)
If cc = 1 Then cc = 1 Else kk$ = ""
End Select
ccheck$ = _Clipboard$
If ccheck$ = "QUITCOLORPICK16" Then kk$ = "QUITCOLORPICK16"
Loop Until kk$ = Chr$(27) Or kk$ = "QUITCOLORPICK16"
_Clipboard$ = "pickcolor quit"
System
Sub print_picker (f, b)
For y = 0 To 1
For x = 0 To 7
fk = y * 8 + x + f
p$ = "[ ]"
a$ = _Trim$(Str$(fk))
If Len(a$) = 1 Then
Mid$(p$, 3, 1) = a$
Else
Mid$(p$, 2, 2) = a$
End If
Color fk, 0
If fk = 0 Then Color 0, 7
_PrintString ((x + 1) * 4 - 3, y + 1), p$
Next
Next
_PrintString (31, 4), "B"
_PrintString (1, 4), "Foreground"
_PrintString (1, 5), "Background"
For x = 0 To 7
bk = x + b
p$ = "[ ]"
a$ = _Trim$(Str$(bk))
If bk < 8 Then Mid$(p$, 3, 1) = a$ Else Mid$(p$, 2, 2) = a$
Color 0, bk
If bk = 0 Then Color 15, 0
_PrintString ((x + 1) * 4 - 3, 7), p$
Next
fk = 15: bk = 0
End Sub
The ascii character picker.
Code: (Select All)
'colorpick16 0.2
'
'a color picker for mode 0 screens.
'compile as colorpick16.exe
'
Screen _NewImage(32, 8, 0)
_ScreenMove 600, 400
_Title "colorpick16"
blinkflag = -1
hflag = -1
FB = 0
BB = 0
print_picker FB, BB
Do
_Limit 100
Do While _MouseInput 'mouse status changes only
x = _MouseX
y = _MouseY
If _MouseButton(1) Then
If y >= 1 And y <= 2 Then
fk = (y - 1) * 8 + Int(x / 4) + FB
End If
Color fk, 0
If fk = 0 Then Color fk, 8
_PrintString (12, 4), " "
_PrintString (12, 4), Str$(fk)
If y = 7 Then
bk = Int(x / 4) + BB
End If
Color fk, bk
_PrintString (12, 5), " "
_PrintString (12, 5), Str$(bk)
_Clipboard$ = "CK" + _Trim$(Str$(fk)) + "/" + _Trim$(Str$(bk))
If x = 31 And y = 4 Then
blinkflag = blinkflag * -1
Select Case blinkflag
Case -1
FB = 0
BB = 0
print_picker FB, BB
Case 1
FB = 16
BB = 8
print_picker FB, BB
End Select
End If
End If
Loop
kk$ = InKey$
Select Case kk$
Case "B"
FB = 16
BB = 8
print_picker FB, BB
Case "b"
FB = 0
BB = 0
print_picker FB, BB
Case Chr$(27)
cc = _MessageBox("QUIT !", "Are you sure you wish to QUIT? The program will lose functionality. ", "yesnocancel", "warning", 0)
If cc = 1 Then cc = 1 Else kk$ = ""
End Select
ccheck$ = _Clipboard$
If ccheck$ = "QUITCOLORPICK16" Then kk$ = "QUITCOLORPICK16"
Loop Until kk$ = Chr$(27) Or kk$ = "QUITCOLORPICK16"
_Clipboard$ = "pickcolor quit"
System
Sub print_picker (f, b)
For y = 0 To 1
For x = 0 To 7
fk = y * 8 + x + f
p$ = "[ ]"
a$ = _Trim$(Str$(fk))
If Len(a$) = 1 Then
Mid$(p$, 3, 1) = a$
Else
Mid$(p$, 2, 2) = a$
End If
Color fk, 0
If fk = 0 Then Color 0, 7
_PrintString ((x + 1) * 4 - 3, y + 1), p$
Next
Next
_PrintString (31, 4), "B"
_PrintString (1, 4), "Foreground"
_PrintString (1, 5), "Background"
For x = 0 To 7
bk = x + b
p$ = "[ ]"
a$ = _Trim$(Str$(bk))
If bk < 8 Then Mid$(p$, 3, 1) = a$ Else Mid$(p$, 2, 2) = a$
Color 0, bk
If bk = 0 Then Color 15, 0
_PrintString ((x + 1) * 4 - 3, 7), p$
Next
fk = 15: bk = 0
End Sub
Posts: 1,581
Threads: 59
Joined: Jul 2022
Reputation:
52
Instead of sending text fragments to the clipboard, the fragments could be filenames that are created and could be checked with `_FILEEXISTS()`. But it could be better if somehow QB64 supported more than one `SCREEN` in a single program. 
Posts: 660
Threads: 142
Joined: Apr 2022
Reputation:
58
Ascii Clip V0.3
it doesn't use clipboard commands and instead reads and writes to a file all 3 apps read. Hopefully this will work on other platforms.
Code: (Select All)
'Ascii Clipdoodle V 0.3
'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
'
'pickclip03.exe and colorpick1603.exe must be compiled before this program will function properly
Dim Shared reflag
reflag = -1
Dim Shared helpscreen As Long
Dim Shared twd, tht
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 "pickclip03.exe" ' Open the pickclip control panel
Shell _DontWait "colorpick1603.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
twid = _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 "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 "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$
Close #11
get_msg$ = g$
End Function
colorpick1603
Code: (Select All)
'colorpick16 0.3
'
'a color picker for mode 0 screens.
'compile as colorpick1603.exe
'
Screen _NewImage(32, 8, 0)
_ScreenMove 600, 400
_Title "colorpick16"
blinkflag = -1
hflag = -1
FB = 0
BB = 0
print_picker FB, BB
Do
_Limit 100
Do While _MouseInput 'mouse status changes only
x = _MouseX
y = _MouseY
If _MouseButton(1) Then
If y >= 1 And y <= 2 Then
fk = (y - 1) * 8 + Int(x / 4) + FB
End If
Color fk, 0
If fk = 0 Then Color fk, 8
_PrintString (12, 4), " "
_PrintString (12, 4), Str$(fk)
If y = 7 Then
bk = Int(x / 4) + BB
End If
Color fk, bk
_PrintString (12, 5), " "
_PrintString (12, 5), Str$(bk)
' _Clipboard$ = "CK" + _Trim$(Str$(fk)) + "/" + _Trim$(Str$(bk))
cmsg$ = "CK" + _Trim$(Str$(fk)) + "/" + _Trim$(Str$(bk))
write_msg cmsg$
If x = 31 And y = 4 Then
blinkflag = blinkflag * -1
Select Case blinkflag
Case -1
FB = 0
BB = 0
print_picker FB, BB
Case 1
FB = 16
BB = 8
print_picker FB, BB
End Select
End If
End If
Loop
kk$ = InKey$
Select Case kk$
Case "B"
FB = 16
BB = 8
print_picker FB, BB
Case "b"
FB = 0
BB = 0
print_picker FB, BB
Case Chr$(27)
cc = _MessageBox("QUIT !", "Are you sure you wish to QUIT? The program will lose functionality. ", "yesnocancel", "warning", 0)
If cc = 1 Then cc = 1 Else kk$ = ""
End Select
' ccheck$ = _Clipboard$
ccheck$ = get_msg$
If ccheck$ = "QUITCOLORPICK16" Then kk$ = "QUITCOLORPICK16"
Loop Until kk$ = Chr$(27) Or kk$ = "QUITCOLORPICK16"
'_Clipboard$ = "pickcolor quit"
write_msg "pickcolor quit"
System
Sub print_picker (f, b)
For y = 0 To 1
For x = 0 To 7
fk = y * 8 + x + f
p$ = "[ ]"
a$ = _Trim$(Str$(fk))
If Len(a$) = 1 Then
Mid$(p$, 3, 1) = a$
Else
Mid$(p$, 2, 2) = a$
End If
Color fk, 0
If fk = 0 Then Color 0, 7
_PrintString ((x + 1) * 4 - 3, y + 1), p$
Next
Next
_PrintString (31, 4), "B"
_PrintString (1, 4), "Foreground"
_PrintString (1, 5), "Background"
For x = 0 To 7
bk = x + b
p$ = "[ ]"
a$ = _Trim$(Str$(bk))
If bk < 8 Then Mid$(p$, 3, 1) = a$ Else Mid$(p$, 2, 2) = a$
Color 0, bk
If bk = 0 Then Color 15, 0
_PrintString ((x + 1) * 4 - 3, 7), p$
Next
fk = 15: bk = 0
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$
Close #11
get_msg$ = g$
End Function
pickclip03
Code: (Select All)
'pickclip v0.3
'complie as pickclip03.exe
'sample of a "control panel" feeding output to the clipboard
Screen _NewImage(33, 20, 0)
_ScreenMove 600, 0
_Title "Pick Clip"
_ControlChr Off
AA = 0
'builds ascii grid
For y = 1 To 16
For x = 1 To 16
_PrintString (x * 2, y), Chr$(AA)
AA = AA + 1
Next
Next
Do
_Limit 100
Do While _MouseInput 'mouse status changes only
x = _MouseX
y = _MouseY
If _MouseButton(1) Then
x = Int(x / 2)
AK = (y - 1) * 16 + (x - 1)
_PrintString (1, 18), " "
If AK > -1 And AK < 256 Then
pp$ = "Picked ASCII " + Str$(AK) + " : " + Chr$(AK)
_PrintString (1, 18), pp$
'_Clipboard$ = "AC" + Str$(AK)
cmsg$ = "AC" + Str$(AK)
write_msg cmsg$
End If
End If
Loop
kk$ = InKey$
cmsg$ = get_msg$
' If _Clipboard$ = "QUITCLIPPICK" Then kk$ = "QUITALL"
If cmsg$ = "QUITCLIPPICK" Then kk$ = "QUITALL"
Loop Until kk$ = "QUITALL" Or kk$ = "Q"
'_Clipboard$ = "pickclip did quit" 'so QUIT message isn't left in clipboard
write_msg "pickclip did quit"
System
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$
Close #11
get_msg$ = g$
End Function
Posts: 477
Threads: 25
Joined: Nov 2022
Reputation:
45
Haha this is cool!
So how come you chose to put these in separate programs? Just curious
Posts: 660
Threads: 142
Joined: Apr 2022
Reputation:
58
10-17-2023, 04:40 PM
(This post was last modified: 10-17-2023, 04:41 PM by James D Jarvis.)
(10-17-2023, 06:34 AM)grymmjack Wrote: Haha this is cool!
So how come you chose to put these in separate programs? Just curious
An earlier version started as an experiment in multi-window programs. The user having control panels they can just move to where they like to fit their style and ease of use is also pretty handy and this is a pretty quick and easy way to do it. The user can also reset the size of the image they are drawing and this eliminates the need for dealing with dead space or trying to squeeze an image into a smaller space if the original program wasn't large enough, the other controls don't have to be resized or moved along with a change in the drawing size.
Posts: 1,581
Threads: 59
Joined: Jul 2022
Reputation:
52
10-17-2023, 05:01 PM
(This post was last modified: 10-17-2023, 05:03 PM by mnrvovrfc.
Edit Reason: Dumb typing mistakes
)
JDJ this is an awesome program! A bit clumsy to navigate three windows.
For this to work on Linux, there are a few fixes to be made in order. It is recommendable to choose what the filenames will be for the executable files of the ASCII and color pickers. Cannot end in EXE, because Debian doesn't like it for some reason. I'm running this on Spiral Linux GNOME with Debian "Bookworm" base.
It is suggested to use `_CWD$()` to create a full path of the program the command shell is told to execute:
Code: (Select All) thisdirectory$ = _CWD$ + "/"
Shell _DontWait thisdirectory$ + "jdjdoodleasciipick" ' Open the pickclip control panel
Shell _DontWait thisdirectory$ + "jdjdoodlecolorpick" ' Open the colorpick16 control panel
I revealed how I changed the filenames for the other two programs. 
I got an "Input Past End" runtime error for one of the pickers. It did not let me close the three programs together gracefully. It means must use `EOF()` everytime a line must be taken from an input file, in case that file is empty.
In line #54 of the ASCII picker:
Code: (Select All) if not eof(11) then Line Input #11, g$
In line #116 of the color picker:
Code: (Select All) if not eof(11) then Line Input #11, g$
Posts: 3,982
Threads: 178
Joined: Apr 2022
Reputation:
220
10-17-2023, 05:19 PM
(This post was last modified: 10-17-2023, 05:21 PM by bplus.)
Quote:So how come you chose to put these in separate programs? Just curious Smile
The answer is obvious to me, he now has 3 independent programs that can be used in other apps, no need for libraries or copy/paste from a Toolbox of handy sub and function tools.
I started same with a GUI GetPathedFilename Dialog that prints selection to file and Clipboard.
That's one less direntry.h file I have to include in library or app, thats' one section I dont have to debug.
Big savings in time and redundant code is the short answer!
PLUS I can count on title working correctly as opposed to some other dialogues we've seen.
A piece at a time, independent of all other code, is a very clean uncluttered approach.
b = b + ...
Posts: 660
Threads: 142
Joined: Apr 2022
Reputation:
58
(10-17-2023, 05:19 PM)bplus Wrote: Quote:So how come you chose to put these in separate programs? Just curious Smile
The answer is obvious to me, he now has 3 independent programs that can be used in other apps, no need for libraries or copy/paste from a Toolbox of handy sub and function tools.
I started same with a GUI GetPathedFilename Dialog that prints selection to file and Clipboard.
That's one less direntry.h file I have to include in library or app, thats' one section I dont have to debug.
Big savings in time and redundant code is the short answer!
PLUS I can count on title working correctly as opposed to some other dialogues we've seen.
A piece at a time, independent of all other code, is a very clean uncluttered approach.
All of those are excellent points. I remember when they used to pretend, we'd have more ability to mix and match pieces of software from different vendors on the big OS's and that never really materialized as much as I'd have liked. Almost there... 30-35 years later and we'll stay at almost.
Posts: 660
Threads: 142
Joined: Apr 2022
Reputation:
58
(10-17-2023, 05:01 PM)mnrvovrfc Wrote: JDJ this is an awesome program! A bit clumsy to navigate three windows.
For this to work on Linux, there are a few fixes to be made in order. It is recommendable to choose what the filenames will be for the executable files of the ASCII and color pickers. Cannot end in EXE, because Debian doesn't like it for some reason. I'm running this on Spiral Linux GNOME with Debian "Bookworm" base.
It is suggested to use `_CWD$()` to create a full path of the program the command shell is told to execute:
Code: (Select All) thisdirectory$ = _CWD$ + "/"
Shell _DontWait thisdirectory$ + "jdjdoodleasciipick" ' Open the pickclip control panel
Shell _DontWait thisdirectory$ + "jdjdoodlecolorpick" ' Open the colorpick16 control panel
I revealed how I changed the filenames for the other two programs.
I got an "Input Past End" runtime error for one of the pickers. It did not let me close the three programs together gracefully. It means must use `EOF()` everytime a line must be taken from an input file, in case that file is empty.
In line #54 of the ASCII picker:
Code: (Select All) if not eof(11) then Line Input #11, g$
In line #116 of the color picker:
Code: (Select All) if not eof(11) then Line Input #11, g$
Thanks for sharing the tips. I haven't used a linux distribution in ages so I really don't know how it works these days. The EOF is odd for me as I've never noticed it being a problem with LINE INPUT in such a simple file. Thanks for pointing it out.
Posts: 660
Threads: 142
Joined: Apr 2022
Reputation:
58
Updated the apps for hopefully better file reading as per advice from mnrvovrfc above. Folks using a system other than windows may still have to edit their shell commands.
Added the ability to save as a jpeg image thanks to the QB64 PE 3.9 update.
![[Image: image.png]](https://i.ibb.co/4pGNvDZ/image.png)
The mainprogram
Code: (Select All)
'Ascii Clipdoodle V 0.4
'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
'
'pickclip.exe and colorpick16.exe must be compiled before this program will function properly
Dim Shared reflag
reflag = -1
Dim Shared helpscreen As Long
Dim Shared twd, tht
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
twid = _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 "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 "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
the color picker control
Code: (Select All)
'colorpick16 0.4
'
'a color picker for mode 0 screens.
'compile as colorpick1604.exe or anythign else of course just make sure to use the same name in the main program
'
Screen _NewImage(32, 8, 0)
_ScreenMove 600, 400
_Title "colorpick16"
blinkflag = -1
hflag = -1
FB = 0
BB = 0
print_picker FB, BB
Do
_Limit 100
Do While _MouseInput 'mouse status changes only
x = _MouseX
y = _MouseY
If _MouseButton(1) Then
If y >= 1 And y <= 2 Then
fk = (y - 1) * 8 + Int(x / 4) + FB
End If
Color fk, 0
If fk = 0 Then Color fk, 8
_PrintString (12, 4), " "
_PrintString (12, 4), Str$(fk)
If y = 7 Then
bk = Int(x / 4) + BB
End If
Color fk, bk
_PrintString (12, 5), " "
_PrintString (12, 5), Str$(bk)
' _Clipboard$ = "CK" + _Trim$(Str$(fk)) + "/" + _Trim$(Str$(bk))
cmsg$ = "CK" + _Trim$(Str$(fk)) + "/" + _Trim$(Str$(bk))
write_msg cmsg$
If x = 31 And y = 4 Then
blinkflag = blinkflag * -1
Select Case blinkflag
Case -1
FB = 0
BB = 0
print_picker FB, BB
Case 1
FB = 16
BB = 8
print_picker FB, BB
End Select
End If
End If
Loop
kk$ = InKey$
Select Case kk$
Case "B"
FB = 16
BB = 8
print_picker FB, BB
Case "b"
FB = 0
BB = 0
print_picker FB, BB
Case Chr$(27)
cc = _MessageBox("QUIT !", "Are you sure you wish to QUIT? The program will lose functionality. ", "yesnocancel", "warning", 0)
If cc = 1 Then cc = 1 Else kk$ = ""
End Select
' ccheck$ = _Clipboard$
ccheck$ = get_msg$
If ccheck$ = "QUITCOLORPICK16" Then kk$ = "QUITCOLORPICK16"
Loop Until kk$ = Chr$(27) Or kk$ = "QUITCOLORPICK16"
'_Clipboard$ = "pickcolor quit"
write_msg "pickcolor quit"
System
Sub print_picker (f, b)
For y = 0 To 1
For x = 0 To 7
fk = y * 8 + x + f
p$ = "[ ]"
a$ = _Trim$(Str$(fk))
If Len(a$) = 1 Then
Mid$(p$, 3, 1) = a$
Else
Mid$(p$, 2, 2) = a$
End If
Color fk, 0
If fk = 0 Then Color 0, 7
_PrintString ((x + 1) * 4 - 3, y + 1), p$
Next
Next
_PrintString (31, 4), "B"
_PrintString (1, 4), "Foreground"
_PrintString (1, 5), "Background"
For x = 0 To 7
bk = x + b
p$ = "[ ]"
a$ = _Trim$(Str$(bk))
If bk < 8 Then Mid$(p$, 3, 1) = a$ Else Mid$(p$, 2, 2) = a$
Color 0, bk
If bk = 0 Then Color 15, 0
_PrintString ((x + 1) * 4 - 3, 7), p$
Next
fk = 15: bk = 0
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
the character picker for the "paintbrush"
Code: (Select All)
'pickclip v0.4
'complie as pickclip04.exe or whatever you wish to call it in your main program
'sample of a "control panel" feeding output to the clipboard
Screen _NewImage(33, 20, 0)
_ScreenMove 600, 0
_Title "Pick Clip"
_ControlChr Off
AA = 0
'builds ascii grid
For y = 1 To 16
For x = 1 To 16
_PrintString (x * 2, y), Chr$(AA)
AA = AA + 1
Next
Next
Do
_Limit 100
Do While _MouseInput 'mouse status changes only
x = _MouseX
y = _MouseY
If _MouseButton(1) Then
x = Int(x / 2)
AK = (y - 1) * 16 + (x - 1)
_PrintString (1, 18), " "
If AK > -1 And AK < 256 Then
pp$ = "Picked ASCII " + Str$(AK) + " : " + Chr$(AK)
_PrintString (1, 18), pp$
'_Clipboard$ = "AC" + Str$(AK)
cmsg$ = "AC" + Str$(AK)
write_msg cmsg$
End If
End If
Loop
kk$ = InKey$
cmsg$ = get_msg$
' If _Clipboard$ = "QUITCLIPPICK" Then kk$ = "QUITALL"
If cmsg$ = "QUITCLIPPICK" Then kk$ = "QUITALL"
Loop Until kk$ = "QUITALL" Or kk$ = "Q"
'_Clipboard$ = "pickclip did quit" 'so QUIT message isn't left in clipboard
write_msg "pickclip did quit"
System
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
|
