Code: Select all
#Include Once "windows.bi"
#Include once "/win/commctrl.bi"
Declare Function CreateTrackBar(dest As hwnd,x As Long,y As Long,lngth As Long,height As Long,range As Long,pagesize As Long) As hwnd
Declare Function CreateToolTip(X As hwnd,msg As String="") As hwnd
Declare Function fb_Set_Font (Font As String,Size As Integer,Bold As Integer=0,Italic As Integer=0,Underline As Integer=0,StrikeThru As Integer=0) As HFONT
Declare function closest(tp as long,tic as long,range as long) as long
Declare Function main As Long
End main
Function WndProc(hWnd As HWND, msg As UINT, wParam As WPARAM, lParam As LPARAM) As LRESULT
#define nobreak(n) End Select: Select Case n
Static As Ubyte rd,gr,bl 'the colours for the mainwindow
Static As PAINTSTRUCT ps
Static As rect r
Static As HWND bar,label,bar2,label2,bar3,label3,hnw
var tic=25,range=255
Select Case msg ' set up
Case WM_CREATE
label= CreateWindowEx(NULL,"static", "", WS_VISIBLE Or WS_CHILD , 0, 150, 100, 40, hwnd,NULL, NULL, NULL)
label2= CreateWindowEx(NULL,"static", "", WS_VISIBLE Or WS_CHILD , 0, 250, 100, 40, hwnd,NULL, NULL, NULL)
label3= CreateWindowEx(NULL,"static", "", WS_VISIBLE Or WS_CHILD , 0, 350, 100, 40, hwnd,NULL, NULL, NULL)
hnw=CreateWindowEx(NULL,"static", "", WS_VISIBLE Or WS_CHILD , 0, 450, 190, 40, hwnd,NULL, NULL, NULL)
setwindowtext(label,"Red 0")
setwindowtext(label2,"Green 0")
setwindowtext(label3,"Blue 0")
setwindowtext(hnw," Happy new year")
'set up three trackbars
bar =CreateTrackBar(hwnd,100, 150, 300, 40,range,tic)
bar2=CreateTrackBar(hwnd,100, 250, 400, 40,range,tic)
bar3=CreateTrackBar(hwnd,100, 350, 600, 40,range,tic)
'set up tooltips on all trackbar thumbs
CreateToolTip(bar,"Red scaler, length=300")
CreateToolTip(bar2,"Green scaler, length=400")
CreateToolTip(bar3,"Blue scaler, length=600")
Dim As HFONT f1=fb_Set_Font("Courier new",14,,true),f2=fb_Set_Font("times new roman",20,,true)
SendMessage(label,WM_SETFONT,Cast(WPARAM,f1),0)
SendMessage(label2,WM_SETFONT,Cast(WPARAM,f1),0)
SendMessage(label3,WM_SETFONT,Cast(WPARAM,f1),0)
SendMessage(hnw,WM_SETFONT,Cast(WPARAM,f2),0)
End Select
Select Case hWnd
Case hwnd
Select Case msg
Case WM_CTLCOLORstatic
Var dcH = Cast(HDC, Wparam)
SetBkMode(dcH, TRANSPARENT)
SetTextColor(dcH, BGR(0,0,0))
Static BrushH As HBRUSH
If BrushH = NULL Then
BrushH = Cast(HBRUSH, CreateSolidBrush(BGRA(200,200,200,0)))
End If
Return Cast(LRESULT,BrushH)
Case WM_HSCROLL 'TRACKBARS
Select Case lparam
Case bar'red
var trackpos= SendMessage(bar, TBM_GETPOS, 1, 0)
setwindowtext(label,"Red "+Str(trackpos))
rd=closest(trackpos,tic,range)
var k=iif(rd>=225,1,0)
SendMessage(bar,TBM_SETPOS,k,rd)
nobreak(lparam) ' C style switch
Case bar2 'green
var trackpos= SendMessage(bar2, TBM_GETPOS, 0, 0)
setwindowtext(label2,"Green "+Str(trackpos))
gr=closest(trackpos,tic,range)
var k=iif(gr>=225,1,0)
SendMessage(bar2,TBM_SETPOS,k,gr)
nobreak(lparam) ' C style switch
Case bar3 'blue
var trackpos= SendMessage(bar3, TBM_GETPOS, 0, 0)
setwindowtext(label3,"Blue "+Str(trackpos))
bl=closest(trackpos,tic,range)
var k=iif(bl>=225,1,0)
SendMessage(bar3,TBM_SETPOS,k,bl)
nobreak(lparam) ' C style switch
Case Else 'Always gets here
Static As Long k=1
k=-k
getwindowrect(hwnd,@r)
movewindow(hwnd,r.left,r.top,800+k,600,1)'ACTIVATE WM_PAINT
End Select
Case WM_PAINT
BeginPaint(hWnd, @ps)
FillRect(ps.hdc, @ps.rcPaint, CreateSolidBrush(BGR(rd, gr, bl)))
EndPaint(hWnd, @ps)
Case WM_CLOSE
PostQuitMessage(NULL)
Case Else
'not decided
End Select
End Select
Return DefWindowProc(hWnd, msg, wParam, lParam)
End Function
Function CreateToolTip(X As hwnd,msg As String="") As hwnd
Dim As hwnd TT= CreateWindowEx(0,"ToolTips_Class32","",64,0,0,0,0,X,0,GetModuleHandle(0),0)
'64=bubble,0 = rectangle
SendMessage(TT, TTM_SETMAXTIPWIDTH, 0 , 180)
SendMessage(TT, TTM_SETDELAYTIME, TTDT_INITIAL ,40)
SendMessage(TT, TTM_SETDELAYTIME, TTDT_RESHOW ,60)
Dim bubble As TOOLINFO
bubble.cbSize = Len(TOOLINFO)
bubble.uFlags = TTF_IDISHWND Or TTF_SUBCLASS
bubble.uId = Cast(Uinteger,X)
bubble.lpszText = Strptr(msg)
SendMessage(TT, TTM_ADDTOOL, 0,Cast(LPARAM,@bubble))
Return TT
End Function
Function CreateTrackBar(dest As hwnd,x As Long,y As Long,lngth As Long,height As Long,range As Long,pagesize As Long) As hwnd
Dim As hwnd h=CreateWindowEx(NULL,TRACKBAR_CLASS, "Trackbar Control", WS_VISIBLE Or WS_CHILD Or TBS_AUTOTICKS Or TBS_ENABLESELRANGE,x,y,lngth,height,dest,NULL, NULL, NULL)
SendMessage(h,TBM_SETRANGE,TRUE, MAKELONG(0,range))
SendMessage(h,TBM_SETTICFREQ,pagesize,0)'Set tic frequency
SendMessage(h,TBM_SETPAGESIZE,0,pagesize) 'Set page size
Return h
End Function
Function fb_Set_Font (Font As String,Size As Integer,Bold As Integer,Italic As Integer,Underline As Integer,StrikeThru As Integer) As HFONT
Dim As HDC hDC=GetDC(HWND_DESKTOP)
Dim As Integer CyPixels=GetDeviceCaps(hDC,LOGPIXELSY)
ReleaseDC(HWND_DESKTOP,hDC)
Return CreateFont(0-(Size*CyPixels)/72,0,0,0,Bold,Italic,Underline,StrikeThru,ANSI_CHARSET _
,OUT_TT_PRECIS,CLIP_DEFAULT_PRECIS,DEFAULT_QUALITY,FF_DONTCARE,Font)
End Function
function closest(tp as long,tic as long,range as long) as long
dim as long d=10000,res
for n as long=0 to range step tic
var dd=abs(n-tp)
if d>dd then d=dd:res=n
next
if tp=range then return range
return res
end function
Function MAIN As Long
static as hwnd MainWindow
' Create window class:
Dim As WNDCLASS wcls
Function=0
With wcls
.style = CS_HREDRAW Or CS_VREDRAW
.lpfnWndProc = @WndProc
.hInstance = GetModuleHandle(NULL)
.hIcon = LoadIcon(NULL, IDI_APPLICATION)
.hCursor = LoadCursor(NULL, IDC_ARROW)
.hbrBackground = GetStockObject(WHITE_BRUSH)
.lpszMenuName = NULL
.lpszClassName = Strptr("WindowClass")
End With
If RegisterClass(@wcls) = FALSE Then
MessageBox(NULL, "RegisterClass('WindowClass') FAIL!", "Error!", MB_OK Or MB_ICONERROR)
End
End If
'mainwindow
MainWindow = CreateWindowEx(NULL, "WindowClass", "MainWindow", WS_OVERLAPPEDWINDOW Or WS_VISIBLE, 100, 100, 800, 600, NULL, NULL, NULL, NULL)
Dim As MSG uMsg
While GetMessage(@uMsg, NULL, NULL, NULL) <> FALSE
TranslateMessage(@uMsg)
DispatchMessage(@uMsg)
Wend
End Function