    '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 MakeLong(lo,hi) { ( (lo) or ( (hi)<<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
     