Code:
#COMPILE EXE #INCLUDE "\pbwin90\winapi\win32api.inc" #INCLUDE "\pbwin90\winapi\commctrl.inc" GLOBAL hinstance& GLOBAL prevtabproc& FUNCTION WINMAIN(BYVAL hinst&,BYVAL hprev&,BYVAL cmdline AS ASCIIZ PTR,BYVAL cmdshow&) AS LONG hinstance&=hinst& initcommoncontrols ''create class and register it with windows DIM wclassname AS ASCIIZ*80 DIM wcaption AS ASCIIZ*80 wclassname="TestColorTabs" DIM wclass AS wndclass wclass.style=%cs_hredraw OR %cs_vredraw wclass.lpfnwndproc=CODEPTR(wndproc) wclass.cbclsextra=0 wclass.cbwndextra=0 wclass.hinstance=hinstance& wclass.hicon=%null wclass.hcursor=loadcursor(%null,BYVAL %idc_arrow) wclass.hbrbackground=%null ''getstockobject(%gray_brush) wclass.lpszmenuname=%null wclass.lpszclassname=VARPTR(wclassname) registerclass wclass ''get size - user defined size or default size DIM wndrect AS rect systemparametersinfo %spi_getworkarea,0,wndrect,0 xsize&=((wndrect.nright-wndrect.nleft)+1-64) ysize&=((wndrect.nbottom-wndrect.ntop)+1-64) xstt&=wndrect.nleft+32 ystt&=wndrect.ntop+32 ''create window wcaption="Test Color Tabs" style&=%WS_OVERLAPPEDWINDOW OR %WS_THICKFRAME OR %WS_CLIPSIBLINGS hwnd&=createwindow(wclassname, _ ''window class name wcaption, _ ''window caption style&, _ ''window style xstt&, _ ''initial x position ystt&, _ ''initial y position xsize&, _ ''initial x size ysize&, _ ''initial y size %null, _ ''parent window handle %null, _ ''window menu handle hinstance&, _ ''program instance handle %null) ''creation parameters showwindow hwnd&,cmdshow& updatewindow hwnd& DIM wmsg AS tagmsg WHILE ISTRUE(getmessage(wmsg,BYVAL %null,0,0)) translatemessage wmsg dispatchmessage wmsg WEND FUNCTION=wmsg.wparam END FUNCTION FUNCTION wndproc(BYVAL hwnd&,BYVAL msg&,BYVAL wparam&,BYVAL lparam&) AS LONG STATIC ztext AS ASCIIZ*256 STATIC htoolbar&,hstatuswin&,htab& DIM rc AS rect DIM disptr AS drawitemstruct PTR DIM ti AS tc_item SELECT CASE msg& CASE %WM_CREATE ''create controls ' getclientrect hwnd&,rc ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''create tooltips DIM tbb(0:12) AS STATIC tbbutton tbb(0).ibitmap=%std_filenew tbb(0).idcommand=9001 tbb(0).fsstate=%TBSTATE_ENABLED tbb(0).fsstyle=%TBSTYLE_BUTTON tbb(0).dwdata=0 tbb(0).istring=0 tbb(1).ibitmap=%std_fileopen tbb(1).idcommand=9002 tbb(1).fsstate=%TBSTATE_ENABLED tbb(1).fsstyle=%TBSTYLE_BUTTON tbb(1).dwdata=0 tbb(1).istring=0 tbb(2).ibitmap=%std_filesave tbb(2).idcommand=9003 tbb(2).fsstate=%TBSTATE_ENABLED tbb(2).fsstyle=%TBSTYLE_BUTTON tbb(2).dwdata=0 tbb(2).istring=0 tbb(3).ibitmap=0 tbb(3).idcommand=0 tbb(3).fsstate=%TBSTATE_ENABLED tbb(3).fsstyle=%TBSTYLE_SEP tbb(3).dwdata=0 tbb(3).istring=0 tbb(4).ibitmap=%std_cut tbb(4).idcommand=9004 tbb(4).fsstate=%TBSTATE_ENABLED tbb(4).fsstyle=%TBSTYLE_BUTTON tbb(4).dwdata=0 tbb(4).istring=0 tbb(5).ibitmap=%std_copy tbb(5).idcommand=9005 tbb(5).fsstate=%TBSTATE_ENABLED tbb(5).fsstyle=%TBSTYLE_BUTTON tbb(5).dwdata=0 tbb(5).istring=0 tbb(6).ibitmap=%std_paste tbb(6).idcommand=9006 tbb(6).fsstate=%TBSTATE_ENABLED tbb(6).fsstyle=%TBSTYLE_BUTTON tbb(6).dwdata=0 tbb(6).istring=0 tbb(7).ibitmap=%std_delete tbb(7).idcommand=9007 tbb(7).fsstate=%TBSTATE_ENABLED tbb(7).fsstyle=%TBSTYLE_BUTTON tbb(7).dwdata=0 tbb(7).istring=0 tbb(8).ibitmap=0 tbb(8).idcommand=0 tbb(8).fsstate=%TBSTATE_ENABLED tbb(8).fsstyle=%TBSTYLE_SEP tbb(8).dwdata=0 tbb(8).istring=0 tbb(9).ibitmap=%std_properties tbb(9).idcommand=9008 tbb(9).fsstate=%TBSTATE_ENABLED tbb(9).fsstyle=%TBSTYLE_BUTTON tbb(9).dwdata=0 tbb(9).istring=0 tbb(10).ibitmap=%std_find tbb(10).idcommand=9009 tbb(10).fsstate=%TBSTATE_ENABLED tbb(10).fsstyle=%TBSTYLE_BUTTON tbb(10).dwdata=0 tbb(10).istring=0 tbb(11).ibitmap=%std_print tbb(11).idcommand=9010 tbb(11).fsstate=%TBSTATE_ENABLED tbb(11).fsstyle=%TBSTYLE_BUTTON tbb(11).dwdata=0 tbb(11).istring=0 tbb(12).ibitmap=%std_help tbb(12).idcommand=9011 tbb(12).fsstate=%TBSTATE_ENABLED tbb(12).fsstyle=%TBSTYLE_BUTTON tbb(12).dwdata=0 tbb(12).istring=0 style&=%WS_CHILD OR %WS_BORDER OR %WS_VISIBLE OR %SBS_SIZEGRIP hstatuswin&=createstatuswindow(style&,"",hwnd&,9999) style&=%WS_CHILD OR %TBSTYLE_TOOLTIPS OR %TBSTYLE_FLAT htoolbar&=createtoolbarex(hwnd&,style&,9000,12,%hinst_commctrl, _ %idb_std_large_color,tbb(0),13, _ 0,0,100,30, _ LEN(tbbutton)) sendmessage htoolbar&,%tb_autosize,0,0 showwindow htoolbar&,%SW_SHOW getwindowrect htoolbar&,rc toolheight&=rc.nbottom-rc.ntop getwindowrect hstatuswin&,rc statheight&=rc.nbottom-rc.ntop ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' this code was previously in error getclientrect hwnd&,rc x1&=0 y1&=toolheight& x2&=rc.nright-rc.nleft y2&=(rc.nbottom-rc.ntop)-(toolheight&+statheight&) style&=%WS_CHILD OR %WS_VISIBLE OR %TCS_TABS OR %TCS_OWNERDRAWFIXED _ OR %WS_CLIPSIBLINGS OR %WS_CLIPCHILDREN htab&=createwindow("SysTabControl32","",style&, _ x1&,y1&,x2&,y2&,hwnd&,1000,hinstance&,%null) inserttab htab&,0,"Test1" inserttab htab&,1,"Test2" inserttab htab&,2,"Test3" inserttab htab&,3,"Test4" inserttab htab&,4,"Test5" inserttab htab&,5,"Test6" ''subclass the tab control prevtabproc&=setwindowlong(htab&,%gwl_wndproc,CODEPTR(tabsubclassproc)) CASE %WM_DRAWITEM IF wparam&=1000 THEN ''tab control disptr=lparam& ' ------------------- SaveDC @disptr.hdc ' ------------------- tabheight&=(@[email protected]) pg&[email protected] IF @disptr.itemstate=%ods_selected THEN @[email protected]+2 fcolor&=RGB(255,255,255) bcolor&=RGB(128,128,255) ELSE fcolor&=RGB(0,0,0) bcolor&=RGB(176,176,255) END IF hbrush&=createsolidbrush(bcolor&) selectobject @disptr.hdc,hbrush& settextcolor @disptr.hdc,fcolor& setbkcolor @disptr.hdc,bcolor& fillrect @disptr.hdc,@disptr.rcitem,hbrush& ti.mask=%TCIF_TEXT ti.psztext=VARPTR(ztext) ti.cchtextmax=SIZEOF(ztext) CALL tabctrl_getitem(getdlgitem(hwnd&,wparam&),@disptr.itemid,ti) style&=%dt_singleline OR %dt_center OR %dt_top drawtext @disptr.hdc,ztext,LEN(ztext),@disptr.rcitem,style& deleteobject hbrush& ' ------------------- RestoreDC @disptr.hdc, 1 ' ------------------- FUNCTION=1 EXIT FUNCTION END IF CASE %WM_PAINT ' dim ps as paintstruct ' hdc&=beginpaint(hwnd&,ps) ' ' endpaint hwnd&,ps CASE %WM_MOVE invalidaterect hwnd&,BYVAL %null,%false updatewindow hwnd& CASE %WM_NOTIFY DIM nmh AS nmhdr PTR nmh=lparam& SELECT CASE @nmh.idfrom CASE 1000 ''main tabs SELECT CASE @nmh.code CASE %TCN_SELCHANGING CASE %TCN_SELCHANGE END SELECT END SELECT CASE %wm_syscommand IF (wparam& AND &hfff0)<>%SC_CLOSE THEN EXIT SELECT destroywindow hwnd& FUNCTION=1 EXIT FUNCTION CASE %WM_COMMAND CASE %WM_DESTROY ''remove subclass setwindowlong htab&,%gwl_wndproc,prevtabproc& postquitmessage 0 FUNCTION=0 EXIT FUNCTION END SELECT FUNCTION=defwindowproc(hwnd&,msg&,wparam&,lparam&) END FUNCTION FUNCTION SetColor (BYVAL COLOR AS BYTE) AS WORD ' the windows api GradientFill routine wants r/g/b colors to be ' 16 bit words with the 8 bit color values left shifted 8 bits. ' this takes care of that. LOCAL clr AS WORD clr = COLOR SHIFT LEFT clr, 8 FUNCTION = clr END FUNCTION SUB PaintTabBg(BYVAL hCtl AS LONG,BYVAL hdc AS LONG,BYVAL r AS LONG, BYVAL g AS LONG, BYVAL b AS LONG) ' this paints the actual tab body LOCAL rc AS Rect LOCAL Xin AS LONG LOCAL Yin AS LONG LOCAL r2 AS LONG, g2 AS LONG, b2 AS LONG, offset AS LONG DIM vert(1) AS TRIVERTEX DIM gRect AS GRADIENT_RECT GetClientRect hCtl, rc Xin = rc.nRight - rc.nLeft Yin = rc.nBottom - rc.nTop vert(0).x = 0 vert(0).y = 0 vert(0).Red = SetColor(r) vert(0).Green = SetColor(g) vert(0).Blue = SetColor(b) vert(0).Alpha = &h0000 vert(1).x = Xin vert(1).y = Yin offset=128 r2=r-offset IF r2<0 THEN r2=0 g2=g-offset IF g2<0 THEN g2=0 b2=b-offset IF b2<0 THEN b2=0 vert(1).Red = SetColor(r2) vert(1).Green = SetColor(g2) vert(1).Blue = SetColor(b2) vert(1).Alpha = &h0000 gRect.UpperLeft = 0 gRect.LowerRight = 1 GradientFill hDc, vert(0), 2, gRect, 1, %GRADIENT_FILL_RECT_v END SUB FUNCTION tabsubclassproc(BYVAL hwnd&,BYVAL msg&,BYVAL wparam&,BYVAL lparam&) AS LONG DIM rc AS rect SELECT CASE msg& CASE %wm_erasebkgnd PaintTabBg hwnd&,wparam&,128,128,255 FUNCTION=1 EXIT FUNCTION END SELECT FUNCTION=callwindowproc(prevtabproc&,hwnd&,msg&,wparam&,lparam&) END FUNCTION FUNCTION inserttab(BYVAL hctl&,BYVAL i&,BYVAL txt$) AS LONG DIM tbctl AS tc_item DIM ztext AS ASCIIZ*255 ztext=txt$ tbctl.mask=%TCIF_TEXT tbctl.psztext=VARPTR(ztext) tbctl.cchtextmax=LEN(txt$) tbctl.iimage=%null FUNCTION=sendmessage(hctl&,%tcm_insertitem,i&,VARPTR(tbctl)) END FUNCTION
I attached a screenshot of the gradient tab control below:
Leave a comment: