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)
The color picker
The ascii character picker.
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.
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 SubThe 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