Posts: 688
Threads: 154
Joined: Apr 2022
Reputation:
67
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
Posts: 688
Threads: 154
Joined: Apr 2022
Reputation:
67
Version 0.6
I've renamed it but it still belongs here in this thread.
I added a button bar for a number of the commands and while it's functional it's producing a weird error where commands repeat.
I've actually used this on a couple of my own programs lately so I figured it was worth sharing. Even used it to make the button bar graphic itself for the program.
The How To once the program(s) are running.
use mouse to draw with ascii characters
select character to draw and colors from control panels
key commands:
<ESC> to quit program
t,T - To type a line of text in colors picked
S - To Save image
L,O - to Load a saved image
J -save as jpeg file.
B - export image as a standard qb64 Basic source file . builds to copy and paste and edit comments to make a full program if you just want to display your masterful work of ascii art. This doesn't save blinking attribute as of yet.
C - to clear image
?,H - help
R - Resize image (destructive, this wipes out the working image)
Compile the control panel programs and leave them in the same folder/directory as the main program before running the main program or its just not going to work.
Code: (Select All)
'Asciidoodle V 0.6
'compiled with latest version of QB64-Phonex Edition , not all commands have been updated so may complie with earleir versions
'an ascii doodle pad that opens control panel apps in other window
'an earleir version of this was called aclipdoodle but I stopped using the clipboard
'so there is a name swith
'
'loadtextimage and savetextimage from SMcNeil at https://qb64phoenix.com/forum/showthread.php?tid=2022
'
'pickchar06.exe and colorpick06.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. the user can resize anyway
Screen mainscreen
_Title "Ascii Doodle v0.6"
Cls
'open cdoodle.tlk
write_msg "ClipDoodleOn"
Sleep 1
'_Clipboard$ = "ClipDoodleOn" ' "clears" clipboard for use
Shell _DontWait "pickchar06.exe" ' Open the pickclip control panel
Shell _DontWait "colorpick06.exe" ' Open the colorpick16 control panel
Shell _DontWait "buttonbar06.exe" ' Open the colorpick16 control panel
_ControlChr Off
AK = 42
ik$ = " "
quitflag$ = "RUN"
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$
If Left$(ik$, 2) = "BC" Then 'handle messages from buttonbar
rc$ = Right$(ik$, 2)
Select Case rc$
Case "SS"
_KeyClear: kk$ = "S": ik$ = " ": write_msg "didsave"
Case "LS"
_KeyClear: kk$ = "L": ik$ = " ": write_msg "didload"
Case "BB"
_KeyClear: kk$ = "B": ik$ = " ": write_msg "didbasic"
Case "JJ"
_KeyClear: kk$ = "J": ik$ = " ": write_msg "didjpeg "
Case "RR"
_KeyClear: kk$ = "R": ik$ = " ": write_msg " didresize"
Case "CS"
_KeyClear: kk$ = "C": ik$ = " ": write_msg "didclear "
Case "HH"
_KeyClear: kk$ = "?": ik$ = " ": write_msg "didhelp"
Case "QQ"
_KeyClear: kk$ = Chr$(27): ik$ = " ": write_msg "didquit"
End Select
End If
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)
kk$ = ""
Case "S", "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
kk$ = ""
Case "L", "O", "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
kk$ = ""
Case "C", "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", "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: kk$ = ""
Case "B", "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: kk$ = ""
Case "R", "r"
do_resize: kk$ = ""
Case "?", "H", "h" 'help
do_help
kk$ = ""
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) Or quitflag$ = "QUITALL"
write_msg "QUITCOLORPICK16"
Sleep 1
write_msg "QUITCHARPICK"
Sleep 1
write_msg "QUITBBAR"
Sleep 1
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 " ?,H - this help 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
Code: (Select All)
'pickclip v0.6
'complie as pickchar06.exe or whatever you wish to call it in your main program
'
'this is a charcter selection control panel for the main program asciidoodle v0.6
Screen _NewImage(33, 20, 0)
_ScreenMove 600, 0
_Title "Pick Char"
_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$
cmsg$ = "AC" + Str$(AK)
write_msg cmsg$
End If
End If
Loop
kk$ = InKey$
cmsg$ = get_msg$
If cmsg$ = "QUITCHARPICK" Then kk$ = "QUITALL"
Loop Until kk$ = "QUITALL" Or kk$ = "Q"
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
Code: (Select All)
'Button Bar v0.6
' this is a compaion porgam that serves a contorl bar for the program asciidoodle
'
'complie as buttonbar06.exe or whatever you wish to call it in your main program
'
'this is a charcter selection control panel for the main program asciidoodle v0.6
Screen _NewImage(16, 19, 0)
_ScreenMove 700, 0
_Title "ButtonBar"
_ControlChr Off
AA = 0
Type button_type
bx As Integer
by As Integer
txt As String
bgk As _Unsigned Long
fgk As _Unsigned Long
End Type
Dim Shared btn(9) As button_type
Dim Shared kcmd$(9)
kcmd$(1) = "SS": kcmd$(2) = "LS": kcmd$(3) = "BB"
kcmd$(4) = "JJ": kcmd$(5) = "RR": kcmd$(6) = "CS"
kcmd$(7) = "HH": kcmd$(8) = " ": kcmd$(9) = "QQ"
setupbuttons
Print_controlbar1 1, 1
For b = 1 To 9
printbuttontext (b)
Next b
Color 15, 0
Do
_Limit 100
Do While _MouseInput 'mouse status changes only
x = _MouseX
y = _MouseY
If _MouseButton(1) Then
bb = Int(y \ 2)
Select Case bb
Case 1, 2, 3, 4, 5, 6, 7, 9
flashbuttontext (bb)
cmsg$ = "BC" + kcmd$(bb)
write_msg cmsg$
End Select
End If
Loop
kk$ = InKey$
cmsg$ = get_msg$
If cmsg$ = "QUITBBAR" Then kk$ = "QUITALL"
If cmsg$ = "QUITALL" Then kk$ = "QUITALL"
Loop Until kk$ = "QUITALL" Or kk$ = "Q"
write_msg "buttonbar 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
Sub Print_controlbar1 (px, py)
' color 0,0 is treated as transparent if character 32 is being printed, adjust comments if desired
_ControlChr Off
Color 14, 7: _PrintString (px + 0, py + 0), String$(1, 213)
Color 14, 7: _PrintString (px + 1, py + 0), String$(14, 205)
Color 14, 7: _PrintString (px + 15, py + 0), String$(1, 184)
Color 14, 7: _PrintString (px + 0, py + 1), String$(0, 184)
Color 14, 7: _PrintString (px + 0, py + 1), String$(1, 179)
Color 7, 0: _PrintString (px + 1, py + 1), String$(14, 32)
Color 14, 7: _PrintString (px + 15, py + 1), String$(1, 179)
Color 14, 7: _PrintString (px + 0, py + 2), String$(0, 179)
Color 14, 7: _PrintString (px + 0, py + 2), String$(1, 198)
Color 14, 7: _PrintString (px + 1, py + 2), String$(14, 205)
Color 14, 7: _PrintString (px + 15, py + 2), String$(1, 181)
Color 14, 7: _PrintString (px + 0, py + 3), String$(0, 181)
Color 14, 7: _PrintString (px + 0, py + 3), String$(1, 179)
Color 7, 0: _PrintString (px + 1, py + 3), String$(14, 32)
Color 14, 7: _PrintString (px + 15, py + 3), String$(1, 179)
Color 14, 7: _PrintString (px + 0, py + 4), String$(0, 179)
Color 14, 7: _PrintString (px + 0, py + 4), String$(1, 198)
Color 14, 7: _PrintString (px + 1, py + 4), String$(14, 205)
Color 14, 7: _PrintString (px + 15, py + 4), String$(1, 181)
Color 14, 7: _PrintString (px + 0, py + 5), String$(0, 181)
Color 14, 7: _PrintString (px + 0, py + 5), String$(1, 179)
Color 7, 0: _PrintString (px + 1, py + 5), String$(14, 32)
Color 14, 7: _PrintString (px + 15, py + 5), String$(1, 179)
Color 14, 7: _PrintString (px + 0, py + 6), String$(0, 179)
Color 14, 7: _PrintString (px + 0, py + 6), String$(1, 198)
Color 14, 7: _PrintString (px + 1, py + 6), String$(14, 205)
Color 14, 7: _PrintString (px + 15, py + 6), String$(1, 181)
Color 14, 7: _PrintString (px + 0, py + 7), String$(0, 181)
Color 14, 7: _PrintString (px + 0, py + 7), String$(1, 179)
Color 7, 0: _PrintString (px + 1, py + 7), String$(14, 32)
Color 14, 7: _PrintString (px + 15, py + 7), String$(1, 179)
Color 14, 7: _PrintString (px + 0, py + 8), String$(0, 179)
Color 14, 7: _PrintString (px + 0, py + 8), String$(1, 198)
Color 14, 7: _PrintString (px + 1, py + 8), String$(14, 205)
Color 14, 7: _PrintString (px + 15, py + 8), String$(1, 181)
Color 14, 7: _PrintString (px + 0, py + 9), String$(0, 181)
Color 14, 7: _PrintString (px + 0, py + 9), String$(1, 179)
Color 7, 0: _PrintString (px + 1, py + 9), String$(14, 32)
Color 14, 7: _PrintString (px + 15, py + 9), String$(1, 179)
Color 14, 7: _PrintString (px + 0, py + 10), String$(0, 179)
Color 14, 7: _PrintString (px + 0, py + 10), String$(1, 198)
Color 14, 7: _PrintString (px + 1, py + 10), String$(14, 205)
Color 14, 7: _PrintString (px + 15, py + 10), String$(1, 181)
Color 14, 7: _PrintString (px + 0, py + 11), String$(0, 181)
Color 14, 7: _PrintString (px + 0, py + 11), String$(1, 179)
Color 7, 0: _PrintString (px + 1, py + 11), String$(14, 32)
Color 14, 7: _PrintString (px + 15, py + 11), String$(1, 179)
Color 14, 7: _PrintString (px + 0, py + 12), String$(0, 179)
Color 14, 7: _PrintString (px + 0, py + 12), String$(1, 198)
Color 14, 7: _PrintString (px + 1, py + 12), String$(14, 205)
Color 14, 7: _PrintString (px + 15, py + 12), String$(1, 181)
Color 14, 7: _PrintString (px + 0, py + 13), String$(0, 181)
Color 14, 7: _PrintString (px + 0, py + 13), String$(1, 179)
Color 7, 0: _PrintString (px + 1, py + 13), String$(14, 32)
Color 14, 7: _PrintString (px + 15, py + 13), String$(1, 179)
Color 14, 7: _PrintString (px + 0, py + 14), String$(0, 179)
Color 14, 7: _PrintString (px + 0, py + 14), String$(1, 212)
Color 14, 7: _PrintString (px + 1, py + 14), String$(14, 205)
Color 14, 7: _PrintString (px + 15, py + 14), String$(1, 190)
Color 14, 7: _PrintString (px + 0, py + 15), String$(0, 190)
Color 0, 7: _PrintString (px + 0, py + 15), String$(16, 176)
'Color 0, 7: _PrintString (px + 0, py + 16), String$(16, 176)
' Color 0, 7: _PrintString (px + 0, py + 17), String$(16, 176)
Color 0, 7: _PrintString (px + 0, py + 16), String$(0, 176)
Color 14, 7: _PrintString (px + 0, py + 16), String$(1, 213)
Color 14, 7: _PrintString (px + 1, py + 16), String$(14, 205)
Color 14, 7: _PrintString (px + 15, py + 16), String$(1, 184)
Color 14, 7: _PrintString (px + 0, py + 17), String$(0, 184)
Color 14, 7: _PrintString (px + 0, py + 17), String$(1, 179)
Color 7, 0: _PrintString (px + 1, py + 17), String$(14, 32)
Color 14, 7: _PrintString (px + 15, py + 17), String$(1, 179)
Color 14, 7: _PrintString (px + 0, py + 18), String$(0, 179)
Color 14, 7: _PrintString (px + 0, py + 18), String$(1, 212)
Color 14, 7: _PrintString (px + 1, py + 18), String$(14, 205)
Color 14, 7: _PrintString (px + 15, py + 18), String$(1, 190)
End Sub
Sub setupbuttons
For b = 1 To 9
btn(b).bx = 2: btn(b).by = b * 2
btn(b).bgk = 7
btn(b).fgk = 0
Next
btn(1).txt = " Save SAV "
btn(2).txt = " Load SAV "
btn(3).txt = " export Basic "
btn(4).txt = " export Jpeg "
btn(5).txt = " Resize image "
btn(6).txt = " Clear screen "
btn(7).txt = " Help "
btn(9).txt = " Quit "
End Sub
Sub printbuttontext (b)
If b <> 8 Then
Color btn(b).fgk, btn(b).bgk
_PrintString (btn(b).bx, btn(b).by), btn(b).txt
Color 15, 0
End If
End Sub
Sub flashbuttontext (b)
If b <> 8 Then
Color 31, 9
_PrintString (btn(b).bx, btn(b).by), btn(b).txt
_Delay 0.4
Color btn(b).fgk, btn(b).bgk
_PrintString (btn(b).bx, btn(b).by), btn(b).txt
Color 15, 0
End If
End Sub
Code: (Select All)
'colorpick v0.6
'this is a color picker contorl panel that is part of asciidoodle v0.6
'
'a color picker for mode 0 screens.
'compile as colorpick06.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 "ColorPick"
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
|
