'http://zetcode.com/gui/winapi/customcontrols/
'slightly modified
$ filename "BurningControl.exe"
'uses rtl32
'uses rtl64
uses WinUtil
% GCLP_HBRBACKGROUND= -10
% TRACKBAR_CLASS="msctls_trackbar32"
% ICC_BAR_CLASSES=4
% COLOR_3DFACE=15
% COLOR_BTNFACE=15
% TBM_SETRANGE=1030
% TBM_SETPAGESIZE=1045
% TBM_SETTICFREQ=1044
% TBM_GETPOS=1024
% TBM_SETPOS=1029
% SWP_NOZORDER=4
% PS_NULL=5
% DT_CENTER=1
% TBS_NOTICKS=16
% TBS_FIXEDLENGTH=64
macro makelong(wlow, whigh) {dword wlow | dword (whigh<<16)}
macro RGB(r,g,b) {r+(g<<8)+(b<<16)}
int g_pos = 150
% EDIT_ID = 1000
'Register Common Controls
INITCOMMONCONTROLSEXt iccex
iccex.dwSize=sizeof(iccex)
iccex.dwICC= ICC_BAR_CLASSES
InitCommonControlsEx(&iccex)
sys hInstance=inst
MainWindow 400,250,WS_OVERLAPPEDWINDOW
function WndProc(sys hwnd, uint uMsg, sys wParam, lParam) as sys callback
static sys hwndTrack, hwndBurn, hEdit
WNDCLASSEX wc
select uMsg
case WM_CREATE
SetWindowText(hwnd,"Burning control")
'Adjust color of MainWindow
SetClassLongPtr(hwnd,GCLP_HBRBACKGROUND, GetSysColorBrush(COLOR_3DFACE))
'Custom control
wc.cbSize = sizeof(WNDCLASSEX)
wc.lpszClassName = strptr "BurningControl"
wc.hbrBackground = GetSysColorBrush(COLOR_BTNFACE)
wc.style = CS_HREDRAW
wc.lpfnWndProc = @PanelProc
wc.hCursor = LoadCursor(0, IDC_ARROW)
if not RegisterClassEx(&wc) then
MessageBox(null, "BurningControl Registration Failed!", "Error!",
MB_ICONEXCLAMATION or MB_OK)
return 0
end if
hwndBurn = CreateWindowEx(
WS_EX_STATICEDGE,
"BurningControl",
null,
WS_CHILD | WS_VISIBLE,
0,0,0,0,
hwnd, 1, null, null)
'Slider control
hwndTrack = CreateWindowEx(
0,
TRACKBAR_CLASS,
null,
WS_CHILD | WS_VISIBLE | TBS_FIXEDLENGTH | TBS_NOTICKS,
40, 25, 150, 25,
hwnd, 2, hInstance, null)
SendMessage(hwndTrack, TBM_SETRANGE, true, makelong(0,750))
' SendMessage(hwndTrack, TBM_SETRANGE, true, makelong(100-10, 1500\2))
SendMessage(hwndTrack, TBM_SETPAGESIZE, 0, 20)
SendMessage(hwndTrack, TBM_SETTICFREQ, 20, 0)
SendMessage(hwndTrack, TBM_SETPOS, true, 150)
'Edit control
hEdit = CreateWindowEx(
WS_EX_CLIENTEDGE,
"edit",
"",
WS_CHILD | WS_VISIBLE | ES_READONLY,
40, 70, 60, 25,
hWnd, EDIT_ID, hInstance, null)
g_pos = SendMessage(hwndTrack, TBM_GETPOS, 0, 0)
SetWindowText(hEdit, str(g_pos))
case WM_SIZE
SetWindowPos(hwndBurn, null, 0, hiword(lParam)-30, loword(lParam), 30, SWP_NOZORDER)
case WM_HSCROLL
g_pos = SendMessage(hwndTrack, TBM_GETPOS, 0, 0)
SetWindowText(hEdit, str(g_pos))
InvalidateRect(hwndBurn, null, true)
case WM_CLOSE
DestroyWindow(hwnd)
case WM_DESTROY
PostQuitMessage(0)
case else
return DefWindowProc(hwnd, uMsg, wParam, lParam)
end select
return 0
end function
function PanelProc(sys hwnd, uint msg, sys wParam, lParam) as sys callback
sys hBrushYellow, hBrushRed, holdBrush
sys hPen, holdPen
sys hFont, holdFont
PAINTSTRUCT ps
RECT rect, rect2
string cap[]={"75","150", "225","300","375","450","525","600","675"}
sys hdc
int till
int gap, full
int i
select msg
case WM_PAINT
hdc = BeginPaint(hwnd, &ps)
GetClientRect(hwnd, &rect)
till = (rect.right / 750.0) * g_pos
gap = rect.right / 10.0
full = (rect.right / 750.0) * 700
hBrushYellow = CreateSolidBrush(RGB(255, 255, 184))
hBrushRed = CreateSolidBrush(RGB(255, 110, 110))
hPen = CreatePen(PS_NULL, 1, RGB(0, 0, 0))
holdPen = SelectObject(hdc, hPen)
hFont = CreateFont(13, 0, 0, 0, FW_BOLD, 0, 0, 0, 0,
0, 0, 0, 0, "Tahoma")
holdFont = SelectObject(hdc, hFont)
if (till > full) then
SelectObject(hdc, hBrushYellow)
Rectangle(hdc, 0, 0, full, 30)
holdBrush = SelectObject(hdc, hBrushRed)
Rectangle(hdc, full, 0, till, 30)
else
holdBrush = SelectObject(hdc, hBrushYellow)
Rectangle(hdc, 0, 0, till, 30)
end if
SelectObject(hdc, holdPen)
for i = 1 to 9
MoveToEx(hdc, i*gap, 0, null)
LineTo(hdc, i*gap, 7)
rect2.bottom = 28
rect2.top = 8
rect2.left = i*gap-10
rect2.right = i*gap+10
SetBkMode(hdc, TRANSPARENT)
DrawText(hdc, cap[i], len(cap[i]), &rect2, DT_CENTER)
next i
SelectObject(hdc, holdBrush)
DeleteObject(hBrushYellow)
DeleteObject(hBrushRed)
DeleteObject(hPen)
SelectObject(hdc, holdFont)
DeleteObject(hFont)
EndPaint(hwnd, &ps)
case else
return DefWindowProc(hwnd, msg, wParam, lParam)
end select
end function