Here are some win api stunts.
To change the colour during run time i had to cheat by calling movewindow (to get into WM_PAINT)
I am sure Winapi experts will have a better method.
Code: Select all
#define WIN_INCLUDEALL
#Include Once "windows.bi"
#Include once "/win/commctrl.bi"
'for blue frame on message
Declare Function SetWindowTheme Lib "UxTheme.dll" Alias "SetWindowTheme"(As Any Ptr,As zstring Ptr,As zstring Ptr) As Long
Declare Sub CreateMessageWindow 'a seperate little window
' Globals (unavoidable)
Dim Shared As HFONT guiFont
Dim Shared As zString * 255 textMessage="Slide the trackbars"
Dim Shared As Long flag
Dim Shared As HWND MainWindow, MessageWindow
Dim Shared As HWND EditBox, Button,msgon,bar,label,bar2,label2,bar3,label3
Dim Shared As Long trackposX,trackposY,trackposZ
Function WndProc(hWnd As HWND, msg As UINT, wParam As WPARAM, lParam As LPARAM) As LRESULT
static as ubyte rd,gr,bl 'the colours
Select Case hWnd
Case MainWindow
Select Case msg
Case WM_HSCROLL'''TRACKBARS
Select Case lparam
Case bar'red
Dim As rect r
getwindowrect(Mainwindow,@r)'
trackposX= SendMessage(bar, TBM_GETPOS, 0, 0)
setwindowtext(label,"Red = "+Str(trackposX+0))
rd=trackposX
movewindow(mainWindow,r.left,r.top,800+(rnd-rnd),600,1) 'ACTIVATE WM_PAINT
Case bar2 'green
Dim As rect r
getwindowrect(Mainwindow,@r)'
trackposY= SendMessage(bar2, TBM_GETPOS, 0, 0)
setwindowtext(label2,"Green = "+Str(trackposY+0))
gr=trackposy
movewindow(mainWindow,r.left,r.top,800+(rnd-rnd),600,1)'ACTIVATE WM_PAINT
Case bar3 'blue
Dim As rect r
getwindowrect(Mainwindow,@r)'
trackposZ= SendMessage(bar3, TBM_GETPOS, 0, 0)
setwindowtext(label3,"Blue = "+Str(trackposZ+0))
bl=trackposZ
movewindow(mainWindow,r.left,r.top,800+(rnd-rnd),600,1)'ACTIVATE WM_PAINT
End Select
Case WM_PAINT
Dim As PAINTSTRUCT ps
BeginPaint(hWnd, @ps)
FillRect(ps.hdc, @ps.rcPaint, CreateSolidBrush(BGR(rd, gr, bl)))
EndPaint(hWnd, @ps)
Case WM_CLOSE
PostQuitMessage(NULL)
Case WM_COMMAND
Select Case lParam
Case msgon
CreateMessageWindow
End Select
Case Else
End Select
Case MessageWindow
Select Case msg
Case WM_COMMAND
Select Case lParam
Case editbox
Case Button
GetWindowText(EditBox, @textMessage, 255)
flag=0
destroywindow(messagewindow)
End Select
Case WM_CLOSE
flag=0
End Select
End Select
Return DefWindowProc(hWnd, msg, wParam, lParam)
End Function
Sub CreateMessageWindow 'new message box
If flag=0 Then
flag=1
MessageWindow = CreateWindowEx(NULL, "WindowClass", "Messages", WS_OVERLAPPEDWINDOW Or WS_VISIBLE,0,0, 300, 150, NULL, NULL, NULL, NULL)
EditBox = CreateWindowEx(WS_EX_CLIENTEDGE, "Edit", textmessage, WS_VISIBLE Or WS_CHILD Or WS_HSCROLL Or ES_AUTOHSCROLL Or ES_MULTILINE, 10, 0, 250, 50, MessageWindow, NULL, NULL, NULL)
Button = CreateWindowEx(NULL, "Button", "OK", WS_VISIBLE Or WS_CHILD, 10, 70, 200, 24, MessageWindow, NULL, NULL, NULL)
SetWindowTheme(messagewindow," "," ")' optional
End If
End Sub
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
'MAIN
' Create window class:
Dim As WNDCLASS wcls
With wcls
.style = CS_HREDRAW Or CS_VREDRAW
.lpfnWndProc = Cast(WNDPROC, @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, and message button
MainWindow = CreateWindowEx(NULL, "WindowClass", "MainWindow", WS_OVERLAPPEDWINDOW Or WS_VISIBLE, 100, 100, 800, 600, NULL, NULL, NULL, NULL)
msgon= CreateWindowEx(NULL, "Button", "Messages", WS_VISIBLE Or WS_CHILD , 10, 40, 90, 24, MainWindow, NULL, NULL, NULL)
'TRACKBARs and labels above them
bar= CreateWindowEx(NULL,TRACKBAR_CLASS, "Trackbar Control", WS_VISIBLE Or WS_CHILD Or TBS_AUTOTICKS Or TBS_ENABLESELRANGE, 100, 150, 200, 40, mainwindow,NULL, NULL, NULL)
bar2= CreateWindowEx(NULL,TRACKBAR_CLASS, "Trackbar Control", WS_VISIBLE Or WS_CHILD Or TBS_AUTOTICKS Or TBS_ENABLESELRANGE, 100, 250, 200, 40, mainwindow,NULL, NULL, NULL)
bar3=CreateWindowEx(NULL,TRACKBAR_CLASS, "Trackbar Control", WS_VISIBLE Or WS_CHILD Or TBS_AUTOTICKS Or TBS_ENABLESELRANGE, 100, 350, 200, 40, mainwindow,NULL, NULL, NULL)
label= CreateWindowEx(NULL,"static", "", WS_VISIBLE Or WS_CHILD , 100, 100, 200, 30, mainwindow,NULL, NULL, NULL)
label2= CreateWindowEx(NULL,"static", "", WS_VISIBLE Or WS_CHILD , 100, 200, 200, 30, mainwindow,NULL, NULL, NULL)
label3= CreateWindowEx(NULL,"static", "", WS_VISIBLE Or WS_CHILD , 100, 300, 200, 30, mainwindow,NULL, NULL, NULL)
SendMessage(bar, TBM_SETRANGE,TRUE, MAKELONG(0,255))'TRACKBAR 1
SendMessage(bar2, TBM_SETRANGE,TRUE, MAKELONG(0,255))'TRACKBAR 2
SendMessage(bar3, TBM_SETRANGE,TRUE, MAKELONG(0,255))'TRACKBAR 2
'set up four tooltips
'on all trackbars and message box
CreateToolTip(bar,"Red scaler")
CreateToolTip(bar2,"Green scaler")
CreateToolTip(bar3,"Blue scaler")
CreateToolTip(msgon,"instructions")
SetWindowTheme(mainwindow," "," ")' optional
Dim As MSG uMsg
While GetMessage(@uMsg, NULL, NULL, NULL) <> FALSE
TranslateMessage(@uMsg)
DispatchMessage(@uMsg)
Wend