I can draw the actual clock dial to an image.
Code: Select all
Function GetClock(im as any ptr=0) As String
Dim As String fbHORSE = _
"S1C0BM345,150M+5,-27M+3,-25M+4,-21M+6,-10M+15,-10"_
&"M+5,-4M+11,-4M+8,0M+2,4M+48,1M+15,7"_
&"M+15,7M+12,10M+12,13M+19,27M+7,15M+6,13"_
&"M+7,7M+23,5M+39,-9M+37,-10M+20,-1M+24,3"_
&"M+30,5M+18,-10M+34,-23M+15,-3M+18,6M+15,11"_
&"M+12,15M+2,28M+5,39M+-5,18M+-17,38M+-7,14"_
&"M+-20,34M+-12,21M+-4,9M+-2,3M+-1,37M+4,9"_
&"M+-4,1M+-9,-7M+-7,-17M+-3,-30M+6,-38M+23,-59"_
&"M+4,-29M+-3,-21M+-13,-17M+-10,-6M+-13,-4M+-17,0"_
&"M+-6,3M+5,18M+11,28M+0,27M+-3,15M+-7,13"_
&"M+-10,16M+-12,11M+-9,11M+-9,10M+6,19M+8,13"_
&"M+5,6M+6,12M+-4,11M+-12,17M+-14,13M+-10,13"_
&"M+-8,13M+-7,10M+-4,11M+-12,6M+-8,3M+-5,11"_
&"M+0,6M+-28,-9M+3,-12M+8,-8M+13,-7M+8,-5"_
&"M+12,-10M+9,-16M+10,-15M+12,-15M+0,-10M+-3,-13"_
&"M+-2,-8M+-5,1M+-3,12M+-8,9M+-12,13M+-10,13"_
&"M+-7,16M+-8,15M+-5,8M+-8,11M+-9,9M+-13,12"_
&"M+-3,9M+273,4M+0,13M+-382,-1M+-1,-12M+71,-3"_
&"M+20,-21M+27,-20M+28,-41M+6,-14M+5,-20M+-19,-35"_
&"M+-7,-10M+-8,-7M+-9,-4M+-16,7M+-12,3M+-29,0"_
&"M+-22,1M+-14,21M+-13,27M+-13,19M+-12,30M+-7,22"_
&"M+-4,19M+-7,22M+31,3M+-1,15M+-171,-1M+-2,-13"_
&"M+95,-2M+13,-8M+15,-9M+8,-13M+8,-21M+5,-32"_
&"M+5,-22M+9,-21M+8,-22M+8,-19M+-3,-4M+-17,5"_
&"M+-9,3M+-69,0M+-4,7M+-4,12M+5,17M+9,10"_
&"M+13,14M+11,10M+10,3M+12,4M+4,11M+-2,12"_
&"M+-8,7M+-8,-4M+-20,-14M+-15,-13M+-36,-56M+-2,-19"_
&"M+7,-14M+15,-8M+48,-20M+-7,-26M+5,-11M+1,-11"_
&"M+7,-7M+6,-11M+8,-18M+3,-18M+-1,-14M+-4,-10"_
&"M+-6,-11M+-8,1M+-14,12M+-7,10M+-3,15M+-6,8"_
&"M+-12,-2M+-16,-6M+-4,-17M+1,-16"_
&"BM+191,77P4294967295,0"
Dim As String S1,tmp
dim as long Xpos=400,Ypos=300,rad=395
#macro thickline(x,y,x2,y2,thickness,col,g,flag2)
Scope
Dim As Long xc,yc
Var _x=Int(x),_y=Int(y),_x2=Int(x2),_y2=Int(y2)
Dim As Single h=Sqr((_x2-_x)*(_x2-_x)+(_y2-y)*(_y2-y)) 'hypotenuse
Dim As Single s=(y-_y2)/h 'sine
Dim As Single c=(_x2-_x)/h 'cosine
If flag2=1 Then
g+="S6BM" & (_x) & "," & (_y)'hands
xc=(_x+_x2)\2:yc=(_y+_y2)\2
Else
g+="S6BM" & (xpos) & "," & (ypos)'digits
g+="BM+" & (_x-xpos) & "," & (_y-ypos)
xc=((_x+_x\2)-xpos\2+c*thickness):yc=((_y+_y\2)-ypos\2-s*thickness)
End If
g+="C" & col
g+="M+" & (s*thickness\2) & "," & (c*thickness\2)
g+="M+" & (_x2-_x) & "," & (_y2-_y)
g+="M+" & (-s*thickness\1) & "," & (-c*thickness\1)
g+="M+" & (_x-_x2) & "," & (_y-_y2)
g+="M+" & (s*thickness\1) & "," & (c*thickness\1)
g+="BM" & (xc) & "," & (yc) & "P" & (col+2) & "," & col
End Scope
#endmacro
#define rd .0174532925199433
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
#macro mod12(n,m)
m= n Mod 12
If m=0 Then m=12
#endmacro
#macro lineto(xx1,yy1,xx2,yy2,d,col,flag2,fract)
thickline(xx1,yy1,(xx1+(xx2-xx1)*d),(yy1+(yy2-yy1)*d),(rad/fract),col,tmp,flag2)
s1+=tmp
#endmacro
#macro drawline(x,y,ang,length,col,x2,y2,flag,flag2)
ang2=ang:ang2=ang2*.0174532925199433
x2=(x)+length*Cos(ang2)
y2=(y)-length*Sin(ang2)
If flag>1 Then :thickline(x,y,x2,y2,(rad/flag),col,tmp,flag2):s1+=tmp:End If
#endmacro
#macro one(x,y,fract,a)
drawline((x+210*Cos((90-a)*rd)),(y-210*Sin((90-a)*rd)),90-(a),fract,grey,tmp1,tmp2,100,1)
#endmacro
#macro V(x,y,fract,a)
drawline((x+210*Cos((90-a)*rd)),(y-210*Sin((90-a)*rd)),90-(a-12),fract,grey,tmp1,tmp2,100,1)
drawline((x+210*Cos((90-a)*rd)),(y-210*Sin((90-a)*rd)),90-(a+12),fract,grey,tmp1,tmp2,100,1)
#endmacro
#macro X(x,y,fract,a)
drawline((x+210*Cos((90-(a+2))*rd)),(y-210*Sin((90-(a+2))*rd)),90-(a-18),fract,grey+1,tmp1,tmp2,100,1)
drawline((x+210*Cos((90-(a-2))*rd)),(y-210*Sin((90-(a-2))*rd)),90-(a+18),fract,grey,tmp1,tmp2,100,1)
#endmacro
Dim As Ulong grey =Rgb(220,220,221)
Static As Long newsm,firstrun,firstmin
Static As Single firstfrac
Dim As Long m2
Dim As Single b1,b2,tmp1,tmp2,ang2
Static As Single delta,secs
if im<>0 then
'numbers
one(400,300,30,30) '1
one(400,300,30,58.75) '2
one(400,300,30,61.25)
one(400,300,30,87.5) '3
one(400,300,30,90)
one(400,300,30,92.5)
one(400,300,30,117.5) '4
V(400,300,30,122.5)
V(400,300,30,150) '5
V(400,300,30,177.5) '6
one(400,300,30,182.5)
V(400,300,30,207.5) '7
one(400,300,30,212.5)
one(400,300,30,215)
V(400,300,30,236) '8
one(400,300,30,241)
one(400,300,30,243.5)
one(400,300,30,246)
one(400,300,30,266.5)
X(400,300,32,271) '9
X(400,300,32,300) '10
X(400,300,32,329) '11
one(400,300,30,333.5)
X(400,300,32,357) '12
one(400,300,30,1.5)
one(400,300,30,4.5)
end if
If firstrun=0 Then
newsm=Valint(Mid(Time,4,2))
firstrun=1
delta=Timer
firstfrac=Valint(Right(Time,2))
End If
Dim As String t=Time
Dim As Single hm=Valint(Left(t,2)),mm=Valint(Mid(t,4,2))
If newsm<>mm Then
firstmin=1
delta=Timer
End If
newsm=mm
If firstmin=0 Then secs=(Timer-delta)+firstfrac Else secs=(Timer-delta)
mod12(hm,m2)
Dim As Single h=map(0,12,m2,360,0)
Dim As Single m=map(0,60,mm,360,0)
Dim As Single s=map(0,60,(secs),360,0)
Dim As Long R=rad/2
if im<>0 then
For z As Long=0 To 359 Step 6
drawline((Xpos),(Ypos),z,R,15,b1,b2,1,0)
If z=90 Then: lineto(b1,b2,(Xpos),(Ypos),.1,Rgb(200,0,0),0,50):End If
If z Mod 30=0 Then
If z<>90 Then: lineto(b1,b2,(Xpos),(Ypos),.1,Rgb(200,0,0),0,50) :End If
Else
lineto(b1,b2,Xpos,Ypos,.05,Rgb(0,0,200),0,50)
End If
Next z
else
drawline(Xpos,Ypos,(h+90)-5*(360-m)/60,.6*R,Rgb(10,100,200),tmp1,tmp2,50,1)'hour
drawline(Xpos,Ypos,(m+90)-(360-s)/60,.85*R,Rgb(10,100,201),tmp1,tmp2,50,1) 'minute
drawline(Xpos,Ypos,(s+90),.92*R,Rgb(150,0,0),tmp1,tmp2,100,1) 'second
end if
if im<>0 then draw im, fbHORSE+ s1
Function= s1
End Function
'=========================== START =====================>>
Screen 19,32
dim as any ptr image=imagecreate(800,600,rgb(200,200,200))
GetClock(image) 'init image with dial
windowtitle "Roman Clock"
Do
Var clockstring= GetClock
Screenlock
Cls
put(0,0),image,pset
Draw Clockstring
Screenunlock
Sleep 1,1
Loop Until Inkey=Chr(27)
Sleep
imagedestroy image
It a little more cpu friendly.
Code: Select all
'Mouse driven point to point editor.
'Press esc to end with choice of saving.
'right click screen to undo an instruction
dim as string bitmap= "horse.bmp"'if bitmap is valid it will load
dim as integer bitmapFlag
dim as string d
Dim Shared As Integer xres,yres
#define shaped 16
#define alphablend 64
#define OnTop 32
#define GetWindowHandle 2
Screeninfo xres,yres
'xres=800
'yres=600
Screenres int(.9*xres),int(.9*yres),32,,SHAPED Or ALPHABLEND Or ONTOP
Type v2
As Integer x,y
col As Ulong
as ushort Bits
End Type
Function Size(bmp As String) As V2 'get bitmap width/height/ colour resolution
dim as V2 b
Open bmp For Binary access read As #1
Get #1, 19, b.X
Get #1, 23, b.Y
get #1, 29, b.Bits
Close #1
Return b
End Function
declare function FileLen alias "fb_FileLen" ( byval filename as zstring ptr ) as longint
declare function FileExists alias "fb_FileExists" ( byval filename as zstring ptr ) as integer
dim as any ptr bitmapim
if FileExists(bitmap) then
bitmapflag=1
var sz=size(bitmap)
bitmapim=imagecreate(sz.x,sz.y)
bload bitmap,bitmapim
end if
Dim Shared As Integer monitorX,monitorY
Dim Shared As Integer WinposX,WinposY
Screeninfo monitorX,monitorY
'set up for opaque screen
Extern "windows" Lib "user32"
Declare Function GetDC Alias "GetDC" (Byval As Any Ptr) As Any Ptr
End Extern
Extern "windows" Lib "gdi32"
Declare Function _point Alias "GetPixel"(Byval As Any Ptr,Byval As Integer,Byval As Integer) As Ulong
End Extern
Declare Function SLWA Alias "SetLayeredWindowAttributes" (Byval As Any Ptr, Byval As Uinteger, Byval As Ubyte, Byval As Integer) As Integer
Declare Function NoConsole Alias "FreeConsole" As Integer
Declare Function _getmouse Alias "GetCursorPos" (Byval As Any Pointer) As Integer
declare function showconsole alias "AllocConsole"() as integer
Sub BlendWindow( Byval Alpha_Value As Ubyte )
Dim Win As Any Ptr
var Ip = Cptr(Integer Ptr,@Win )
Screencontrol GETWINDOWHANDLE, *Ip
SLWA Win,Rgba(255,0,255,0),Alpha_Value,2 Or 1
End Sub
'---------------------------------------
Type Point
As Single x,y,r
As Integer counter
As Ulong col
End Type
Type screenpoint
As long x,y
End Type
Sub getmoose(Byref mx As Integer,Byref my As Integer,byref mb as integer=0,byref mw as integer=0)
getmouse mx,my,mw,mb
#define _map(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))/((b)-(a))+(c)
ScreenControl 0, WinposX,WinposY
Dim As screenpoint mouse=Type<screenpoint>(mx,my)
_getmouse(@mouse)
mx=_map(0,MonitorX,mouse.x-WinposX,0,MonitorX)
my=_map(0,monitorY,mouse.y-WinposY,0,MonitorY)
End Sub
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
#define inpoint(c,mx,my) (mx)>(c.x-c.r) And (mx)<(c.x+c.r) And (my)>(c.y-c.r) And (my)<(c.y+c.r)
#define Red(col) cptr(ubyte ptr,@col)[2]
#define Green(col) cptr(ubyte ptr,@col)[1]
#define Blue(col) cptr(ubyte ptr,@col)[0]
dim shared as integer sx=50,sy=50 'screen start position
Sub moveall
Dim As Integer mx,my,mb,x,y,dx,dy
Static As Integer lastmx,lastmy
Getmouse mx,my,,mb
Screencontrol 0, x, y
Static As Integer pressed,moved
If mb=1 Then pressed=-1 else pressed=0
If lastmx<>mx Or lastmy<>my Then moved=-1 Else moved=0
If moved Then dx=lastmx-mx:dy=lastmy-my
If pressed And moved Then
Screencontrol 100, x-dx, y - dy
sx=x-dx:sy=y-dy
pressed=0
Exit Sub
End If
lastmx=mx:lastmy=my
End Sub
sub traceover(a() as point, col as ulong,l as integer,im as any ptr=0)
for n as integer=l to ubound(a)-1
line im,(a(n).x,a(n).y)-(a(n+1).x,a(n+1).y),col
next n
end sub
Dim As Point c(1 To 5) 'the four boxes on top
Redim As Point Ccolours(0) 'the coloured boxes below
Redim As Point s(0) 'the array running parallel(Legacy from an older program, but still handy)
Dim As Point slide(1 To 3) 'the colour slider circles
Dim As Any Pointer im=imagecreate(.9*xres,.9*yres,Rgb(0,0,0))
Screeninfo xres,yres
Dim As Any Ptr MyScreen = GetDC(0)
'slider ball circles
slide(1).y=.92*yres:slide(1).r=5:slide(1).col=Rgb(200,0,0)
slide(2).y=.94*yres:slide(2).r=5:slide(2).col=Rgb(0,200,0)
slide(3).y=.96*yres:slide(3).r=5:slide(3).col=Rgb(0,0,200)
'the three larger circles
c(1).x=.3*xres:c(1).y=20:c(1).r=10
c(2).x=.5*xres:c(2).y=20:c(2).r=10
c(3).x=.9*xres:c(3).y=20:c(3).r=10
c(4).x=.7*xres:c(4).y=20:c(4).r=10
c(5).x=.1*xres:c(5).y=25:c(5).r=10
'========= DRAW STUFF TO AN IMAGE ================
'The colour boxes
dim as string border=Str(Rgb(0,200,0))',lastborder,starter
Line im,(0,0)-(xres,50),Rgb(100,100,255),bf
Dim As Integer ypos=.9*yres
Dim As Integer _st=.4*xres/25
Dim As Ulong col,tally,total,delta1
Line im,(0,.9*yres)-(xres,yres),Rgb(100,100,255),bf
Line im,(.6*xres,.92*yres)-(.75*xres,.92*yres),Rgb(200,0,0)
Line im,(.6*xres,.94*yres)-(.75*xres,.94*yres),Rgb(0,200,0)
Line im,(.6*xres,.96*yres)-(.75*xres,.96*yres),Rgb(0,0,200)
For y As Integer=_st To 4*_st Step _st
tally+=1
For x As Integer=.1*xres To .5*xres Step _st
total+=1
delta1=map((.1*xres),(.5*xres),x,0,254)
Select Case tally
Case 1: col=Rgb(255,delta1,0)
Case 2:col=Rgb(0,255,delta1)
Case 3:col=Rgb(delta1,0,255)
Case 4:col=Rgb(255-delta1,255-delta1,255-delta1)
End Select
Redim Preserve Ccolours(1 To total)
Ccolours(total)=Type<Point>(x,ypos+y-_st,_st,0,col)
Line im,(x-_st/2,ypos-_st/2+y)- (x+_st/2,ypos+_st/2+y),col,bf
Line im,(x-_st/2,ypos-_st/2+y)- (x+_st/2,ypos+_st/2+y),rgb(0,0,0),b
Next x
Next y
'================= GRID AND CIRCLES =======================
For x As Integer=0 To xres Step 50
Line im,(x,50)-(x,yres),Rgba(255,255,255,200)'50 before
Next x
For y As Integer=50 To yres Step 50
Line im,(0,y)-(xres,y),Rgba(255,255,255,200)
Next y
For z As Integer=1 To 4
line im,(c(z).x-c(z).r,c(z).y-c(z).r)-(c(z).x+c(z).r,c(z).y+c(z).r),Rgb(255,255,255),b
'Circle im,(c(z).x,c(z).y),c(z).r+1,Rgb(255,255,255)
Next z
if bitmapflag=1 then line im,(c(5).x-c(5).r,c(5).y-c(5).r)-(c(5).x+c(5).r,c(5).y+c(5).r),Rgb(255,255,255),b
Line im,(0,.9*yres)-(xres,.9*yres),Rgb(0,200,0)
Draw String im,(c(1).x-150,c(1).y),"NEW POINTS -->"
Draw String im,(c(2).x-80,c(2).y),"FILL -->"
Draw String im,(5,5), "SCREEN RESOLOTIONS = " &xres-1 &"," &yres-1
Draw String im,(.9*xres-50,35),"SCREEN TOGGLE"
Draw String im,(.7*xres-70,35),"SEE THROUGH TOGGLE"
if bitmapflag=1 then
Draw String im,(.1*xres-70,40),"BITMAP TOGGLE"
end if
'================ IMAGE NOW DRAWN =========================
Noconsole 'hide the dos box
'===============================================
'some variables
Dim As Integer mx,my,mb,flag1,flag2,flag3,flag4,flag5,flag6,flag7,toggle=1,counter,paintflag,contrast=1
dim as integer flag8,bitmaptoggle=1
Dim As Integer dx,dy
Dim As String key
Dim As String fill=Str(Rgb(255,255,255))
dim as string delta,first
d="""C"+border+"B" +d
Dim As String f=d
Dim As Integer count,cm,z
Dim As Integer rd,gr,bl,lower=1
Dim As Ulong boxcol=valulng(fill),circ1col,circ2col
dim as integer bitmapx=0,bitmapy=50,bflagx,bflagy
counter=0
'======================== SHOW THE SCREEN =================
#macro showscreen()
Screenlock
Cls
Put(0,0),im,alpha
if bitmaptoggle=1 then
if bitmapflag then put(bitmapx,bitmapy),bitmapim,pset
end if
'highlight the newpoints box
line(c(1).x+c(1).r-1,c(1).y+c(1).r-1)-(c(1).x-c(1).r+1,c(1).y-c(1).r+1),circ1col,bf
'draw the colour slider circles
For z As Integer=1 To 3
Circle(slide(z).x,slide(z).y),slide(z).r,slide(z).col,,,,f
Next z
'highlight the fill circle
Circle(c(2).x,c(2).y),c(2).r-1,circ2col,,,,f
circle(c(3).x,c(3).y),c(3).r-1,circ2col
'the coloured square
Line(.8*xres,.9*yres)-(.85*xres,.95*yres),boxcol,bf
'top and base of drawing area
Line (0,.9*yres)-(xres,.9*yres),valuint(border)
line (0,50)-(xres,50),valuint(border)
Draw String(xres/3,60),"mouse " & mx &" " & my
Draw String(xres/2,60),"Previous mouse " &s(Ubound(s)).x & " " &s(Ubound(s)).y
'the rbg values of the fill colour shown
Draw String(.8*xres,.975*yres),"RGB(" &RED(boxcol) &"," &GREEN(boxcol) &"," & BLUE(boxcol) &")",Rgb(255,255,255)
Draw d 'MAIN STRING
traceover(s(),boxcol,lower)
'small spot at mouse
pset (s(Ubound(s)).x,s(Ubound(s)).y)
if contrast=1 then line(0,50)-(xres,.9*yres),rgba(0,0,0,150),bf
Screenunlock
Sleep 1,1
#endmacro
'=============================================================
Do
getmoose(mx,my,mb)
key=Inkey
cm=0
'Set the slider bobs to match the fill colour (boxcol)
slide(1).x=map(0,255,RED(boxcol),(.6*xres),(.75*xres))
slide(2).x=map(0,255,GREEN(boxcol),(.6*xres),(.75*xres))
slide(3).x=map(0,255,BLUE(boxcol),(.6*xres),(.75*xres))
'colours highlight at mouse inside(Two boxes at the top, not the toggle)
circ1col=Rgb(100,100,255)
circ2col=Rgb(100,100,255)
'arrow keys to shift the screen
if bflagx=0 and bflagy=0 then
If key=Chr(255)+"K" Then sx-=5:bflagx=1
If key=Chr(255)+"M" Then sx+=5:bflagx=1
If key=Chr(255)+"P" Then sy+=5:bflagy=1
If key=Chr(255)+"H" Then sy-=5:bflagy=1
end if
if len(key)=0 then bflagx=0:bflagy=0
if bitmapflag=0 then
screencontrol 100,sx,sy
'bflag=0
else
if bflagx then bitmapx+=sgn(sx-50)*5:sx=50
if bflagy then bitmapy+=sgn(sy-50)*5:sy=50
end if
'CHECK THE MOUSE IN:
If mb=1 And flag6=0 Then 'the colours in the boxes at the bottom
flag6=1
For z =1 To Ubound(Ccolours)
If inpoint(Ccolours(z),mx,my+5)=0 Then boxcol=Ccolours(z).col':border=str(boxcol)
Next z
End If
flag6=mb
For cm=Lbound(c) To Ubound(c) 'Check for mouse in a box (upper screen)
If inpoint(c(cm),mx,my) Then Exit For
If my>.9*yres Then cm=-1: Exit For
Next cm
If cm=5 and bitmapflag=1 Then 'BITMAP TOGGLE
If mb=1 And flag8=0 Then
flag8=1
bitmaptoggle=-bitmaptoggle
End If
End If
flag8=mb
If cm=4 Then 'CONTRAST TOGGLE
If mb=1 And flag7=0 Then
flag7=1
contrast=-contrast
End If
End If
flag7=mb
If cm=3 Then 'SCREEN TOGGLE
If mb=1 And flag5=0 Then
flag5=1
toggle=-toggle
If toggle=-1 Then blendwindow(100) Else blendwindow(255)
End If
End If
flag5=mb
If cm=2 And Ubound(s)>=3 Then 'FILLER
If PaintFlag Then circ2col=boxcol
If mb=1 And flag4=0 Then
flag4=1
fill= Str(boxcol)
'var t=ltrim(starter ,"""C")
If PaintFlag Then d+="P"+fill+","+border't'str(boxcol)'border
End If
End If
flag4=mb
If cm=1 Then 'NEW START
circ1col=Rgb(0,200,0)
If mb=1 And flag3=0 Then
flag3=1
lower=ubound(s)+1
d+=""""+"_"+Chr(10)+"&"+""""
d+="B"
End If
End If
flag3=mb
If my<50 And cm=Ubound(c)+1 then moveall:cm=0 'if mouse in top frame
'CREATE THE STRING FOR DRAW.
'AND CREATE AN ARRAY IN PARALLEL
If mb=1 And flag1=0 And cm=Ubound(c)+1 Then
flag1=1:counter+=1
Redim Preserve s(1 To Ubound(s)+1)
s(Ubound(s))=Type<Point>(mx,my,0,counter)
Dim As Integer dx,dy
If counter=1 Then dx=mx:dy=my Else dx=mx-s(Ubound(s)-1).x:dy=my-s(Ubound(s)-1).y
If counter=1 Then d+="M"+Str(dx)+","+Str(dy) Else d+="M+"+Str(dx)+","+Str(dy)
count+=1
If count>5 Then d+=""""+"_"+Chr(10)+"&"+"""":count=0
End If
flag1=mb
'go back on right mouse click(delete mistakes)
If mb=2 And flag2=0 Then
flag2=1
If counter>1 Then Redim Preserve s(1 To Ubound(s)-1):counter-=1
If counter=1 Then Redim s(0):counter=0
delta=Mid(d,instrrev(d,"M"))
d=Rtrim(d,delta)
End If
flag2=mb
showscreen()
'the colour sliders
For z As Integer=1 To 3 'in the colour sliders
If inpoint(slide(z),mx,my) Then
While mb = 1
Getmouse mx,my,,mb
showscreen()
If mx<>slide(z).x Or my<>slide(z).y Then
rd=RED(boxcol):gr=GREEN(boxcol):bl=BLUE(boxcol)
slide(z).x=mx
If slide(z).x<.6*xres Then slide(z).x=.6*xres
If slide(z).x>.75*xres Then slide(z).x=.75*xres
Select Case As Const z
Case 1: rd=map((.6*xres),(.75*xres),slide(1).x,0,255)
Case 2: gr=map((.6*xres),(.75*xres),slide(2).x,0,255)
Case 3: bl=map((.6*xres),(.75*xres),slide(3).x,0,255)
End Select
If rd<0 Then rd=0:If rd>255 Then rd=255
If gr<0 Then gr=0:If gr>255 Then gr=255
If bl<0 Then bl=0:If bl>255 Then bl=255
boxcol=Rgb(rd,gr,bl)
End If
Wend
End If
Next z
If Len(d)-Instrrev(d,"B")<18 Then PaintFlag=1 Else PaintFlag=0
Loop Until key =Chr(27)
d+=""""
screeninfo xres,yres
dim as any ptr lastscreen=imagecreate(xres,yres,0)
get(0,0)-(xres-1,yres-1),lastscreen
dim as string q
screenres xres,yres,32
put(0,0),lastscreen,pset
draw string(100,100),"Do you wish to save -- y/n",rgb(255,255,255)
var ff=freefile
do
q=input(1)
loop until lcase(q)="n" or lcase(q)="y"
if lcase(q)="n" then goto fin
locate 6,6
if Open ("DRAWINGpoints.bas" For Output As #ff)=0 then print "saved":beep else print "Fail"
Print #ff,"Dim as string zz = _"
Print #ff,d
Print #ff,"'Number off points ";Ubound(s)
Print #ff,"Screenres ";xres;",";yres;",";32
Print #ff, "Draw zz"
Print #ff,"Sleep"
Close #ff
shell "notepad DRAWINGpoints.bas"
Sleep
fin:
imagedestroy im
imagedestroy lastscreen
if bitmapim<>0 then imagedestroy bitmapim
