10-19-2023, 08:08 PM
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
the color picker control
the character picker for the "paintbrush"
Added the ability to save as a jpeg image thanks to the QB64 PE 3.9 update.
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 Functionthe 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 Functionthe 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