Microsoft Small Basic

Program Listing: RFT686-6

List Program

' 16x16 Plain PPM Icon Editor
' Copyright © 2015 Nonki Takahashi. The MIT License.
' Version 0.7b
' Last update 2015-03-14
' Program ID RFT686-6
' Repository https://iconeditorsb.codeplex.com/
'
' TODO:
' [ ] #10 Support other image format in Open
' [ ] #9 Workaround for Silverlight
' [ ] #8 Add unit test feature
'
' set graphics window title
title = "Icon Editor 0.7b"
fname = "Untitled"
GraphicsWindow.Title = fname + " - " + title
' define variables as constants or functions
debug = "False"
If debug Then
TextWindow.Title = "Debug - " + title
Timer.Interval = 500
Timer.Tick = Mouse_OnTick
EndIf
CR = Text.GetCharacter(13)
LF = Text.GetCharacter(10)
TAB = Text.GetCharacter(9)
DIGIT = "0123456789"
Not = "False=True;True=False;"
' width/height [%] of each character in Trebuchet MS font
ratio = "32=30;48=58;49=58;50=58;51=58;52=58;53=58;54=58;55=58;56=58;"
ratio = ratio + "57=58;65=63;66=59;67=61;68=64;69=57;70=58;71=67;"
ratio = ratio + "72=68;73=28;74=53;75=62;76=55;77=74;78=67;79=70;"
ratio = ratio + "80=59;81=71;82=61;83=51;84=61;85=68;86=62;87=88;"
ratio = ratio + "88=60;89=61;90=56;97=53;98=58;99=51;100=58;101=57;"
ratio = ratio + "102=37;103=50;104=59;105=30;106=37;107=55;108=29;"
ratio = ratio + "109=86;110=59;111=56;112=58;113=58;114=43;115=43;"
ratio = ratio + "116=39;117=59;118=53;119=78;120=55;121=53;122=53;"
' initialize mouse and keyboard events
Mouse_Init()
KB_Init()
' show menu, white icon, and edit field in graphics window
pcolor = GraphicsWindow.PenColor
Form()
GraphicsWindow.FontSize = 12
Color_Init()
Msg_Init()
Macro_Init()
While "True"
If clicked Then
' find clicked object - menu item or pixel of the icon
Mouse_DetectObject()
' create message (command) for the object if found
If name = "pen color" Then
param = "cmd=color;"
Msg_Set()
ElseIf name = "icon" Then
Icon_MouseToXY()
If 0 <= x And 0 <= y Then
param = "cmd=pixel;x=" + x + ";y=" + y + ";"
Msg_Set()
EndIf
ElseIf name <> "" Then
param = "cmd=" + name + ";"
Msg_Set()
EndIf
clicked = "False"
EndIf
While keyOut < keyIn
KB_InKey()
' create message (command) for the shortcut if found
If c = "^N" Then
param = "cmd=new;"
Msg_Set()
c = ""
ElseIf c = "^O" Then
param = "cmd=open;"
Msg_Set()
c = ""
ElseIf c = "^S" Then
param = "cmd=save;"
Msg_Set()
c = ""
ElseIf c = "^Z" Then
param = "cmd=undo;"
Msg_Set()
c = ""
ElseIf c = "^Y" Then
param = "cmd=redo;"
Msg_Set()
c = ""
ElseIf debug Then
TextWindow.ForegroundColor = "Red"
TextWindow.WriteLine("Unknown cmd: '" + c + "'")
TextWindow.ForegroundColor = "Gray"
c = ""
EndIf
EndWhile
If msgOut < msgIn Then
' do action for the message (command)
msgOut = msgOut + 1
msg = message[msgOut]
If msg["cmd"] = "new" Then
New()
ElseIf msg["cmd"] = "open" Then
Open()
ElseIf msg["cmd"] = "save" Then
Save()
ElseIf msg["cmd"] = "undo" Then
Macro_Undo()
ElseIf msg["cmd"] = "redo" Then
Macro_Redo()
ElseIf msg["cmd"] = "color" Then
color = pcolor
CS_ShowPopup()
pcolor = color
Color_SetPenColor()
ElseIf msg["cmd"] = "pixel" Then
x = msg["x"]
y = msg["y"]
Icon_GetPixel()
msg["from"] = color
msg["to"] = pcolor
Macro_Add()
color = pcolor
Icon_SetPixel()
Else
GraphicsWindow.Title = msg["cmd"] + " - " + title
EndIf
EndIf
If debug Then
Debug_StateChanged()
If changed Then
Debug_Dump()
EndIf
EndIf
EndWhile
Sub Form
gw = 598
gh = 428
GraphicsWindow.Width = gw
GraphicsWindow.Height = gh
GraphicsWindow.BackgroundColor = "DimGray"
iconWidth = 16 '40
iconHeight = 16 '40
itemSize = 40
itemGap = 10
menuHeight = 60
size = 16 '6
gap = 2
Menu_Draw()
xEdit = Math.Floor((gw - (size + gap + 1) * iconWidth) / 2) + iconWidth
yEdit = Math.Floor((gh - menuHeight - (size + gap) * iconHeight) / 2) + menuHeight
xIcon = Math.Floor((xEdit - iconWidth) / 2)
yIcon = yEdit
add = "True"
Icon_Clear()
add = "False"
EndSub
Sub New
yes = "True"
If Text.IsSubText(GraphicsWindow.Title, "*") Then
caution = "Are you sure to clear the icon?"
Dialog_YesNo()
EndIf
If yes Then
Icon_Clear()
fname = "Untitled"
relPath = ""
Macro_Init()
EndIf
EndSub
Sub Open
' open command
File_Open()
Parse_PPM()
If match And relPath <> "" Then
fname = relPath
Macro_Init()
EndIf
EndSub
Sub Save
' save command
File_GeneratePPM()
File_Save()
EndSub
Sub Array_GetIndexOfValue
' param arry - array
' param value - value to get index
' return index - index if found or "" if not found
nValue = Array.GetItemCount(arry)
indices = Array.GetAllIndices(arry)
index = ""
For iArry = 1 To nValue
If value = arry[indices[iArry]] Then
index = indices[iArry]
iArry = nValue + 1 ' break
EndIf
EndFor
EndSub
Sub Color_ColorToRGB
' Color | Convert Color to RGB
' param sColor - "#rrggbb"
' return iR, iG, iB - [0, 255]
sR = Text.GetSubText(sColor, 2, 2)
sG = Text.GetSubText(sColor, 4, 2)
sB = Text.GetSubText(sColor, 6, 2)
sHex = sR
Math_Hex2Dec()
iR = iDec
sHex = sG
Math_Hex2Dec()
iG = iDec
sHex = sB
Math_Hex2Dec()
iB = iDec
EndSub
Sub Color_HSLtoRGB
' Color | Convert HSL to RGB
' param rHue - [0, 360) or UNDEFINED
' param rLightness - [0, 1]
' param rSaturation - [0, 1]
' return iR, iG, iB - RGB color
' return sColor - "#rrggbb"
If rLightness <= 0.5 Then
rN2 = rLightness * (1 + rSaturation)
Else
rN2 = rLightness + rSaturation - rLightness * rSaturation
EndIf
rN1 = 2 * rLightness - rN2
If rSaturation = 0 Then
iR = Math.Round(rLightness * 255)
iG = Math.Round(rLightness * 255)
iB = Math.Round(rLightness * 255)
Else
rH = rHue + 120
Color_Value()
iR = iValue
rH = rHue
Color_Value()
iG = iValue
rH = rHue - 120
Color_Value()
iB = iValue
EndIf
sColor = GraphicsWindow.GetColorFromRGB(iR, iG, iB)
EndSub
Sub Color_Init
Popup_Init()
Color_SetPenColor()
CS_InitPalette() ' initialize palette for color slider
EndSub
Sub Color_RGBtoHSL
' Color | Convert RGB to HSL
' param sColor - "#rrggbb"
' return rHue - [0, 360) or UNDEFINED
' return rLightness - (0, 1)
' return rSaturation - (0, 1)
Color_ColorToRGB()
' rR = iR / 255 ' occurs Math.Max() bug
rR = Math.Round(iR / 255 * 10000) / 10000
' rG = iG / 255 ' occurs Math.Max() bug
rG = Math.Round(iG / 255 * 10000) / 10000
' rB = iB / 255 ' occurs Math.Max() bug
rB = Math.Round(iB / 255 * 10000) / 10000
rMax = Math.Max(rR, rG)
rMax = Math.Max(rMax, rB)
rMin = Math.Min(rR, rG)
rMin = Math.Min(rMin, rB)
rLightness = (rMax + rMin) / 2
If rMax = rMin Then ' rR = rG = rB
rSaturation = 0
rHue = UNDEFINED
Else
If rLightness <= 0.5 Then
rSaturation = (rMax - rMin) / (rMax + rMin)
Else
rSaturation = (rMax - rMin) / (2 - rMax - rMin)
EndIf
rRC = (rMax - rR) / (rMax - rMin)
rGC = (rMax - rG) / (rMax - rMin)
rBC = (rMax - rB) / (rMax - rMin)
If rR = rMax Then ' between Yellow and Magenta
rHue = rBC - rGC
ElseIf rG = rMax Then ' between Cyan and Yellow
rHue = 2 + rRC - rBC
ElseIf rB = rMax Then ' between Magenta and Cyan
rHue = 4 + rGC - rRC
Else
TextWindow.WriteLine("Error:")
TextWindow.WriteLine("rMax=" + rMax)
TextWindow.WriteLine("rR=" + rR + ",sR=" + sR)
TextWindow.WriteLine("rG=" + rG + ",sG=" + sG)
TextWindow.WriteLine("rB=" + rB + ",sB=" + sB)
EndIf
rHue = rHue * 60
If rHue < 0 Then
rHue = rHue + 360
EndIf
EndIf
EndSub
Sub Color_Value
' Color | Function value
' param rN1, rN2
' param rH - [-120, 480)
' return iValue - 0..255
If rH >= 360 Then
rH = rH - 360
EndIF
If rH < 0 Then
rH = rH + 360
EndIF
If rH < 60 Then
rV = rN1 + (rN2 - rN1) * rH / 60
ElseIf rH < 180 Then
rV = rN2
ElseIf rH < 240 Then
rV = rN1 + (rN2 - rN1) * (240 - rH) / 60
Else
rV = rN1
EndIf
iValue = Math.Round(rV * 255)
EndSub
Sub CS_AddColorToPalette
' Color Selector | Add color to palette
' param color - color to set
' param maxPalette
' param nPalette
' param palette
' param tPalette - target palette
Stack.PushValue("local", i)
For i = 1 To nPalette
pltt = palette[i]
If color = pltt["color"] Then
Goto csactp_not_new_color
EndIf
EndFor
pltt = palette[tPalette]
pltt["color"] = color
palette[tPalette] = pltt
If nPalette < maxPalette Then
nPalette = nPalette + 1
EndIf
tPalette = tPalette + 1
If maxPalette < tPalette Then
tPalette = 1
EndIf
csactp_not_new_color:
i = Stack.PopValue("local")
EndSub
Sub CS_AdjustSlider
' Color Selector | Adjust slider
' param iSlider - moved slider
Stack.PushValue("local", iSlider)
If iSlider = iHue Or iSlider = iLightness Or iSlider = iSaturation Then
If iSlider = iHue Then
Slider_GetLevel()
rHue = level
ElseIf iSlider = iLightness Then
Slider_GetLevel()
rLightness = level / 100
Else
Slider_GetLevel()
rSaturation = level / 100
EndIf
Color_HSLtoRGB()
iSlider = iRed
level = iR
Slider_SetLevel()
iSlider = iGreen
level = iG
Slider_SetLevel()
iSlider = iBlue
level = iB
Slider_SetLevel()
Else
CS_GetColorFromSlider()
sColor = GraphicsWindow.GetColorFromRGB(red, green, blue)
Color_RGBtoHSL()
If rHue = UNDEFINED Then
rHue = 0
EndIf
iSlider = iHue
level = Math.Floor(rHue)
Slider_SetLevel()
iSlider = iSaturation
level = Math.Floor(rSaturation * 100)
Slider_SetLevel()
iSlider = iLightness
level = Math.Floor(rLightness * 100)
Slider_SetLevel()
EndIf
iSlider = Stack.PopValue("local")
EndSub
Sub CS_DoObject
' Color Selector | Do object
' param - obj
While obj <> ""
CS_DoSlider()
If obj <> "" Then
CS_DoPalette()
EndIf
EndWhile
EndSub
Sub CS_DoPalette
' Color Selector | Do palette
' param obj - clicked object
If Text.StartsWith(obj, "palette") Then
iPalette = Text.GetSubTextToEnd(obj, 8)
pltt = palette[iPalette]
color = pltt["color"]
CS_SetColorToSlider() ' set color to slider
CS_ShowNewColor() ' show new color name
CS_DrawColorRect() ' draw new color rectangle
obj = ""
param = "down=True;move=False;up=False;" ' wait to click
Mouse_SetHandler()
EndIf
EndSub
Sub CS_DoSlider
' Color Selector | Do slider
' param obj - clicked object
' param iSlider - index of slider
If Text.StartsWith(obj, "slider") Then
Slider_WaitToRelease()
obj = ""
param = "down=True;move=False;up=False;" ' wait to click
Mouse_SetHandler()
EndIf
EndSub
Sub CS_DrawColorRect
' Color Selector | Draw color rectangle
' param color - color of rectangle
' param x, y, width, height - position and size of rectangle
' return oRect - rectangle object
GraphicsWindow.BrushColor = color
GraphicsWindow.PenColor = BORDERCOLOR
If oRect <> "" Then
Shapes.Remove(oRect)
EndIf
oRect = Shapes.AddRectangle(width, height)
Shapes.Move(oRect, x, y)
EndSub
Sub CS_DrawPalette
' Color Selector | Draw palette
' param palette[] - color palette
' param nPalette - number of color in palette
' param x, y, width, height - position and size of rectangle
' return oPalette[] - palette object array
Stack.PushValue("local", i)
GraphicsWindow.PenColor = BORDERCOLOR
For i = 1 To nPalette
pltt = palette[i]
GraphicsWindow.BrushColor = pltt["color"]
pltt["oCell"] = Shapes.AddRectangle(width, height)
dx = Math.Remainder((i - 1), (maxPalette / 2)) * (width + 4)
dy = Math.Floor((i - 1) / (maxPalette / 2)) * (height + 4)
Shapes.Move(pltt["oCell"], x + dx, y + dy)
pltt["x"] = x + dx
pltt["y"] = y + dy
pltt["width"] = width
pltt["height"] = height
palette[i] = pltt
EndFor
i = Stack.PopValue("local")
EndSub
Sub CS_GetColorFromSlider
' Color Selector | get color from slider
' return color
Stack.PushValue("local", iSlider)
iSlider = iRed ' slider index
Slider_GetLevel()
red = level
iSlider = iGreen ' slider index
Slider_GetLevel()
green = level
iSlider = iBlue ' slider index
Slider_GetLevel()
blue = level
color = GraphicsWindow.GetColorFromRGB(red, green, blue)
iSlider = Stack.PopValue("local")
EndSub
Sub CS_Init
' Color Selector | Initialize sliders
width = 256
min = 0
max = 255
left = 190
' add red slider
top = TOPY
caption = "R"
Slider_Add()
iRed = iSlider ' index of slider
' add green slider
top = top + DELTAY
caption = "G"
Slider_Add()
iGreen = iSlider ' index of slider
' add blue slider
top = top + DELTAY
caption = "B"
Slider_Add()
iBlue = iSlider ' index of slider
' add hue slider
width = 360
top = top + DELTAY
max = 360
caption = "H"
Slider_Add()
iHue = iSlider ' index of slider
' add saturation slider
width = 100
top = top + DELTAY
max = 100
caption = "S"
Slider_Add()
iSaturation = iSlider ' index of slider
' add lightness slider
width = 100
top = top + DELTAY
max = 100
caption = "L"
Slider_Add()
iLightness = iSlider ' index of slider
' draw color rectangle
CS_GetColorFromSlider()
CS_ShowNewColor()
x = LEFTX
y = TOPY + DELTAY * 4
width = 100
height = 100
CS_DrawColorRect()
' add text box
GraphicsWindow.BrushColor = CAPTIONCOLOR
top = y + height + 4
oNewColor = Shapes.AddText("")
Shapes.Move(oNewColor, LEFTX, top)
EndSub
Sub CS_DumpSlider
' Color Selector | Dump slider for debug
For i = 1 To numSlider
TextWindow.WriteLine("slider" + i)
TextWindow.WriteLine(slider[i])
EndFor
EndSub
Sub CS_InitPalette
' Color Selector | Initialize palette
' This subroutine should be called before CS_ShowPopup().
pcolor = GraphicsWindow.PenColor
If Text.GetLength(pcolor) = 9 Then ' for Silverlight
pcolor = "#" + Text.GetSubText(pcolor, 4, 6)
EndIf
maxPalette = 24 ' max cell number of palette
nPalette = 1 ' number of palette in use
tPalette = 2 ' index of update target cell
pltt = palette[1]
pltt["color"] = pcolor
palette[1] = pltt
EndSub
Sub CS_RemovePalette
' Color Selector | Remove palette
' param nPalette - number of color in palette
' return oPalette[] - palette object array
Stack.PushValue("local", i)
For i = 1 To nPalette
oPalette = "Palette" + i
pltt = palette[i]
Shapes.Remove(pltt["oCell"])
EndFor
i = Stack.PopValue("local")
EndSub
Sub CS_RemoveSliders
' Color Selector | Remove sliders
For iSlider = 1 To numSlider
Slider_Remove()
EndFor
numSlider = 0
EndSub
Sub CS_SearchClickedObject
' Color Selector | Check slider clicked
' param mxD, myD - clicked point
' return obj - clicked slider or palette
' return iSlider - index if obj is slider
' return iPalette - index if obj is palette
Stack.PushValue("local", i)
For iSlider = 1 To numSlider
obj = "slider" + iSlider
sldr = slider[iSlider]
x2 = sldr["x2"]
y2 = sldr["y2"]
x3 = sldr["x3"]
y3 = sldr["y3"]
If x2 <= mxD And mxD <= x3 And y2 <= myD And myD <= y3 Then
Goto scco_obj_found
EndIf
EndFor
For iPalette = 1 To nPalette
obj = "palette" + iPalette
pltt = palette[iPalette]
x2 = pltt["x"]
y2 = pltt["y"]
x3 = pltt["x"] + pltt["width"]
y3 = pltt["y"] + pltt["height"]
If x2 <= mxD And mxD <= x3 And y2 <= myD And myD <= y3 Then
Goto scco_obj_found
EndIf
EndFor
obj = ""
scco_obj_found:
i = Stack.PopValue("local")
EndSub
Sub CS_SetColorToSlider
' Color Selector | Set color to slider
' param color
Stack.PushValue("local", iSlider)
sColor = color
Color_ColorToRGB()
iSlider = iRed
level = iR
Slider_SetLevel()
iSlider = iGreen
level = iG
Slider_SetLevel()
iSlider = iBlue
level = iB
Slider_SetLevel()
CS_AdjustSlider()
iSlider = Stack.PopValue("local")
EndSub
Sub CS_ShowNewColor
' Color Selector | Show new color
' param oColor
' param color
Shapes.SetText(oNewColor, color)
EndSub
Sub CS_ShowPopup
' Color Selector | Show popup
' param color - current color
' return color - new color
' define constant
Stack.PushValue("local", cont)
fs = 12
GraphicsWindow.FontSize = fs
GraphicsWindow.FontBold = "False"
GraphicsWindow.BrushColor = "Black"
colorInit = color ' initial color
GraphicsWindow.PenWidth = 2
GraphicsWindow.PenColor = POPUPCOLOR
GraphicsWindow.BrushColor = POPUPCOLOR
oPopup = Shapes.AddRectangle(gw, gh)
Shapes.SetOpacity(oPopup, 64)
Shapes.Move(oPopup, LEFTX - 10, TOPY - 10)
GraphicsWindow.BrushColor = CAPTIONCOLOR
oOK = Controls.AddButton("OK", gw - 100, gh - 34)
oCancel = Controls.AddButton("Cancel", gw - 60, gh - 34)
Controls.ButtonClicked = CS_OnButtonClicked
CS_Init()
Stack.PushValue("local", y)
y = TOPY
color = colorInit
CS_DrawColorRect() ' original color
oRectCurrent = oRect
oRect = "" ' keep current color
If Text.GetLength(color) = 9 Then ' for Silverlight
color = "#" + Text.GetSubText(color, 4, 6)
EndIf
GraphicsWindow.BrushColor = CAPTIONCOLOR
oColor = Shapes.AddText(colorInit)
Shapes.Move(oColor, x, y + height + 2)
y = Stack.PopValue("local")
CS_SetColorToSlider()
CS_DrawColorRect() ' draw new color rectangle
CS_ShowNewColor() ' show new color name
Stack.PushValue("local", x)
Stack.PushValue("local", y)
Stack.PushValue("local", width)
Stack.PushValue("local", height)
x = x + width + 30
y = TOPY + height * 2 + 24
width = 30
height = 30
CS_DrawPalette()
height = Stack.PopValue("local")
width = Stack.PopValue("local")
y = Stack.PopValue("local")
x = Stack.PopValue("local")
cont = "True" ' continue
param = "down=True;move=False;up=False;" ' wait click
Mouse_SetHandler()
While cont
If clicked Then
CS_SearchClickedObject()
CS_DoObject()
clicked = "False"
Else
Program.Delay(100)
EndIf
EndWhile
If cancel Then
color = colorInit
Else
CS_AddColorToPalette()
EndIf
CS_RemovePalette()
CS_RemoveSliders()
Shapes.Remove(oColor)
Shapes.Remove(oNewColor)
Shapes.Remove(oRectCurrent)
Shapes.Remove(oRect)
Controls.Remove(oOK)
Controls.Remove(oCancel)
Shapes.Remove(oPopup)
cont = Stack.PopValue("local")
EndSub
Sub CS_OnButtonClicked
' Color Selector | Event handler on button clicked
cont = "False"
If Controls.LastClickedButton = oCancel Then
cancel = "True"
Else
cancel = "False"
EndIf
EndSub
Sub Color_SetPenColor
' param pcolor
GraphicsWindow.BrushColor = pcolor
padding = 4
arry = item
value = "Pen Color"
Array_GetIndexOfValue()
y = Math.Floor((menuHeight - itemSize - 10) / 2) + padding
x = (index - 1) * (itemSize + itemGap) + itemGap + padding
GraphicsWindow.FillRectangle(x, y, itemSize - 2 * padding, itemSize - 2 * padding)
EndSub
Sub Debug_StateChanged
' Debug | Check state changed
' return changed - "True" if state changed
changed = "False"
If keyIn <> lastKeyIn Then
lastKeyIn = keyIn
changed = "True"
EndIf
If keyOut <> lastKeyOut Then
lastKeyOut = keyOut
changed = "True"
EndIf
If msgIn <> lastMsgIn Then
lastMsgIn = msgIn
changed = "True"
EndIf
If msgOut <> lastMsgOut Then
lastMsgOut = msgOut
changed = "True"
EndIf
EndSub
Sub Debug_Dump
' Debug | Dump state
TextWindow.WriteLine("fifo = " + fifo)
TextWindow.WriteLine("keyIn = " + keyIn)
TextWindow.WriteLine("keyOut = " + keyOut)
TextWindow.WriteLine("message = " + message)
TextWindow.WriteLine("msgIn = " + msgIn)
TextWindow.WriteLine("msgOut = " + msgOut)
EndSub
Sub Dialog_YesNo
' param caution - message
' return yes - if [Yes] pushed
yes = "True"
GraphicsWindow.PenWidth = 0
GraphicsWindow.BrushColor = POPUPCOLOR
oMsgBox = Shapes.AddRectangle(gw, gh)
Shapes.SetOpacity(oMsgBox, 64)
GraphicsWindow.BrushColor = CAPTIONCOLOR
oCaution = Shapes.AddText(caution)
yCaution = (gh - 80) / 2
Shapes.Move(oCaution, 150, yCaution)
oYes = Controls.AddButton("Yes", 360, yCaution + 50)
oNo = Controls.AddButton("No", 400, yCaution + 50)
cont = "True" ' continue
Controls.ButtonClicked = File_OnButtonClicked
While cont
Program.Delay(500)
EndWhile
If Controls.LastClickedButton = oNo Then
yes = "False"
EndIf
Controls.Remove(oNo)
Controls.Remove(oYes)
Shapes.Remove(oCaution)
Shapes.Remove(oMsgBox)
EndSub
Sub File_GetAbsPath
' param curDir - current directory
' param relPath - relative path
' return absPath - absolute path
If Text.IsSubText(relPath, ":") Or Text.StartsWith(relPath, "\") Or relPath = "" Then
absPath = relPath
Else
absPath = curDir + "\" + relPath
File_RemoveDots()
EndIf
EndSub
Sub File_RemoveDots
' param absPath - with dots
' return absPath - without dots
path = absPath
folder = ""
n = 0
While Text.IsSubText(path, "\")
n = n + 1
p = Text.GetIndexOf(path, "\")
folder[n] = Text.GetSubText(path, 1, p - 1)
path = Text.GetSubTextToEnd(path, p + 1)
EndWhile
If path <> "" Then
n = n + 1
folder[n] = path
EndIf
While Array.ContainsValue(folder, ".") Or Array.ContainsValue(folder, "..")
For i = 1 To n
If folder[i] = "." Then
File_RemoveEntry()
i = n + 1 ' break
ElseIf folder[i] = ".." Then
i = i - 1
File_RemoveEntry()
File_RemoveEntry()
i = n + 1 ' break
EndIf
EndFor
EndWhile
absPath = folder[1]
For i = 2 To n
absPath = absPath + "\" + folder[i]
EndFor
EndSub
Sub File_RemoveEntry
' param folder - entry array
' param i - entry index
' return folder - updated entry array
' return n
For _i = i To n - 1
folder[_i] = folder[_i + 1]
EndFor
folder[n] = ""
n = n - 1
EndSub
Sub File_CloseDialog
' File | Close dialog for Open/Save
' param oPopup
' param oCaption
' param oFilename
' param oText
' param oMsg
' param oCancel
Controls.Remove(oCancel)
Controls.Remove(oMsg)
Controls.Remove(oText)
Controls.Remove(oFilename)
Controls.Remove(oCaption)
Controls.Remove(oPopup)
EndSub
Sub File_GeneratePPM
' File | Generate PPM in buf
' return buf - buffer
buf = "P3" + CR + LF
buf = buf + "16 16" + CR + LF
buf = buf + "255" + CR + LF
nRGB = 0
For y = 0 To iconHeight - 1
nCol = 0
For x = 0 To iconWidth - 1
Icon_GetPixel()
sColor = color
Color_ColorToRGB()
len = Text.GetLength(iR)
sp = Text.GetSubTextToEnd(" ", len)
buf = buf + sp + iR + " "
len = Text.GetLength(iG)
sp = Text.GetSubTextToEnd(" ", len)
buf = buf + sp + iG + " "
len = Text.GetLength(iB)
sp = Text.GetSubTextToEnd(" ", len)
buf = buf + sp + iB
If (Math.Remainder(nCol, 5) = 4) Or (nCol = iconWidth - 1) Then
buf = buf + CR + LF
Else
buf = buf + " "
EndIf
nCol = nCol + 1
EndFor
EndFor
EndSub
Sub File_GetBasename
' FIle | Get basename from filename
' param filename
' return basename
' return ext - extension
pFilename = 1
While Text.IsSubText(Text.GetSubTextToEnd(filename, pFilename), "\")
iBackslash = Text.GetIndexOf(Text.GetSubTextToEnd(filename, pFilename), "\")
pFilename = pFilename + iBackslash
EndWhile
iDot = Text.GetIndexOf(Text.GetSubTextToEnd(filename, pFilename), ".")
If 0 < iDot Then
basename = Text.GetSubText(filename, pFilename, iDot - 1)
ext = Text.GetSubTextToEnd(filename, pFilename + iDot)
Else
basename = Text.GetSubTextToEnd(filename, pFilename)
ext = ""
EndIf
EndSub
Sub File_Open
' File | Show input code to open
' return buf
' return filename
Stack.PushValue("local", cont)
relPath = ""
filename = ""
File_OpenDialog()
oOpen = Controls.AddButton("Open", 486, gh - 34)
Shapes.SetText(oMsg, "You can also click above, push Ctrl+V to paste from clipboard")
Controls.ButtonClicked = File_OnButtonClicked
Controls.TextTyped = File_OnTextTyped
subname = "Shapes_Init"
typed = "False"
done = "False"
While Not[done]
cont = "True" ' continue
While cont
If typed Then
curDir = Program.Directory
relPath = Controls.GetTextBoxText(oFilename)
File_GetAbsPath()
filename = absPath
buf = ""
' The following line could be harmful and has been automatically commented.
' buf = File.ReadContents(filename)
Controls.SetTextBoxText(oText, buf)
typed = "False"
Else
Program.Delay(200)
EndIf
EndWhile
If Controls.LastClickedButton = oOpen Then
buf = Controls.GetTextBoxText(oText)
If buf <> "" Then
done = "True"
EndIf
Else
buf = ""
relPath = ""
filename = ""
done = "True"
EndIf
EndWhile
Controls.Remove(oOpen)
File_CloseDialog()
cont = Stack.PopValue("local")
EndSub
Sub File_OpenDialog
' File | Open dialog and common parts for Open/Save
' param relPath
' return oPopup
' return oCaption
' return oFilename
' return oText
' return oMsg
' return oCancel
GraphicsWindow.PenWidth = 0
GraphicsWindow.BrushColor = POPUPCOLOR
oPopup = Shapes.AddRectangle(gw, gh)
Shapes.SetOpacity(oPopup, 64)
Shapes.Move(oPopup, LEFTX - 10, TOPY - 10)
GraphicsWindow.BrushColor = CAPTIONCOLOR
oCaption = Shapes.AddText("Filename")
Shapes.Move(oCaption, LEFTX, TOPY + 4)
GraphicsWindow.BrushColor = TEXTCOLOR
oFilename = Controls.AddTextBox(LEFTX + 80, TOPY)
Shapes.SetOpacity(oFilename, OPACITY)
Controls.SetSize(oFilename, 300, 24)
Controls.SetTextBoxText(oFilename, relPath)
oText = Controls.AddMultiLineTextBox(LEFTX, TOPY + 30)
Controls.SetSize(oText, gw - 20, gh - 84)
Shapes.SetOpacity(oText, OPACITY)
GraphicsWindow.BrushColor = CAPTIONCOLOR
oMsg = Shapes.AddText("")
Shapes.Move(oMsg, LEFTX, gh - 28)
GraphicsWindow.BrushColor = TEXTCOLOR
oCancel = Controls.AddButton("Cancel", 535, gh - 34)
EndSub
Sub File_Save
' File | Show output code to save
' param buf - program buffer
' param filename
Stack.PushValue("local", cont)
File_OpenDialog()
Controls.SetTextBoxText(oText, buf)
oSave = Controls.AddButton("Save", 488, gh - 34)
Shapes.SetText(oMsg, "You can also click above, push Ctrl+A, Ctrl+C to copy to clipboard")
Controls.ButtonClicked = File_OnButtonClicked
Controls.TextTyped = File_OnTextTyped
done = "False"
While Not[done]
cont = "True" ' continue
While cont
If typed Then
curDir = Program.Directory
relPath = Controls.GetTextBoxText(oFilename)
File_GetAbsPath()
filename = absPath
File_GetBasename()
lowerExt = Text.ConvertToLowerCase(ext)
typed = "False"
Else
Program.Delay(500)
EndIf
EndWhile
buf = Controls.GetTextBoxText(oText)
If (Controls.LastClickedButton = oSave) And (filename <> "") Then
dummy = "" ' for Silverlight
' The following line could be harmful and has been automatically commented.
' dummy = File.ReadContents(filename)
yes = "True"
If dummy <> "" Then
caution = "'" + basename + "." + ext + "' already exists." + CR + LF + "Do you want to replace it?"
Dialog_YesNo()
EndIf
If yes Then
' The following line could be harmful and has been automatically commented.
' File.WriteContents(filename, buf)
done = "True" ' saved
EndIf
ElseIf Controls.LastClickedButton = oCancel Then
done = "True" ' canceled
EndIf
EndWhile
Controls.Remove(oSave)
File_CloseDialog()
cont = Stack.PopValue("local")
EndSub
Sub File_OnButtonClicked
' File | Button event handler
cont = "False"
EndSub
Sub File_OnTextTyped
' File | Textbox event handler
If Controls.LastTypedTextBox = oFilename Then
typed = "True"
EndIf
EndSub
Sub Icon_Clear
' param add - "True" to add menu to mouse object
GraphicsWindow.BrushColor = "White"
GraphicsWindow.FillRectangle(xIcon, yIcon, iconWidth, iconHeight)
For row = 0 To iconHeight - 1
y = yEdit + row * (size + gap)
For col = 0 To iconWidth - 1
x = xEdit + col * (size + gap)
GraphicsWindow.FillRectangle(x, y, size, size)
EndFor
EndFor
If add Then
param = ""
param["name"] = "icon"
param["xLeft"] = xEdit
param["xRight"] = xEdit + iconWidth * (size + gap) - gap
param["yTop"] = yEdit
param["yBottom"] = yEdit + iconHeight * (size + gap) - gap
Mouse_AddObject()
EndIf
EndSub
Sub Icon_GetPixel
' param x, y - position in icon
' return color - got color
color = GraphicsWindow.GetPixel(xIcon + x, yIcon + y)
If Text.GetLength(color) = 9 Then
color = "#" + Text.GetSubTextToEnd(color, 4)
EndIf
EndSub
Sub Icon_MouseToXY
' param xRel, yRel - position in icon edit field
' return x, y - pixel of the icon or (-1, -1) if on the grid
x = Math.Floor(xRel / (size + gap))
y = Math.Floor(yRel / (size + gap))
If (iconWidth - 1 < x) Or (iconHeight - 1 < y) Then
x = -1
y = -1
Else
xMod = Math.Remainder(xRel, (size + gap))
yMod = Math.Remainder(yRel, (size + gap))
If (size - 1 < xMod) Or (size - 1 < yMod) Then
x = -1
y = -1
EndIf
EndIf
EndSub
Sub Icon_SetPixel
' param x, y - position in icon
' param color - set color
GraphicsWindow.SetPixel(xIcon + x, yIcon + y, color)
GraphicsWindow.BrushColor = color
GraphicsWindow.FillRectangle(xEdit + x * (size + gap), yEdit + y * (size + gap), size, size)
EndSub
Sub KB_Init
' Keyboard | Initialization (use only ^n, ^o, ^s, ^z, ^y)
shift = ""
ctrl = ""
keyIn = 0
keyOut = 0
GraphicsWindow.KeyDown = KB_OnKeyDown
GraphicsWindow.KeyUp = KB_OnKeyUp
EndSub
Sub KB_InKey
' Keyboard | In key
' return c - input key
If keyOut < keyIn Then
keyOut = keyOut + 1
c = fifo[keyOut]
'fifo[keyOut] = ""
EndIf
EndSub
Sub KB_OnKeyDown
' Keyboard | Key down event handler
key = GraphicsWindow.LastKey
If key = "LeftShift" Or key = "RightShift" Or key = "Shift" Then
shift = "+"
ElseIf key = "LeftCtrl" Or key = "RightCtrl" Then
ctrl = "^"
Else
' solution for known issue 29976 (keyIn increment moved after fifo update)
fifo[keyIn + 1] = shift + ctrl + key
keyIn = keyIn + 1
EndIf
EndSub
Sub KB_OnKeyUp
' Keyboard | Key up event handler
key = GraphicsWindow.LastKey
If key = "LeftShift" Or key = "RightShift" Or key = "Shift" Then
shift = ""
ElseIf key = "LeftCtrl" Or key = "RightCtrl" Then
ctrl = ""
EndIf
EndSub
Sub Macro_Add
' Macro | Add macro
' param msg - message command
iMacro = iMacro + 1
nMacro = iMacro
macro[iMacro] = msg
name = "undo"
Menu_EnableItem()
GraphicsWindow.Title = fname + " * - " + title
name = "redo"
Menu_DisableItem()
EndSub
Sub Macro_Init
' Macro | Initialize
macro = ""
iMacro = 0
nMacro = 0
name = "undo"
Menu_DisableItem()
GraphicsWindow.Title = fname + " - " + title
name = "redo"
Menu_DisableItem()
EndSub
Sub Macro_Redo
' Macro | Redo
If iMacro < nMacro Then
iMacro = iMacro + 1
msg = macro[iMacro]
If msg["cmd"] = "pixel" Then
x = msg["x"]
y = msg["y"]
color = msg["to"]
Icon_SetPixel()
ElseIf debug Then
TextWindow.ForegroundColor = "Red"
TextWindow.WriteLine("Unknown macro: '" + msg["cmd"] + "'")
TextWindow.ForegroundColor = "Gray"
EndIf
name = "undo"
Menu_EnableItem()
GraphicsWindow.Title = fname + " * - " + title
If iMacro = nMacro Then
name = "redo"
Menu_DisableItem()
EndIf
EndIf
EndSub
Sub Macro_Undo
' Macro | Undo
If 0 < iMacro Then
msg = macro[iMacro]
If msg["cmd"] = "pixel" Then
x = msg["x"]
y = msg["y"]
color = msg["from"]
Icon_SetPixel()
iMacro = iMacro - 1
name = "redo"
Menu_EnableItem()
If iMacro = 0 Then
name = "undo"
Menu_DisableItem()
GraphicsWindow.Title = fname + " - " + title
EndIf
ElseIf debug Then
TextWindow.ForegroundColor = "Red"
TextWindow.WriteLine("Unknown macro: '" + msg["cmd"] + "'")
TextWindow.ForegroundColor = "Gray"
EndIf
EndIf
EndSub
Sub Math_Hex2Dec
' Math | Convert hexadecimal to decimal
' param sHex
' return iDec
iDec = 0
iLen = Text.GetLength(sHex)
For iPtr = 1 To iLen
iDec = iDec * 16 + Text.GetIndexOf("0123456789ABCDEF", Text.GetSubText(sHex, iPtr, 1)) - 1
EndFor
EndSub
Sub Menu_Draw
GraphicsWindow.BrushColor = "#EEEEEE"
GraphicsWindow.FillRectangle(0, 0, gw, menuHeight)
item = "1=New;2=Open;3=Save;4=Undo;5=Redo;6=Pen Color;"
nItem = Array.GetItemCount(item)
add = "True"
For i = 1 To nItem
Menu_DrawItem()
EndFor
add = "False"
EndSub
Sub Menu_EnableItem
' param name - name of the menu item
' param item - array of the menu items
' param nItem - number of the menu items
i = 1
While (Text.ConvertToLowerCase(item[i]) <> Text.ConvertToLowerCase(name)) And (i <= nItem)
i = i + 1
EndWhile
If (i <= nItem) And (mask[i] <> "") Then
Shapes.Remove(mask[i])
mask[i] = ""
EndIf
EndSub
Sub Menu_DisableItem
' param name - name of the menu item
' param item - array of the menu items
' param nItem - number of the menu items
i = 1
While (Text.ConvertToLowerCase(item[i]) <> Text.ConvertToLowerCase(name)) And (i <= nItem)
i = i + 1
EndWhile
If (i <= nItem) And (mask[i] = "") Then
y = Math.Floor((menuHeight - itemSize - 10) / 2)
x = (i - 1) * (itemSize + itemGap) + itemGap
GraphicsWindow.PenWidth = 0
GraphicsWindow.BrushColor = "#EEEEEE"
mask[i] = Shapes.AddRectangle(itemSize, itemSize)
Shapes.SetOpacity(mask[i], 70)
Shapes.Move(mask[i], x, y)
EndIf
EndSub
Sub Menu_DrawItem
' param i - index number of the menu item
' param add - "True" to add menu to mouse object
y = Math.Floor((menuHeight - itemSize - 10) / 2)
x = (i - 1) * (itemSize + itemGap) + itemGap
url = "http://www.nonkit.com/smallbasic.files/" + Text.ConvertToLowerCase(item[i]) + ".png"
GraphicsWindow.DrawImage(url, x, y)
If add Then
param = ""
param["name"] = Text.ConvertToLowerCase(item[i])
param["xLeft"] = x
param["xRight"] = x + itemSize
param["yTop"] = y
param["yBottom"] = y + itemSize
Mouse_AddObject()
EndIf
fs = 10
GraphicsWindow.FontSize = fs
GraphicsWindow.FontBold = "False"
GraphicsWindow.FontName = "Trebuchet MS"
GraphicsWindow.BrushColor = "Black"
txt = item[i]
Text_GetWidthInPx()
dx = Math.Floor((itemSize - px) / 2)
GraphicsWindow.DrawText(x + dx, y + itemSize, item[i])
EndSub
Sub Mouse_AddObject
' Mouse | Add object to click
' param["name"] - name of the object to add
' param["xLeft"] - left x coordinate of the object
' param["xRight"] - right x coordinate of the object
' param["yTop"] - top y coordinate of the object
' param["yBottom"] - bottom y coordinate of the object
' return object
' return nObject
nObject = nObject + 1
object[nObject] = param
EndSub
Sub Mouse_DetectObject
' param mxD, myD - mouse clicked coordinate
' return name - clicked object name if found, "" if not found
' return xRel - relative x coordinate from left x of the object
' return yRel - relative y coordinate from top y of the object
name = "" ' not found
For iObject = 1 To nObject
obj = object[iObject]
If obj["xLeft"] <= mxD And mxD <= obj["xRight"] And obj["yTop"] <= myD And myD <= obj["yBottom"] Then
name = obj["name"] ' found
xRel = mxD - obj["xLeft"]
yRel = myD - obj["yTop"]
iObject = nObject ' break
EndIf
EndFor
EndSub
Sub Mouse_Init
' Mouse | Initialize for common event handler
clicked = "False"
released = "False"
moved = "False"
object = ""
nObject = 0
GraphicsWindow.MouseDown = Mouse_OnDown
EndSub
Sub Mouse_SetHandler
' Mouse | Set or reset common event handler
' param["down"] - "True" if set, "False" if reset
' param["move"] - "True" if set, "False" if reset
' param["up"] - - "True" if set, "False" if reset
' return clicked - "False" if set MouseDown
' return moved - "False" if set MouseMove
' return released - "False" if set MouseUp
' return dmu - which handlers are set for debug
If param["up"] Then
released = "False"
GraphicsWindow.MouseUp = Mouse_OnUp
handler["up"] = "U"
ElseIf Not[param["up"]] Then
GraphicsWindow.MouseUp = Mouse_DoNothing
handler["up"] = ""
EndIf
If param["down"] Then
clicked = "False"
GraphicsWindow.MouseDown = Mouse_OnDown
handler["down"] = "D"
ElseIf Not[param["down"]] Then
GraphicsWindow.MouseDown = Mouse_DoNothing
handler["down"] = ""
EndIf
If param["move"] Then
moved = "False"
GraphicsWindow.MouseMove = Mouse_OnMove
handler["move"] = "M"
ElseIf Not[param["move"]] Then
GraphicsWindow.MouseMove = Mouse_DoNothing
handler["move"] = ""
EndIf
dmu = handler["down"] + handler["move"] + handler["up"]
If debug Then
smrc = " set "
EndIf
EndSub
Sub Mouse_OnDown
' Mouse | Common event handler on mouse down
' return mxD, myD - position on mouse down
mxD = Math.Floor(GraphicsWindow.MouseX)
myD = Math.Floor(GraphicsWindow.MouseY)
clicked = "True"
released = "False"
If debug Then
smrc = " clicked " + mxD + "," + myD
EndIf
EndSub
Sub Mouse_DoNothing
' Mouse | Common event handler to do nothing
EndSub
Sub Mouse_OnMove
' Mouse | Common event handler on mouse move
' return mxM, myM - position on mouse move
mxM = Math.Floor(GraphicsWindow.MouseX)
myM = Math.Floor(GraphicsWindow.MouseY)
moved = "True"
If debug Then
smrc = " moved " + mxM + "," + myM
EndIf
EndSub
Sub Mouse_OnTick
' Mouse | debug routine
If clicked Then
cmr = "C"
Else
cmr = ""
EndIf
If moved Then
cmr = cmr + "M"
EndIf
If released Then
cmr = cmr + "R"
EndIf
GraphicsWindow.Title = title + smrc + " " + dmu + " " + cmr
EndSub
Sub Mouse_OnUp
' Mouse | Common event handler on mouse up
' return mxU, myU - position on mouse up
mxU = Math.Floor(GraphicsWindow.MouseX)
myU = Math.Floor(GraphicsWindow.MouseY)
released = "True"
If debug Then
smrc = " released " + mxU + "," + myU
EndIf
EndSub
Sub Msg_Init
' Message | Initialize
msgIn = 0
msgOut = 0
EndSub
Sub Msg_Set
' Message | Set message to fifo
' param["cmd"] - massage command
' param["*"].. - message operands
msgIn = msgIn + 1
message[msgIn] = param
EndSub
Sub Parse_Comment
' param buf - buffer to parse
' param p - poiter to the buffer
' return p - updated pointer
char = Text.GetSubText(buf, p, 1)
If char = "#" Then
lenBuf = Text.GetLength(buf)
While (char <> LF) And (p < lenBuf)
p = p + 1
char = Text.GetSubText(buf, p, 1)
EndWhile
EndIf
EndSub
Sub Parse_Decimal
' param buf - buffer to parse
' param p - poiter to the buffer
' return p - updated pointer
' return dec - decimal number
' return match - "True" if match
match = "False"
isDigit = "True"
dec = 0
While isDigit
char = Text.GetSubText(buf, p, 1)
If Text.IsSubText(DIGIT, char) Then
dec = dec * 10 + char
p = p + 1
match = "True"
Else
isDigit = "False"
EndIf
EndWhile
EndSub
Sub Parse_MagicNumber
' param buf - buffer to parse
' param p - poiter to the buffer
' return p - updated pointer
' return match - "True" if match
If Text.StartsWith(Text.GetSubTextToEnd(buf, p), "P3") Then
p = p + 2
match = "True"
Else
match = "False"
EndIf
EndSub
Sub Parse_PPM
' param buf - buffer to parse
' return p - updated pointer
' return match - "True" if match
p = 1
Parse_MagicNumber()
If match Then
Parse_WhiteSpaceAndComment()
EndIf
If match Then
Parse_Decimal()
If match Then
If dec <> iconWidth Then
match = "False"
EndIf
EndIf
EndIf
If match Then
Parse_WhiteSpaceAndComment()
EndIf
If match Then
Parse_Decimal()
If match Then
If dec <> iconHeight Then
match = "False"
EndIf
EndIf
EndIf
If match Then
Parse_WhiteSpaceAndComment()
EndIf
If match Then
Parse_Decimal()
If match Then
If 0 < dec And dec < 65536 Then
maxVal = dec
Else
match = "False"
EndIf
EndIf
EndIf
If match Then
Parse_WhiteSpaceAndComment()
EndIf
If match Then
Icon_Clear()
For y = 0 To iconHeight - 1
For x = 0 To iconWidth - 1
Parse_WhiteSpace()
Parse_Decimal()
If match Then
iR = Math.Floor(255 * dec / maxVal)
Else
Goto PPPM_Error
EndIf
Parse_WhiteSpace()
Parse_Decimal()
If match Then
iG = Math.Floor(255 * dec / maxVal)
Else
Goto PPPM_Error
EndIf
Parse_WhiteSpace()
Parse_Decimal()
If match Then
iB = Math.Floor(255 * dec / maxVal)
Else
Goto PPPM_Error
EndIf
color = GraphicsWindow.GetColorFromRGB(iR, iG, iB)
Icon_SetPixel()
EndFor
EndFor
EndIf
PPPM_Error:
EndSub
Sub Parse_WhiteSpace
' param buf - buffer to parse
' param p - poiter to the buffer
' return p - updated pointer
' return match - "True"
isSpace = "True"
While isSpace
char = Text.GetSubText(buf, p, 1)
If Text.IsSubText(" " + TAB + CR + LF, char) Then
p = p + 1
Else
isSpace = "False"
EndIf
EndWhile
match = "True"
EndSub
Sub Parse_WhiteSpaceAndComment
' param buf - buffer to parse
' param p - poiter to the buffer
' return p - updated pointer
' return match - "True"
isSpace = "True"
While isSpace
char = Text.GetSubText(buf, p, 1)
If char = "#" Then
Parse_Comment()
ElseIf Text.IsSubText(" " + TAB + CR + LF, char) Then
p = p + 1
Else
isSpace = "False"
EndIf
EndWhile
match = "True"
EndSub
Sub Popup_Init
TOPY = 10 ' top y
LEFTX = 10 ' left x
DELTAY = 36 ' delta y
OPACITY = 70
POPUPCOLOR = "LightGray"
CAPTIONCOLOR = "Black"
TEXTCOLOR = "Black"
BORDERCOLOR = "#666666"
BOXCOLOR = "LightGray"
SLITCOLOR = "#555555"
UNDEFINED = "N/A"
EndSub
Sub Slider_Add
' Slider | Add slider as shapes and property
' param width
' param caption
' param min, max
' param left, top
' return slider[] - property of slider
' return iSlider - added slider index
numSlider = numSlider + 1
iSlider = numSlider
' add shapes for slider
GraphicsWindow.BrushColor = CAPTIONCOLOR
len = Text.GetLength(caption)
sldr = slider[iSlider]
sldr["oCaption"] = Shapes.AddText(caption)
Shapes.Move(sldr["oCaption"], left - (len * 5 + 10), top + 1)
level = Math.Floor((min + max) / 2)
sldr["level"] = level ' property
sldr["min"] = min
sldr["max"] = max
GraphicsWindow.PenColor = BORDERCOLOR
mag = (level - min) / (max - min)
GraphicsWindow.BrushColor = SLITCOLOR
sldr["oSlit"] = Shapes.AddRectangle(width, 10)
GraphicsWindow.PenColor = BORDERCOLOR
GraphicsWindow.BrushColor = BOXCOLOR
sldr["oBox"] = Shapes.AddRectangle(10, 18)
GraphicsWindow.BrushColor = CAPTIONCOLOR
sldr["oLevel"] = Shapes.AddText(level)
sldr["x0"] = left
sldr["x1"] = left + width
sldr["y0"] = top
Shapes.Move(sldr["oLevel"], left + width + 5, top)
' move and zoom shapes for slider
Shapes.Move(sldr["oSlit"], left, top + 4)
slider[iSlider] = sldr
Slider_SetLevel()
EndSub
Sub Slider_CallBack
' Slider | Call back
' param iSlider - changed slider
CS_AdjustSlider()
CS_GetColorFromSlider()
CS_ShowNewColor() ' show new color name
CS_DrawColorRect() ' draw new color rectangle
EndSub
Sub Slider_GetLevel
' Slider | Get latest level of slider
' param iSlider
' return level
sldr = slider[iSlider]
level = sldr["level"]
EndSub
Sub Slider_GetMouseLevel
' Slider | Get mouse level of slider
' param iSlider
' return level
sldr = slider[iSlider]
x0 = sldr["x0"]
x1 = sldr["x1"]
max = sldr["max"]
min = sldr["min"]
level = min + Math.Floor((max - min) * (mxM - x0) / (x1 - x0))
EndSub
Sub Slider_WaitToRelease
' Slider | Get released point for slider moving
' param iSlider
param = "down=False;move=True;up=True;" ' for slider moving / wait to release
Mouse_SetHandler()
While Not[released]
If moved Then
param = "move=False;" ' while slider moving
Mouse_SetHandler()
sldr = slider[iSlider]
x0_ = sldr["x0"]
x1_ = sldr["x1"]
If mxM < x0_ Then
mxM = x0_
EndIf
If x1_ < mxM Then
mxM = x1_
EndIf
Slider_GetMouseLevel() ' get mouse level of slider
Slider_SetLevel() ' set slider level and move slider box
Slider_CallBack()
param = "move=True;" ' for next slider moving
Mouse_SetHandler()
Else
Program.Delay(100)
EndIf
EndWhile
param = "move=False;up=False;" ' mouse released
Mouse_SetHandler()
EndSub
Sub Slider_Remove
' Slider | Remove a slider
' param iSlider
sldr = slider[iSlider]
Shapes.Remove(sldr["oCaption"])
Shapes.Remove(sldr["oSlit"])
Shapes.Remove(sldr["oBox"])
Shapes.Remove(sldr["oLevel"])
EndSub
Sub Slider_SetLevel
' Slider | Set slider level and move slider box
' param iSlider
' param level
Stack.PushValue("local", width)
sldr = slider[iSlider]
x0 = sldr["x0"]
x1 = sldr["x1"]
y0 = sldr["y0"]
width = x1 - x0
sldr["level"] = level
Shapes.SetText(sldr["oLevel"], level)
' move bar
min = sldr["min"]
max = sldr["max"]
mag = (level - min) / (max - min)
' move box
Shapes.Move(sldr["oBox"], x0 + Math.Floor(width * mag) - 5, y0)
sldr["x2"] = x0 + Math.Floor(width * mag) - 5
sldr["x3"] = x0 + Math.Floor(width * mag) - 5 + 10
sldr["y2"] = y0
sldr["y3"] = y0 + 18
slider[iSlider] = sldr
width = Stack.PopValue("local")
EndSub
Sub Text_GetWidthInPx
' param txt - text to get width in px
' param ratio - character width/height in a font
' param fs - font size (height)
' return px - width in px (pixels)
len = Text.GetLength(txt)
px = 0
For p = 1 To len
px = px + ratio[Text.GetCharacterCode(Text.GetSubText(txt, p, 1))]
EndFor
px = Math.Floor(px * fs / 100)
EndSub