visionmercer/pixler
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

space saving.

Browse source
This commit is contained in:
visionmercer 2026-05-20 10:39:08 +02:00
commit 576726e6be
4 changed files with 626 additions and 626 deletions
Download patch file Download diff file Expand all files Collapse all files

380
include/imgout.bm
View file

@ -1,203 +1,203 @@
Sub SaveBinaryPPM (imageHandle As Long, fileName As String) sub savebinaryppm (imagehandle as long,filename as string)
Dim r As _Unsigned _Byte dim r as _unsigned _byte
Dim g As _Unsigned _Byte dim g as _unsigned _byte
Dim b As _Unsigned _Byte dim b as _unsigned _byte
Dim fileHandle As Integer dim filehandle as integer
Dim w As _Unsigned Long dim w as _unsigned long
Dim h As _Unsigned Long dim h as _unsigned long
Dim head As String dim head as string
Dim fileout As String dim fileout as string
Dim image As _MEM dim image as _mem
Dim filebuffer As _MEM dim filebuffer as _mem
Dim inPosition As _Offset dim inposition as _offset
Dim outPosition As _Offset dim outposition as _offset
Dim length As _Offset dim length as _offset
image = _MemImage(imageHandle) image=_memimage(imagehandle)
inPosition = image.OFFSET inposition=image.offset
w = _Width(imageHandle) w=_width(imagehandle)
h = _Height(imageHandle) h=_height(imagehandle)
length = inPosition + w * h * 4 length=inposition+w*h*4
head = "P6" + Chr$(10) head="P6"+chr$(10)
head = head + "# Created with Pixler" + Chr$(10) head=head+"# Created with Pixler"+chr$(10)
head = head + LTrim$(str$(w) + str$(h)) + Chr$(10) head=head+ltrim$(str$(w)+str$(h))+chr$(10)
head = head + "255" + Chr$(10) head=head+"255"+chr$(10)
filebuffer = _MemNew(w * h * 3) filebuffer=_memnew(w*h*3)
outPosition = filebuffer.OFFSET outposition=filebuffer.offset
Do do
b = _MemGet(image, inPosition, _Unsigned _Byte) b=_memget(image,inposition,_unsigned _byte)
g = _MemGet(image, inPosition + 1, _Unsigned _Byte) g=_memget(image,inposition+1,_unsigned _byte)
r = _MemGet(image, inPosition + 2, _Unsigned _Byte) r=_memget(image,inposition+2,_unsigned _byte)
_MemPut filebuffer, outPosition, r As _UNSIGNED _BYTE _memput filebuffer,outposition,r as _unsigned _byte
_MemPut filebuffer, outPosition + 1, g As _UNSIGNED _BYTE _memput filebuffer,outposition+1,g as _unsigned _byte
_MemPut filebuffer, outPosition + 2, b As _UNSIGNED _BYTE _memput filebuffer,outposition+2,b as _unsigned _byte
inPosition = inPosition + 4 inposition=inposition+4
outPosition = outPosition + 3 outposition=outposition+3
Loop Until inPosition = length loop until inposition=length
fileout = Space$(w * h * 3) fileout=space$(w*h*3)
_MemGet filebuffer, filebuffer.OFFSET, fileout _memget filebuffer,filebuffer.offset,fileout
fileHandle = FreeFile filehandle=freefile
Open fileName For Binary As fileHandle open filename for binary as filehandle
Put fileHandle, , head put filehandle,,head
Put fileHandle, , fileout put filehandle,,fileout
Close fileHandle close filehandle
_MemFree image _memfree image
_MemFree filebuffer _memfree filebuffer
End Sub end sub
Sub save24bitBmp (imageHandle As Long, fileName As String) sub save24bitbmp (imagehandle as long,filename as string)
Dim oSource As Long dim osource as long
Dim ff As Long dim ff as long
Dim x As Long, y As Long dim x as long,y as long
Dim header As String * 54 dim header as string*54
Dim outBytes As String * 3 dim outbytes as string*3
Dim padding As String dim padding as string
oSource = _Source osource=_source
_Source imageHandle _source imagehandle
header = "BM" + MKL$(_Width * _Height * 3 + 54) +_ header="BM"+mkl$(_width*_height*3+54)+_
String$(4, 0) + MKL$(54) + MKL$(40) +_ string$(4,0)+mkl$(54)+mkl$(40)+_
MKL$(_Width) + MKL$(_Height) +_ mkl$(_width)+mkl$(_height)+_
MKI$(1) + MKI$(24) + MKL$(0) + MKL$(0) +_ mki$(1)+mki$(24)+mkl$(0)+mkl$(0)+_
MKL$(11811) + MKL$(11811) + MKL$(0) + MKL$(0) mkl$(11811)+mkl$(11811)+mkl$(0)+mkl$(0)
If ((_Width * 3) Mod 4) Then padding$ = String$(4 - ((_width * 3) Mod 4), 0) if ((_width*3) mod 4) then padding$=string$(4-((_width*3) mod 4),0)
ff = FreeFile ff=freefile
Open fileName For Binary As ff open filename for binary as ff
Put ff, , header put ff,,header
For y = _Height - 1 To 0 Step -1 for y=_height-1 to 0 step -1
For x = 0 To _Width - 1 for x=0 to _width-1
outBytes = Left$(MKL$(Point(x, y)), 3) outbytes=left$(mkl$(point(x,y)),3)
Put #ff, , outBytes put #ff,,outbytes
Next next
put #ff, , padding put #ff,,padding
Next next
Close ff close ff
_Source oSource _source osource
End Sub end sub
Sub save8bitPNG (imagehandle As Long, filename As String) sub save8bitpng (imagehandle as long,filename as string)
Dim PngHeader As String dim pngheader as string
Dim IHDR As String dim ihdr as string
Dim IDAT As String dim idat as string
Dim IEND As String dim iend as string
Dim PLTE As String dim plte as string
Dim x As _Unsigned Long, y As _Unsigned Long dim x as _unsigned long,y as _unsigned long
Dim colorvalue As _Unsigned Long dim colorvalue as _unsigned long
Dim chunksize As String dim chunksize as string
Dim ff As Long dim ff as long
Dim imageData As String dim imagedata as string
dim sourceMem as _mem dim sourcemem as _mem
dim c As _Unsigned _byte dim c as _unsigned _byte
sourceMem = _memimage(imagehandle) sourcemem=_memimage(imagehandle)
PngHeader = chr$(137) + "PNG" + Chr$(13) + Chr$(10) + Chr$(26) + Chr$(10) pngheader=chr$(137)+"PNG"+chr$(13)+chr$(10)+chr$(26)+chr$(10)
IHDR = "IHDR" + MKL$(FlipBytes(_Width(imagehandle))) + MKL$(FlipBytes(_Height(imagehandle))) + Chr$(8) + Chr$(3) + String$(3, 0) ihdr="IHDR"+mkl$(flipbytes(_width(imagehandle)))+mkl$(flipbytes(_height(imagehandle)))+chr$(8)+chr$(3)+string$(3,0)
IHDR = MKL$(FlipBytes(&H0D)) + IHDR + MKL$(FlipBytes(crc32(IHDR))) ihdr=mkl$(flipbytes(&h0d))+ihdr+mkl$(flipbytes(crc32(ihdr)))
IEND = MKL$(0) + "IEND" + MKL$(FlipBytes(&HAE426082)) iend=mkl$(0)+"IEND"+mkl$(flipbytes(&hae426082))
PLTE = "PLTE" plte="PLTE"
for c = 0 to 255 for c=0 to 255
PLTE = PLTE + chr$(_Red32(_PaletteColor(c))) plte=plte+chr$(_red32(_palettecolor(c)))
PLTE = PLTE + chr$(_Green32(_PaletteColor(c))) plte=plte+chr$(_green32(_palettecolor(c)))
PLTE = PLTE + chr$(_Blue32(_PaletteColor(c))) plte=plte+chr$(_blue32(_palettecolor(c)))
Next next
PLTE = mkl$(FlipBytes(256 * 3)) + PLTE + MKL$(FlipBytes(crc32(PLTE))) plte=mkl$(flipbytes(256*3))+plte+mkl$(flipbytes(crc32(plte)))
imageData = string$(_Height(imagehandle) * _Width(imagehandle) + _Height(imagehandle), 0) imagedata=string$(_height(imagehandle)*_width(imagehandle)+_height(imagehandle),0)
For y = 0 To _Height(imagehandle) - 1 for y=0 to _height(imagehandle)-1
For x = 0 To _Width(imagehandle) - 1 for x=0 to _width(imagehandle)-1
c = _memget(sourceMem, sourceMem.OFFSET + bytecount + 0, _Unsigned _byte) c=_memget(sourcemem,sourcemem.offset+bytecount+0,_unsigned _byte)
asc(imageData,bytecount + y + 2) = c asc(imagedata,bytecount+y+2)=c
bytecount = bytecount + 1 bytecount=bytecount+1
Next x next x
Next y next y
_memfree sourceMem _memfree sourcemem
IDAT = _Deflate$(imageData) idat=_deflate$(imagedata)
chunksize = MKL$(FlipBytes(Len(IDAT))) chunksize=mkl$(flipbytes(len(idat)))
IDAT = "IDAT" + IDAT idat="IDAT"+idat
IDAT = IDAT + MKL$(FlipBytes(crc32(IDAT))) idat=idat+mkl$(flipbytes(crc32(idat)))
IDAT = chunksize + IDAT idat=chunksize+idat
ff = FreeFile ff=freefile
Open filename For Output As ff: Close ff open filename for output as ff:close ff
Open filename For Binary As ff open filename for binary as ff
Put ff, , PngHeader put ff,,pngheader
Put ff, , IHDR put ff,,ihdr
put ff, , PLTE put ff,,plte
Put ff, , IDAT put ff,,idat
Put ff, , IEND put ff,,iend
Close ff close ff
End Sub end sub
Sub save32bitPNG (imagehandle As Long, filename As String) sub save32bitpng (imagehandle as long,filename as string)
Dim PngHeader As String dim pngheader as string
Dim IHDR As String dim ihdr as string
Dim IDAT As String dim idat as string
Dim IEND As String dim iend as string
Dim x As _Unsigned Long, y As _Unsigned Long dim x as _unsigned long,y as _unsigned long
Dim colorvalue As _Unsigned Long dim colorvalue as _unsigned long
Dim chunksize As String dim chunksize as string
Dim ff As Long dim ff as long
Dim imageData As String dim imagedata as string
dim sourceMem as _mem dim sourcemem as _mem
dim as _Unsigned _byte r, g, b dim as _unsigned _byte r,g,b
sourceMem = _memimage(imagehandle) sourcemem=_memimage(imagehandle)
PngHeader = chr$(137) + "PNG" + Chr$(13) + Chr$(10) + Chr$(26) + Chr$(10) pngheader=chr$(137)+"PNG"+chr$(13)+chr$(10)+chr$(26)+chr$(10)
IHDR = "IHDR" + MKL$(FlipBytes(_Width(imagehandle))) + MKL$(FlipBytes(_Height(imagehandle))) + Chr$(8) + Chr$(6) + String$(3, 0) ihdr="IHDR"+mkl$(flipbytes(_width(imagehandle)))+mkl$(flipbytes(_height(imagehandle)))+chr$(8)+chr$(6)+string$(3,0)
IHDR = MKL$(FlipBytes(&H0D)) + IHDR + MKL$(FlipBytes(crc32(IHDR))) ihdr=mkl$(flipbytes(&h0d))+ihdr+mkl$(flipbytes(crc32(ihdr)))
IEND = MKL$(0) + "IEND" + MKL$(FlipBytes(&HAE426082)) iend=mkl$(0)+"IEND"+mkl$(flipbytes(&hae426082))
imageData = string$(_Height(imagehandle) * _Width(imagehandle) * 4 + _Height(imagehandle), 0) imagedata=string$(_height(imagehandle)*_width(imagehandle)*4+_height(imagehandle),0)
For y = 0 To _Height(imagehandle) - 1 for y=0 to _height(imagehandle)-1
For x = 0 To _Width(imagehandle) - 1 for x=0 to _width(imagehandle)-1
b = _memget(sourceMem, sourceMem.OFFSET + bytecount + 0, _Unsigned _byte) b=_memget(sourcemem,sourcemem.offset+bytecount+0,_unsigned _byte)
g = _memget(sourceMem, sourceMem.OFFSET + bytecount + 1, _Unsigned _byte) g=_memget(sourcemem,sourcemem.offset+bytecount+1,_unsigned _byte)
r = _memget(sourceMem, sourceMem.OFFSET + bytecount + 2, _Unsigned _byte) r=_memget(sourcemem,sourcemem.offset+bytecount+2,_unsigned _byte)
a = _memget(sourceMem, sourceMem.OFFSET + bytecount + 3, _Unsigned _byte) a=_memget(sourcemem,sourcemem.offset+bytecount+3,_unsigned _byte)
asc(imageData,bytecount + y + 2) = r asc(imagedata,bytecount+y+2)=r
asc(imageData,bytecount + y + 3) = g asc(imagedata,bytecount+y+3)=g
asc(imageData,bytecount + y + 4) = b asc(imagedata,bytecount+y+4)=b
asc(imageData,bytecount + y + 5) = a asc(imagedata,bytecount+y+5)=a
bytecount = bytecount + 4 bytecount=bytecount+4
Next x next x
Next y next y
_memfree sourceMem _memfree sourcemem
IDAT = _Deflate$(imageData) idat=_deflate$(imagedata)
chunksize = MKL$(FlipBytes(Len(IDAT))) chunksize=mkl$(flipbytes(len(idat)))
IDAT = "IDAT" + IDAT idat="IDAT"+idat
IDAT = IDAT + MKL$(FlipBytes(crc32(IDAT))) idat=idat+mkl$(flipbytes(crc32(idat)))
IDAT = chunksize + IDAT idat=chunksize+idat
ff = FreeFile ff=freefile
Open filename For Output As ff: Close ff open filename for output as ff:close ff
Open filename For Binary As ff open filename for binary as ff
Put ff, , PngHeader put ff,,pngheader
Put ff, , IHDR put ff,,ihdr
Put ff, , IDAT put ff,,idat
Put ff, , IEND put ff,,iend
Close ff close ff
End Sub end sub
Function FlipBytes~& (value As _Unsigned Long) function flipbytes~& (value as _unsigned long)
FlipBytes~& = (value \ 16777216)_ flipbytes~&=(value \ 16777216)_
Or (value * 16777216)_ or (value*16777216)_
Or ((value And 16711680) \ 256)_ or ((value and 16711680) \ 256)_
Or ((value And 65280) * 256) or ((value and 65280)*256)
End Function end function
Function crc32~& (IN$) function crc32~& (in$)
Dim As _Unsigned Long CRC32_POLY, CRC dim as _unsigned long crc32_poly,crc
CRC32_POLY = &HEDB88320 crc32_poly=&hedb88320
CRC = &HFFFFFFFF crc=&hffffffff
For I = 1 To Len(IN$) for i=1 to len(in$)
CRC = CRC Xor Asc(IN$, I) crc=crc xor asc(in$,i)
For J = 1 To 8 for j=1 to 8
If CRC And 1 Then if crc and 1 then
CRC = (CRC \ 2) Xor CRC32_POLY crc=(crc \ 2) xor crc32_poly
Else else
CRC = CRC \ 2 crc=crc \ 2
End If end if
Next J next j
Next I next i
crc32~& = Not CRC crc32~&=not crc
End Function end function

316
include/palette.bm
View file

@ -1,160 +1,160 @@
sub loadpalette(palname as string, palarray() as _unsigned long) sub loadpalette(palname as string,palarray() as _unsigned long)
Dim SLSO8(7) As _Unsigned Long dim slso8(7) as _unsigned long
select case lcase$(palname) select case lcase$(palname)
case "slso8" case "slso8"
redim palarray(7) as _unsigned long redim palarray(7) as _unsigned long
palarray(0) = &HFF0D2B45 palarray(0)=&hff0d2b45
palarray(1) = &HFF203C56 palarray(1)=&hff203c56
palarray(2) = &HFF544E68 palarray(2)=&hff544e68
palarray(3) = &HFF8D697A palarray(3)=&hff8d697a
palarray(4) = &HFFD08159 palarray(4)=&hffd08159
palarray(5) = &HFFFFAA5E palarray(5)=&hffffaa5e
palarray(6) = &HFFFFD4A3 palarray(6)=&hffffd4a3
palarray(7) = &HFFFFECD6 palarray(7)=&hffffecd6
case "endesga16" case "endesga16"
redim palarray(15) as _Unsigned Long redim palarray(15) as _unsigned long
palarray( 0) = &HFFe4a672 palarray( 0)=&hffe4a672
palarray( 1) = &HFFb86f50 palarray( 1)=&hffb86f50
palarray( 2) = &HFF743f39 palarray( 2)=&hff743f39
palarray( 3) = &HFF3f2832 palarray( 3)=&hff3f2832
palarray( 4) = &HFF9e2835 palarray( 4)=&hff9e2835
palarray( 5) = &HFFe53b44 palarray( 5)=&hffe53b44
palarray( 6) = &HFFfb922b palarray( 6)=&hfffb922b
palarray( 7) = &HFFffe762 palarray( 7)=&hffffe762
palarray( 8) = &HFF63c64d palarray( 8)=&hff63c64d
palarray( 9) = &HFF327345 palarray( 9)=&hff327345
palarray(10) = &HFF193d3f palarray(10)=&hff193d3f
palarray(11) = &HFF4f6781 palarray(11)=&hff4f6781
palarray(12) = &HFFafbfd2 palarray(12)=&hffafbfd2
palarray(13) = &HFFffffff palarray(13)=&hffffffff
palarray(14) = &HFF2ce8f4 palarray(14)=&hff2ce8f4
palarray(15) = &HFF0484d1 palarray(15)=&hff0484d1
case "kinkan" case "kinkan"
redim palarray(7) as _Unsigned Long redim palarray(7) as _unsigned long
palarray(0) = &HFF446176 palarray(0)=&hff446176
palarray(1) = &HFF3EAAAE palarray(1)=&hff3eaaae
palarray(2) = &HFF8CEFB6 palarray(2)=&hff8cefb6
palarray(3) = &HFFC4F0C2 palarray(3)=&hffc4f0c2
palarray(4) = &HFFFFFEE4 palarray(4)=&hfffffee4
palarray(5) = &HFFBEC0C0 palarray(5)=&hffbec0c0
palarray(6) = &HFFFFA7B9 palarray(6)=&hffffa7b9
palarray(7) = &HFFFF7A8F palarray(7)=&hffff7a8f
case "custodian-8" case "custodian-8"
redim palarray(7) as _Unsigned Long redim palarray(7) as _unsigned long
palarray(0) = &HFF2b3634 palarray(0)=&hff2b3634
palarray(1) = &HFF474848 palarray(1)=&hff474848
palarray(2) = &HFF6e5f52 palarray(2)=&hff6e5f52
palarray(3) = &HFFa2856c palarray(3)=&hffa2856c
palarray(4) = &HFFa0a294 palarray(4)=&hffa0a294
palarray(5) = &HFFdcb9a0 palarray(5)=&hffdcb9a0
palarray(6) = &HFFf3dbc6 palarray(6)=&hfff3dbc6
palarray(7) = &HFFfffefe palarray(7)=&hfffffefe
case "greyteen" case "greyteen"
redim palarray(17) as _unsigned long redim palarray(17) as _unsigned long
palarray( 0) = &hff272524 palarray( 0)=&hff272524
palarray( 1) = &hff444140 palarray( 1)=&hff444140
palarray( 2) = &hf626368 palarray( 2)=&hf626368
palarray( 3) = &hff918783 palarray( 3)=&hff918783
palarray( 4) = &hffa7a8b9 palarray( 4)=&hffa7a8b9
palarray( 5) = &hffd7c7c0 palarray( 5)=&hffd7c7c0
palarray( 6) = &hffdadceb palarray( 6)=&hffdadceb
palarray( 7) = &hfff2ece9 palarray( 7)=&hfff2ece9
palarray( 8) = &hff4e393a palarray( 8)=&hff4e393a
palarray( 9) = &hff7d5c51 palarray( 9)=&hff7d5c51
palarray(10) = &hffcd9f83 palarray(10)=&hffcd9f83
palarray(11) = &hffebd8a3 palarray(11)=&hffebd8a3
palarray(12) = &hff95ae91 palarray(12)=&hff95ae91
palarray(13) = &hff5a7054 palarray(13)=&hff5a7054
palarray(14) = &hff3f4459 palarray(14)=&hff3f4459
palarray(15) = &hff7b8caa palarray(15)=&hff7b8caa
palarray(16) = &hffb0c6d5 palarray(16)=&hffb0c6d5
palarray(17) = &hff745e72 palarray(17)=&hff745e72
case "ega" case "ega"
redim palarray(63) As _unsigned Long redim palarray(63) as _unsigned long
palarray( 0) = &hff000000 palarray( 0)=&hff000000
palarray( 1) = &hff000055 palarray( 1)=&hff000055
palarray( 2) = &hff0000aa palarray( 2)=&hff0000aa
palarray( 3) = &hff0000ff palarray( 3)=&hff0000ff
palarray( 4) = &hff550000 palarray( 4)=&hff550000
palarray( 5) = &hff550055 palarray( 5)=&hff550055
palarray( 6) = &hff5500aa palarray( 6)=&hff5500aa
palarray( 7) = &hff5500ff palarray( 7)=&hff5500ff
palarray( 8) = &hffaa0000 palarray( 8)=&hffaa0000
palarray( 9) = &hffaa0055 palarray( 9)=&hffaa0055
palarray(10) = &hffaa00aa palarray(10)=&hffaa00aa
palarray(11) = &hffaa00ff palarray(11)=&hffaa00ff
palarray(12) = &hffff0000 palarray(12)=&hffff0000
palarray(13) = &hffff0055 palarray(13)=&hffff0055
palarray(14) = &hffff00aa palarray(14)=&hffff00aa
palarray(15) = &hffff00ff palarray(15)=&hffff00ff
palarray(16) = &hff005500 palarray(16)=&hff005500
palarray(17) = &hff005555 palarray(17)=&hff005555
palarray(18) = &hff0055aa palarray(18)=&hff0055aa
palarray(19) = &hff0055ff palarray(19)=&hff0055ff
palarray(20) = &hff555500 palarray(20)=&hff555500
palarray(21) = &hff555555 palarray(21)=&hff555555
palarray(22) = &hff5555aa palarray(22)=&hff5555aa
palarray(23) = &hff5555ff palarray(23)=&hff5555ff
palarray(24) = &hffaa5500 palarray(24)=&hffaa5500
palarray(25) = &hffaa5555 palarray(25)=&hffaa5555
palarray(26) = &hffaa55aa palarray(26)=&hffaa55aa
palarray(27) = &hffaa55ff palarray(27)=&hffaa55ff
palarray(28) = &hffff5500 palarray(28)=&hffff5500
palarray(29) = &hffff5555 palarray(29)=&hffff5555
palarray(30) = &hffff55aa palarray(30)=&hffff55aa
palarray(31) = &hffff55ff palarray(31)=&hffff55ff
palarray(32) = &hff00aa00 palarray(32)=&hff00aa00
palarray(33) = &hff00aa55 palarray(33)=&hff00aa55
palarray(34) = &hff00aaaa palarray(34)=&hff00aaaa
palarray(35) = &hff00aaff palarray(35)=&hff00aaff
palarray(36) = &hff55aa00 palarray(36)=&hff55aa00
palarray(37) = &hff55aa55 palarray(37)=&hff55aa55
palarray(38) = &hff55aaaa palarray(38)=&hff55aaaa
palarray(39) = &hff55aaff palarray(39)=&hff55aaff
palarray(40) = &hffaaaa00 palarray(40)=&hffaaaa00
palarray(41) = &hffaaaa55 palarray(41)=&hffaaaa55
palarray(42) = &hffaaaaaa palarray(42)=&hffaaaaaa
palarray(43) = &hffaaaaff palarray(43)=&hffaaaaff
palarray(44) = &hffffaa00 palarray(44)=&hffffaa00
palarray(45) = &hffffaa55 palarray(45)=&hffffaa55
palarray(46) = &hffffaaaa palarray(46)=&hffffaaaa
palarray(47) = &hffffaaff palarray(47)=&hffffaaff
palarray(48) = &hff00ff00 palarray(48)=&hff00ff00
palarray(49) = &hff00ff55 palarray(49)=&hff00ff55
palarray(50) = &hff00ffaa palarray(50)=&hff00ffaa
palarray(51) = &hff00ffff palarray(51)=&hff00ffff
palarray(52) = &hff55ff00 palarray(52)=&hff55ff00
palarray(53) = &hff55ff55 palarray(53)=&hff55ff55
palarray(54) = &hff55ffaa palarray(54)=&hff55ffaa
palarray(55) = &hff55ffff palarray(55)=&hff55ffff
palarray(56) = &hffaaff00 palarray(56)=&hffaaff00
palarray(57) = &hffaaff55 palarray(57)=&hffaaff55
palarray(58) = &hffaaffaa palarray(58)=&hffaaffaa
palarray(59) = &hffaaffff palarray(59)=&hffaaffff
palarray(60) = &hffffff00 palarray(60)=&hffffff00
palarray(61) = &hffffff55 palarray(61)=&hffffff55
palarray(62) = &hffffffaa palarray(62)=&hffffffaa
palarray(63) = &hffffffff palarray(63)=&hffffffff
case else case else
redim palarray(1) as _unsigned long redim palarray(1) as _unsigned long
if _fileexists(palname) then if _fileexists(palname) then
dim fh as integer dim fh as integer
dim i as integer dim i as integer
dim colorload as string dim colorload as string
fh=freefile fh=freefile
open palname for input as fh open palname for input as fh
do until eof(fh) do until eof(fh)
line input #fh, colorload line input #fh,colorload
i = i + 1 i=i+1
if i > ubound(palarray) then if i>ubound(palarray) then
redim _preserve palarray(i) as _unsigned long redim _preserve palarray(i) as _unsigned long
End If end if
palarray(i) = Val("&HFF" + colorload) palarray(i)=val("&HFF"+colorload)
Loop loop
Close fh close fh
else else
palarray(0)=&hff000000 palarray(0)=&hff000000
palarray(1)=&hffffffff palarray(1)=&hffffffff
end if end if
end select end select
end sub end sub

286
include/tools.bm
View file

@ -1,51 +1,51 @@
sub thickbox(sx,sy,ex,ey,col as long) sub thickbox(sx,sy,ex,ey,col as long)
thickline sx, sy, ex, sy, col thickline sx,sy,ex,sy,col
thickline ex, sy, ex, ey, col thickline ex,sy,ex,ey,col
thickline ex, ey, sx, ey, col thickline ex,ey,sx,ey,col
thickline sx, ey, sx, sy, col thickline sx,ey,sx,sy,col
end sub end sub
sub filledbox(sx,sy,ex,ey,col as long) sub filledbox(sx,sy,ex,ey,col as long)
line(sx,sy)-(ex,ey),col,bf line(sx,sy)-(ex,ey),col,bf
end sub end sub
sub filledPolygon (Points() as long, col as long) sub filledpolygon (points() as long,col as long)
dim i as integer, j as integer dim i as integer,j as integer
dim x1 as single, y1 as single, x2 as single, y2 as single dim x1 as single,y1 as single,x2 as single,y2 as single
dim intersectX as single dim intersectx as single
' get the number of points from the upper bound of the array ' get the number of points from the upper bound of the array
' divide by 2 since we have x,y pairs ' divide by 2 since we have x,y pairs
dim numPoints as integer dim numpoints as integer
numPoints = (ubound(Points) + 1) \ 2 numpoints=(ubound(points)+1) \ 2
' loop through each scanline (rows of pixels) ' loop through each scanline (rows of pixels)
dim intersections(100) as single dim intersections(100) as single
dim numIntersections as integer dim numintersections as integer
for y = 0 to _height ' adjust for screen height for y=0 to _height ' adjust for screen height
numIntersections = 0 numintersections=0
' check for intersections between the polygon edges and this scanline ' check for intersections between the polygon edges and this scanline
for i = 0 to numPoints - 1 for i=0 to numpoints-1
x1 = Points(i * 2) x1=points(i*2)
y1 = Points(i * 2 + 1) y1=points(i*2+1)
x2 = Points(((i + 1) mod numPoints) * 2) x2=points(((i+1) mod numpoints)*2)
y2 = Points(((i + 1) mod numPoints) * 2 + 1) y2=points(((i+1) mod numpoints)*2+1)
' check if the scanline intersects with the edge of the polygon ' check if the scanline intersects with the edge of the polygon
if ((y1 > y and y2 <= y) or (y2 > y and y1 <= y)) then if ((y1>y and y2<=y) or (y2>y and y1<=y)) then
' calculate intersection point with the scanline ' calculate intersection point with the scanline
intersectX = x1 + (y - y1) * (x2 - x1) / (y2 - y1) intersectx=x1+(y-y1)*(x2-x1)/(y2-y1)
intersections(numIntersections) = intersectX intersections(numintersections)=intersectx
numIntersections = numIntersections + 1 numintersections=numintersections+1
end if end if
next i next i
' sort the intersections (sort by x-coordinates) ' sort the intersections (sort by x-coordinates)
for i = 0 to numIntersections - 1 for i=0 to numintersections-1
for j = i + 1 to numIntersections - 1 for j=i+1 to numintersections-1
if intersections(i) > intersections(j) then if intersections(i)>intersections(j) then
swap intersections(i), intersections(j) swap intersections(i),intersections(j)
end if end if
next j next j
next i next i
' fill the area between pairs of intersections ' fill the area between pairs of intersections
for i = 0 to numIntersections - 1 step 2 for i=0 to numintersections-1 step 2
line(intersections(i),y)-(intersections(i+1),y),col line(intersections(i),y)-(intersections(i+1),y),col
next i next i
next y next y
@ -55,170 +55,170 @@ sub thickpixel(x,y,col as long)
if state.brushsize=1 then if state.brushsize=1 then
pset(x,y),col pset(x,y),col
else else
line(x-0.5 * state.brushsize,y-0.5 * state.brushsize)-(x+0.5 * state.brushsize,y+0.5 * state.brushsize),col,bf line(x-0.5*state.brushsize,y-0.5*state.brushsize)-(x+0.5*state.brushsize,y+0.5*state.brushsize),col,bf
end if end if
end sub end sub
sub thickline(x1,y1,x2,y2, col as long) sub thickline(x1,y1,x2,y2,col as long)
if state.brushsize=1 then if state.brushsize=1 then
line(x1,y1)-(x2,y2),col line(x1,y1)-(x2,y2),col
else else
dim tempimg as long dim tempimg as long
dim od as long dim od as long
tempimg=_newimage(1,1,32) tempimg=_newimage(1,1,32)
od =_dest od=_dest
_dest tempimg _dest tempimg
pset(0,0),col pset(0,0),col
_dest od _dest od
a = _Atan2(y2 - y1, x2 - x1) a=_atan2(y2-y1,x2-x1)
a = a + _Pi / 2 a=a+_pi/2
x0 = 0.5 * state.brushsize * Cos(a) x0=0.5*state.brushsize*cos(a)
y0 = 0.5 * state.brushsize * Sin(a) y0=0.5*state.brushsize*sin(a)
_maptriangle _seamless(0,0)-(0,0)-(0,0),tempimg to(x1-x0, y1-y0)-(x1+x0,y1+y0)-(x2+x0,y2+y0),,_smooth _maptriangle _seamless(0,0)-(0,0)-(0,0),tempimg to (x1-x0,y1-y0)-(x1+x0,y1+y0)-(x2+x0,y2+y0),,_smooth
_maptriangle _seamless(0,0)-(0,0)-(0,0),tempimg to(x1-x0, y1-y0)-(x2+x0,y2+y0)-(x2-x0,y2-y0),,_smooth _maptriangle _seamless(0,0)-(0,0)-(0,0),tempimg to (x1-x0,y1-y0)-(x2+x0,y2+y0)-(x2-x0,y2-y0),,_smooth
_freeimage tempimg _freeimage tempimg
end if end if
end sub end sub
Sub polygon (pa() As Long,col as long) sub polygon (pa() as long,col as long)
For i = 2 To UBound(pa) Step 2 for i=2 to ubound(pa) step 2
thickLine pa(i - 2), pa(i - 1),pa(i), pa(i + 1),col thickline pa(i-2),pa(i-1),pa(i),pa(i+1),col
Next i next i
thickLine pa(ubound(pa)-1), pa(ubound(pa)),pa(0), pa(1),col thickline pa(ubound(pa)-1),pa(ubound(pa)),pa(0),pa(1),col
End Sub end sub
sub thickcircle(x, y, r, col as long) sub thickcircle(x,y,r,col as long)
if state.brushsize <= 1 then if state.brushsize<=1 then
circle (x, y), r, col circle (x,y),r,col
else else
dim rp as single, rm as single, rp2 as single, rm2 as single dim rp as single,rm as single,rp2 as single,rm2 as single
dim rpi2 as single, rmi2 as single, sp as single, sm as single dim rpi2 as single,rmi2 as single,sp as single,sm as single
dim i as single dim i as single
rp = r + state.brushsize / 2 rp=r+state.brushsize/2
rm = r - state.brushsize / 2 rm=r-state.brushsize/2
' If the brush is thicker than the circle, it's just a filled circle ' If the brush is thicker than the circle, it's just a filled circle
if rm < 0 then if rm<0 then
filledcircle x, y, rp, col filledcircle x,y,rp,col
exit sub exit sub
end if end if
rp2 = rp ^ 2 rp2=rp ^ 2
rm2 = rm ^ 2 rm2=rm ^ 2
' Outer edges (Top/Bottom caps) ' Outer edges (Top/Bottom caps)
for i = -rp to -rm step .2 for i=-rp to -rm step .2
rpi2 = rp2 - i ^ 2 rpi2=rp2-i ^ 2
if rpi2 < 0 then rpi2 = 0 ' Safety Gate if rpi2<0 then rpi2=0 ' Safety Gate
sp = sqr(rpi2) sp=sqr(rpi2)
line (x + i, y - sp)-(x + i, y + sp), col, bf line (x+i,y-sp)-(x+i,y+sp),col,bf
next next
' Side rings (where the hole in the middle exists) ' Side rings (where the hole in the middle exists)
for i = -rm to rm step .2 for i=-rm to rm step .2
rpi2 = rp2 - i ^ 2 rpi2=rp2-i ^ 2
rmi2 = rm2 - i ^ 2 rmi2=rm2-i ^ 2
if rpi2 < 0 then rpi2 = 0 ' Safety Gate if rpi2<0 then rpi2=0 ' Safety Gate
if rmi2 < 0 then rmi2 = 0 ' Safety Gate if rmi2<0 then rmi2=0 ' Safety Gate
sp = sqr(rpi2) sp=sqr(rpi2)
sm = sqr(rmi2) sm=sqr(rmi2)
' Draw the top and bottom segments only ' Draw the top and bottom segments only
line (x + i, y + sm)-(x + i, y + sp), col, bf line (x+i,y+sm)-(x+i,y+sp),col,bf
line (x + i, y - sm)-(x + i, y - sp), col, bf line (x+i,y-sm)-(x+i,y-sp),col,bf
next next
' Outer edges (Right cap) ' Outer edges (Right cap)
for i = rm to rp step .2 for i=rm to rp step .2
rpi2 = rp2 - i ^ 2 rpi2=rp2-i ^ 2
if rpi2 < 0 then rpi2 = 0 ' Safety Gate if rpi2<0 then rpi2=0 ' Safety Gate
sp = sqr(rpi2) sp=sqr(rpi2)
line (x + i, y - sp)-(x + i, y + sp), col, bf line (x+i,y-sp)-(x+i,y+sp),col,bf
next next
end if end if
end sub end sub
sub filledcircle(x,y,r,col as long) sub filledcircle(x,y,r,col as long)
dim __radius as integer, radiuserror as integer dim __radius as integer,radiuserror as integer
dim tx as integer, ty as integer dim tx as integer,ty as integer
__radius=abs(r)-1 __radius=abs(r)-1
radiuserror=-__radius radiuserror=-__radius
tx=__radius tx=__radius
ty=0 ty=0
line (x-tx,y)-(x+tx,y),col line (x-tx,y)-(x+tx,y),col
while tx>ty while tx>ty
radiuserror=radiuserror+ty*2+1 radiuserror=radiuserror+ty*2+1
if radiuserror >= 0 then if radiuserror>=0 then
if tx<>ty+1 then if tx<>ty+1 then
line (x-ty,y-tx)-(x+ty,y-tx),col line (x-ty,y-tx)-(x+ty,y-tx),col
line (x-ty,y+tx)-(x+ty,y+tx),col line (x-ty,y+tx)-(x+ty,y+tx),col
end if
tx=tx-1
radiuserror=radiuserror-tx*2
end if end if
ty=ty+1 tx=tx-1
line (x-tx,y-ty)-(x+tx,y-ty),col radiuserror=radiuserror-tx*2
line (x-tx,y+ty)-(x+tx,y+ty),col end if
wend ty=ty+1
line (x-tx,y-ty)-(x+tx,y-ty),col
line (x-tx,y+ty)-(x+tx,y+ty),col
wend
end sub end sub
SUB FloodFill (startX, startY, fillColor~&) sub floodfill (startx,starty,fillcolor~&)
' We use a simple array as a stack for (x, y) pairs ' We use a simple array as a stack for (x, y) pairs
' For large images, you may need to increase this size ' For large images, you may need to increase this size
DIM stackX(2000) AS INTEGER dim stackx(2000) as integer
DIM stackY(2000) AS INTEGER dim stacky(2000) as integer
targetColor~&=point(startX,startY) targetcolor~&=point(startx,starty)
if targetColor~&=fillColor~& then exit sub if targetcolor~&=fillcolor~& then exit sub
stackPtr = 1 stackptr=1
stackX(stackPtr) = startX stackx(stackptr)=startx
stackY(stackPtr) = startY stacky(stackptr)=starty
WHILE stackPtr > 0 while stackptr>0
curX = stackX(stackPtr) curx=stackx(stackptr)
curY = stackY(stackPtr) cury=stacky(stackptr)
stackPtr = stackPtr - 1 stackptr=stackptr-1
' Move to the left edge of the span ' Move to the left edge of the span
x = curX x=curx
WHILE POINT(x, curY) = targetColor~& AND x >= 0 while point(x,cury)=targetcolor~& and x>=0
x = x - 1 x=x-1
WEND wend
x = x + 1 x=x+1
spanAbove = 0 spanabove=0
spanBelow = 0 spanbelow=0
' Process the span moving right ' Process the span moving right
WHILE POINT(x, curY) = targetColor~& AND x < _WIDTH while point(x,cury)=targetcolor~& and x<_width
PSET (x, curY), fillColor~& pset (x,cury),fillcolor~&
' Check row above ' Check row above
IF curY > 0 THEN if cury>0 then
IF spanAbove = 0 AND POINT(x, curY - 1) = targetColor~& THEN if spanabove=0 and point(x,cury-1)=targetcolor~& then
stackPtr = stackPtr + 1 stackptr=stackptr+1
stackX(stackPtr) = x stackx(stackptr)=x
stackY(stackPtr) = curY - 1 stacky(stackptr)=cury-1
spanAbove = 1 spanabove=1
ELSEIF spanAbove = 1 AND POINT(x, curY - 1) <> targetColor~& THEN elseif spanabove=1 and point(x,cury-1)<>targetcolor~& then
spanAbove = 0 spanabove=0
END IF end if
END IF end if
' Check row below ' Check row below
IF curY < _HEIGHT - 1 THEN if cury<_height-1 then
IF spanBelow = 0 AND POINT(x, curY + 1) = targetColor~& THEN if spanbelow=0 and point(x,cury+1)=targetcolor~& then
stackPtr = stackPtr + 1 stackptr=stackptr+1
stackX(stackPtr) = x stackx(stackptr)=x
stackY(stackPtr) = curY + 1 stacky(stackptr)=cury+1
spanBelow = 1 spanbelow=1
ELSEIF spanBelow = 1 AND POINT(x, curY + 1) <> targetColor~& THEN elseif spanbelow=1 and point(x,cury+1)<>targetcolor~& then
spanBelow = 0 spanbelow=0
END IF end if
END IF end if
x = x + 1 x=x+1
WEND wend
WEND wend
END SUB end sub

248
include/ui.bm
View file

@ -1,8 +1,8 @@
function textinput$ (x as integer,y as integer,w as integer,h as integer,__text as string) function textinput$ (x as integer,y as integer,w as integer,h as integer,__text as string)
dim text as string, keyin as string dim text as string,keyin as string
dim cursor as integer, done as integer dim cursor as integer,done as integer
text=__text text=__text
if not (_mousex>x and _mousey>y AND _mousex<x+w AND _mousey<y+h) then if not (_mousex>x and _mousey>y and _mousex<x+w and _mousey<y+h) then
drawtextinput x,y,w,h,__text,0 drawtextinput x,y,w,h,__text,0
exit function exit function
end if end if
@ -10,7 +10,7 @@ function textinput$ (x as integer,y as integer,w as integer,h as integer,__text
if not mouseclicked then exit function if not mouseclicked then exit function
'text="" 'text=""
cursor=len(text)+1 cursor=len(text)+1
dim relativeX as integer dim relativex as integer
do do
keyin=inkey$ keyin=inkey$
if len(keyin)=2 then if len(keyin)=2 then
@ -28,16 +28,16 @@ function textinput$ (x as integer,y as integer,w as integer,h as integer,__text
text=left$(text,cursor-1)+mid$(text,cursor+1) text=left$(text,cursor-1)+mid$(text,cursor+1)
end if end if
end select end select
elseif LEN(keyin)=1 then elseif len(keyin)=1 then
select case asc(keyin) select case asc(keyin)
case 22 ' Ctrl + V (Paste) case 22 ' Ctrl + V (Paste)
text=left$(text,cursor-1)+_clipboard$+mid$(text,cursor) text=left$(text,cursor-1)+_clipboard$+mid$(text,cursor)
cursor=cursor+len(pasteData) cursor=cursor+len(pastedata)
case 32 to 126 ' Regular Typing case 32 to 126 ' Regular Typing
text=left$(text,cursor-1)+keyin+mid$(text,cursor) text=left$(text,cursor-1)+keyin+mid$(text,cursor)
cursor=cursor+1 cursor=cursor+1
case 8 ' Backspace case 8 ' Backspace
if cursor>1 THEN if cursor>1 then
text=left$(text,cursor-2)+mid$(text,cursor) text=left$(text,cursor-2)+mid$(text,cursor)
cursor=cursor-1 cursor=cursor-1
end if end if
@ -48,11 +48,11 @@ function textinput$ (x as integer,y as integer,w as integer,h as integer,__text
done=-1 done=-1
end select end select
end if end if
while _mouseinput: wend while _mouseinput:wend
if _mousebutton(1) then if _mousebutton(1) then
IF (_mousex>x and _mousey>y AND _mousex<x+w AND _mousey<y+h) THEN if (_mousex>x and _mousey>y and _mousex<x+w and _mousey<y+h) then
relativeX=_mousex-x relativex=_mousex-x
cursor=(relativeX\8)+1 cursor=(relativex\8)+1
if cursor<1 then cursor=1 if cursor<1 then cursor=1
if cursor>len(text)+1 then cursor=len(text)+1 if cursor>len(text)+1 then cursor=len(text)+1
else else
@ -68,8 +68,8 @@ end function
sub drawtextinput (x as integer,y as integer,w as integer,h as integer,text as string,state as integer) sub drawtextinput (x as integer,y as integer,w as integer,h as integer,text as string,state as integer)
dim outtext as string dim outtext as string
dim charWidth as integer:charWidth = 8 dim charwidth as integer:charwidth=8
dim cursorX as integer,textX as integer,textY as integer dim cursorx as integer,textx as integer,texty as integer
if state>0 then if state>0 then
color backgroundcolor1 color backgroundcolor1
else else
@ -78,22 +78,22 @@ sub drawtextinput (x as integer,y as integer,w as integer,h as integer,text as s
line(x,y)-(x+w,y+h),,bf line(x,y)-(x+w,y+h),,bf
if state>0 then if state>0 then
color highlightcolor color highlightcolor
ELSE else
color textcolor color textcolor
end if end if
line(x,y)-(x+w,y+h),,b line(x,y)-(x+w,y+h),,b
_printmode _keepbackground _printmode _keepbackground
outtext=right$(text,min(w/charWidth,len(text))) outtext=right$(text,min(w/charwidth,len(text)))
textX=2+x textx=2+x
textY=1+y+h/2-8 texty=1+y+h/2-8
_printstring(textX,textY),outtext _printstring(textx,texty),outtext
if state>0 then if state>0 then
if int(timer*2) mod 2=0 then if int(timer*2) mod 2=0 then
dim relativeCursor as integer dim relativecursor as integer
relativeCursor=state-(len(text)-len(outtext)) relativecursor=state-(len(text)-len(outtext))
if relativeCursor>=1 and relativeCursor<=len(outtext)+1 then if relativecursor>=1 and relativecursor<=len(outtext)+1 then
cursorX=textX+(relativeCursor-1)*charWidth cursorx=textx+(relativecursor-1)*charwidth
line(cursorX,textY)-(cursorX,textY+14),highlightcolor line(cursorx,texty)-(cursorx,texty+14),highlightcolor
end if end if
end if end if
end if end if
@ -103,7 +103,7 @@ function min(a,b)
if a<=b then min=a else min=b if a<=b then min=a else min=b
end function end function
function clickregion(x as integer, y as integer, w as integer, h as integer) function clickregion(x as integer,y as integer,w as integer,h as integer)
if _mousex>x and _mousey>y and _mousex<x+w and _mousey<y+h then if _mousex>x and _mousey>y and _mousex<x+w and _mousey<y+h then
if mouseclicked then clickregion=-1 if mouseclicked then clickregion=-1
if rmouseclicked then clickregion=-2 if rmouseclicked then clickregion=-2
@ -120,7 +120,7 @@ function button (x as integer,y as integer,w as integer,h as integer,caption as
end function end function
function buttonhold (x as integer,y as integer,w as integer,h as integer,caption as string) function buttonhold (x as integer,y as integer,w as integer,h as integer,caption as string)
if _mousex>x and _mousey>y and _mousex<x+w and _mousey<y+h then if _mousex>x and _mousey>y and _mousex<x+w and _mousey<y+h then
drawbutton x,y,w,h,caption,1 drawbutton x,y,w,h,caption,1
if _mousebutton(1)then buttonhold=-1 if _mousebutton(1)then buttonhold=-1
else else
@ -148,12 +148,12 @@ function imagebuttonhold (x as integer,y as integer,w as integer,h as integer,ic
end function end function
function checkbox (x as integer,y as integer, state as integer) function checkbox (x as integer,y as integer,state as integer)
if _mousex>x and _mousey>y and _mousex<x+16 and _mousey<y+16 then if _mousex>x and _mousey>y and _mousex<x+16 and _mousey<y+16 then
drawcheckbox x,y,2 + state drawcheckbox x,y,2+state
if mouseclicked then checkbox=(state+1) mod 2:exit function if mouseclicked then checkbox=(state+1) mod 2:exit function
else else
drawcheckbox x,y,0 + state drawcheckbox x,y,0+state
end if end if
checkbox=state checkbox=state
end function end function
@ -169,31 +169,31 @@ function link(x,y,label as string)
end if end if
end function end function
function slider(x as long, y as long, w as long, value as single) function slider(x as long,y as long,w as long,value as single)
dim tmpval as single dim tmpval as single
tmpval = value tmpval=value
if _mousex > x and _mousey > y - 5 and _mousex < x + w and _mousey < y + 15 then if _mousex>x and _mousey>y-5 and _mousex<x+w and _mousey<y+15 then
drawslider x, y, w, value, 1 drawslider x,y,w,value,1
if _mousebutton(1) then if _mousebutton(1) then
tmpval = ((_mousex - x) / w) * 100 tmpval=((_mousex-x)/w)*100
end if end if
else else
drawslider x, y, w, value, 0 drawslider x,y,w,value,0
end if end if
if tmpval < 0 then tmpval = 0 if tmpval<0 then tmpval=0
if tmpval > 100 then tmpval = 100 if tmpval>100 then tmpval=100
slider = tmpval slider=tmpval
end function end function
function vscrollbar(x as long,y as long,h as long,value as single) function vscrollbar(x as long,y as long,h as long,value as single)
dim tmpval as single dim tmpval as single
tmpval=value tmpval=value
if buttonhold(x,y,23,23,"U") then tmpval=tmpval-1 if buttonhold(x,y,23,23,"U") then tmpval=tmpval-1
if buttonhold(x,h-23,23,23,"D") then tmpval=tmpval+1 if buttonhold(x,h-23,23,23,"D") then tmpval=tmpval+1
tmpval= vbar(x,y+23,h-46,tmpval) tmpval=vbar(x,y+23,h-46,tmpval)
if tmpval<0 then tmpval=0 if tmpval<0 then tmpval=0
if tmpval>100 then tmpval=100 if tmpval>100 then tmpval=100
vscrollbar=tmpval vscrollbar=tmpval
end function end function
function vbar(x as long,y as long,h as long,value as single) function vbar(x as long,y as long,h as long,value as single)
@ -208,30 +208,30 @@ function vbar(x as long,y as long,h as long,value as single)
vbar=tmpval vbar=tmpval
end function end function
function hscrollbar(x as long, y as long, w as long, value as single) function hscrollbar(x as long,y as long,w as long,value as single)
dim tmpval as single dim tmpval as single
tmpval = value tmpval=value
if button(x, y, 23, 23, "L") then tmpval = tmpval - 1 if button(x,y,23,23,"L") then tmpval=tmpval-1
if button(x + w - 23, y, 23, 23, "R") then tmpval = tmpval + 1 if button(x+w-23,y,23,23,"R") then tmpval=tmpval+1
tmpval = hbar(x + 23, y, w - 46, tmpval) tmpval=hbar(x+23,y,w-46,tmpval)
if tmpval < 0 then tmpval = 0 if tmpval<0 then tmpval=0
if tmpval > 100 then tmpval = 100 if tmpval>100 then tmpval=100
hscrollbar = tmpval hscrollbar=tmpval
end function end function
function hbar(x as long, y as long, w as long, value as single) function hbar(x as long,y as long,w as long,value as single)
dim tmpval as single dim tmpval as single
tmpval = value tmpval=value
if _mousex > x and _mousey > y and _mousex < x + w and _mousey < y + 23 then if _mousex>x and _mousey>y and _mousex<x+w and _mousey<y+23 then
drawhbar x, y, w, value, 1 drawhbar x,y,w,value,1
if _mousebutton(1) then tmpval=((_mousex-x)/(w))*100 if _mousebutton(1) then tmpval=((_mousex-x)/(w))*100
else else
drawhbar x, y, w, value, 0 drawhbar x,y,w,value,0
end if end if
hbar = tmpval hbar=tmpval
end function end function
sub drawbutton(x as integer,y as integer,w as integer,h as integer,caption as string, state as integer) sub drawbutton(x as integer,y as integer,w as integer,h as integer,caption as string,state as integer)
if state and 2 then if state and 2 then
color backgroundcolor1 color backgroundcolor1
line (x,y)-(x+w,y+h),,bf line (x,y)-(x+w,y+h),,bf
@ -250,7 +250,7 @@ sub drawbutton(x as integer,y as integer,w as integer,h as integer,caption as st
_printstring (1+x+w/2-len(caption)*8/2,1+y+h/2-8),caption _printstring (1+x+w/2-len(caption)*8/2,1+y+h/2-8),caption
end sub end sub
sub drawimagebutton(x as integer,y as integer,w as integer,h as integer,iconhandle as long, state as integer) sub drawimagebutton(x as integer,y as integer,w as integer,h as integer,iconhandle as long,state as integer)
if state and 2 then if state and 2 then
color backgroundcolor2 color backgroundcolor2
line (x,y)-(x+w,y+h),,bf line (x,y)-(x+w,y+h),,bf
@ -293,7 +293,7 @@ sub drawlink(x,y,label as string,state as integer)
else else
color textcolor color textcolor
end if end if
_printstring (x,y),label _printstring (x,y),label
end sub end sub
sub drawhline(x,y,w) sub drawhline(x,y,w)
@ -301,25 +301,25 @@ sub drawhline(x,y,w)
line (x,y+1)-(x+w,y+1),backgroundcolor2 line (x,y+1)-(x+w,y+1),backgroundcolor2
end sub end sub
sub drawslider(x as long, y as long, w as long, value as single, state as integer) sub drawslider(x as long,y as long,w as long,value as single,state as integer)
dim handleX as long dim handlex as long
handleX = x + (w * (value / 100)) handlex=x+(w*(value/100))
color backgroundcolor1 color backgroundcolor1
line (x, y + 4)-(x + w, y + 6), , bf line (x,y+4)-(x+w,y+6),,bf
if state = 1 then color highlightcolor else color textcolor if state=1 then color highlightcolor else color textcolor
line (x, y + 4)-(x + w, y + 6), , b line (x,y+4)-(x+w,y+6),,b
if state = 1 then if state=1 then
color highlightcolor color highlightcolor
else else
color textcolor color textcolor
end if end if
line (handleX - 5, y - 2)-(handleX + 5, y + 12), , bf line (handlex-5,y-2)-(handlex+5,y+12),,bf
color backgroundcolor1 color backgroundcolor1
line (handleX - 5, y - 2)-(handleX + 5, y + 12), , b line (handlex-5,y-2)-(handlex+5,y+12),,b
end sub end sub
sub drawvbar(x as long,y as long,h as long,value as single, state as integer) sub drawvbar(x as long,y as long,h as long,value as single,state as integer)
if state and 2 then if state and 2 then
color backgroundcolor2 color backgroundcolor2
line (x,y)-(x+23,y+h),,bf line (x,y)-(x+23,y+h),,bf
else else
@ -334,97 +334,97 @@ if state and 2 then
line (x,y)-(x+23,y+h),,b line (x,y)-(x+23,y+h),,b
end if end if
dim indicator as long dim indicator as long
indicator=((h-23) / 100)*value indicator=((h-23)/100)*value
line (x+1,y+indicator)-step(21,21),,bf line (x+1,y+indicator)-step (21,21),,bf
end sub end sub
sub drawhbar(x as long, y as long, w as long, value as single, state as integer) sub drawhbar(x as long,y as long,w as long,value as single,state as integer)
color backgroundcolor2 color backgroundcolor2
line (x, y)-(x + w, y + 23),, bf line (x,y)-(x+w,y+23),,bf
if state and 1 then if state and 1 then
color highlightcolor color highlightcolor
line (x, y)-(x + w, y + 23),, b line (x,y)-(x+w,y+23),,b
else else
color textcolor color textcolor
line (x, y)-(x + w, y + 23),, b line (x,y)-(x+w,y+23),,b
end if end if
dim indicator as long dim indicator as long
indicator = ((w - 23) / 100) * value indicator=((w-23)/100)*value
line (x + indicator, y + 1)-step(21, 21),, bf line (x+indicator,y+1)-step (21,21),,bf
end sub end sub
sub textcolor (value as long) sub textcolor (value as long)
ignore=__interncolors(1,1,value) ignore=__interncolors(1,1,value)
end sub end sub
sub highlightcolor (value as long) sub highlightcolor (value as long)
ignore=__interncolors(1,2,value) ignore=__interncolors(1,2,value)
end sub end sub
sub backgroundcolor1 (value as long) sub backgroundcolor1 (value as long)
ignore=__interncolors(1,3,value) ignore=__interncolors(1,3,value)
end sub end sub
sub backgroundcolor2 (value as long) sub backgroundcolor2 (value as long)
ignore=__interncolors(1,4,value) ignore=__interncolors(1,4,value)
end sub end sub
function textcolor () function textcolor ()
textcolor=__interncolors(2,1,ignore) textcolor=__interncolors(2,1,ignore)
end function end function
function highlightcolor () function highlightcolor ()
highlightcolor=__interncolors(2,2,ignore) highlightcolor=__interncolors(2,2,ignore)
end function end function
function backgroundcolor1 () function backgroundcolor1 ()
backgroundcolor1=__interncolors(2,3,ignore) backgroundcolor1=__interncolors(2,3,ignore)
end function end function
function backgroundcolor2 () function backgroundcolor2 ()
backgroundcolor2=__interncolors(2,4,ignore) backgroundcolor2=__interncolors(2,4,ignore)
end function end function
function __interncolors(mode as integer, object as integer, value as long) function __interncolors(mode as integer,object as integer,value as long)
static textc as long static textc as long
static highc as long static highc as long
static bgrc1 as long static bgrc1 as long
static bgrc2 as long static bgrc2 as long
static linc as long static linc as long
static init as long static init as long
if init=0 then if init=0 then
textc=&hffbbbbbb textc=&hffbbbbbb
highc=&hffdddddd highc=&hffdddddd
bgrc1=&hff282828 bgrc1=&hff282828
bgrc2=&hff282828 bgrc2=&hff282828
linc =&hffdddddd linc=&hffdddddd
init =-1 init=-1
end if end if
if mode=1 then if mode=1 then
select case object select case object
case 1 case 1
textc=value textc=value
case 2 case 2
highc=value highc=value
case 3 case 3
bgrc1=value bgrc1=value
case 4 case 4
bgrc2=value bgrc2=value
end select end select
end if end if
if mode=2 then if mode=2 then
select case object select case object
case 1 case 1
__interncolors=textc __interncolors=textc
case 2 case 2
__interncolors=highc __interncolors=highc
case 3 case 3
__interncolors=bgrc1 __interncolors=bgrc1
case 4 case 4
__interncolors=bgrc2 __interncolors=bgrc2
end select end select
end if end if
end function end function