Announcement

Collapse
No announcement yet.

Tab Control and gradient shading problem

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • Chris Boss
    replied
    I combined Bob's code and Jim's code, so the tab control uses a gradient:

    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:
    Attached Files
    Last edited by Chris Boss; 5 May 2009, 11:59 PM.

    Leave a comment:


  • Jim Seekamp
    replied
    Man, what a lame-brained error...
    I never even thought of that.
    Thanks for the help, Chris.

    Leave a comment:


  • Chris Boss
    replied
    The problems with your code was your calculations of the height of the tab control. Simply put, they were wrong. You used the rc variable (RECT) twice in two different API calls, so the value was changed later and so it was incorrect when you used it. Your tab control was coming out 23 pixels high.

    I rewrote the calculation code to get the correct height for the tab control.

    This code now works:

    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
               ' -------------------
               [EMAIL="tabheight&[email protected]@disptr.rcitem.ntop"]tabheight&[email protected]@disptr.rcitem.ntop[/EMAIL]
               [EMAIL="pg&[email protected]"]pg&[email protected][/EMAIL]
               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 tabsubclassproc(BYVAL hwnd&,BYVAL msg&,BYVAL wparam&,BYVAL lparam&) AS LONG
         DIM rc AS rect
         SELECT CASE msg&
           CASE %wm_erasebkgnd
             hdc&=wparam&
             getclientrect hwnd&,rc
             bcolor&=RGB(128,128,255)
             hbrush&=createsolidbrush(bcolor&)
             fillrect hdc&,rc,hbrush&
             deleteobject hbrush&
             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

    Leave a comment:


  • Jim Seekamp
    replied
    Here's a test program with the exact same problem...

    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)
         ysize&=((wndrect.nbottom-wndrect.ntop)+1)
         xstt&=0
         ystt&=0
    
    ''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
    
             '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
             x1&=0
             y1&=toolheight&
             x2&=rc.nright-rc.nleft
             y2&=rc.nbottom-rc.ntop
    
             style&=%ws_child or %ws_visible or %tcs_tabs or %tcs_ownerdrawfixed _
                    or %ws_clipsiblings
    
             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&
               tabheight&[email protected]@disptr.rcitem.ntop
               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&
    
               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 tabsubclassproc(byval hwnd&,byval msg&,byval wparam&,byval lparam&) as long
    
         dim rc as rect
    
         select case msg&
           case %wm_erasebkgnd
             hdc&=wparam&
    
             getclientrect hwnd&,rc
             bcolor&=rgb(64,128,255)
    
             hbrush&=createsolidbrush(bcolor&)
             fillrect hdc&,rc,hbrush&
             deleteobject hbrush&
    
             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
    Last edited by Jim Seekamp; 5 May 2009, 04:40 PM.

    Leave a comment:


  • Jim Seekamp
    replied
    Hmmm.... even with subclassing, I can't get the tab's background to fill in: it comes in invisible (see-through!)

    I subclassed the control:
    Code:
             style&=%ws_child or %ws_visible or %tcs_tabs or %tcs_ownerdrawfixed _
                    or %ws_clipsiblings
    
            htab&=actualsizecontrol("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))
    I added the subclass function:

    Code:
    function tabsubclassproc(byval hwnd&,byval msg&,byval wparam&,byval lparam&) as long
    
         dim rc as rect
    
         select case msg&
           case %wm_erasebkgnd
             hdc&=wparam&
             getclientrect hwnd&,rc
             bcolor&=rgb(64,128,255)
             hbrush&=createsolidbrush(bcolor&)
             fillrect hdc&,rc,hbrush&
             deleteobject hbrush&
    
             function=1
             exit function
         end select
         function=callwindowproc(prevtabproc&,hwnd&,msg&,wparam&,lparam&)
    end function
    and got rid of the %wm_erasebkgnd in the main wndproc...
    I left the %wm_drawitem (which still works) as is...

    and prevtabproc is a global variable
    Any ideas what's wrong??

    Leave a comment:


  • BOB MECHLER
    replied
    Using 'Beyond Compare' I understand this much better. It also became clear that if I had read the documentation on WM_ERASEBKGND I would have known that I already had the hDc. The repetition of the code after the WM message was unnecessary. I could have simply called the PaintTabBg Sub

    Code:
        CASE %WM_ERASEBKGND
          CALL PaintTabBg(%IDC_SYSTABCONTROL32_1,wParam,192,224,192)
    '        hDC=wParam  ' DC passed to this message from Beginpaint in wParam
    '        r = 192
    '        SHIFT LEFT r, 8
    '        g = 224
    '        SHIFT LEFT g, 8
    '        b = 192
    '        SHIFT LEFT b, 8
    '        w = 255
    '        SHIFT LEFT w, 8
    '        GetClientRect hWnd, rc
    '        Xin = rc.nRight - rc.nLeft-2            ' don't want to go all the way to the right, or we'll paint over the border
    '        Yin = rc.nBottom - rc.nTop-2            ' don't want to go all the way to the bottom, or we'll paint over the border
    '        vert(0).x      = 2                      ' start at pixel 2 so we don't paint over the border
    '        vert(0).y      = 22                     ' start at pixel 22 so that we don't paint over the tabs
    '        vert(0).Red    = w
    '        vert(0).Green  = w
    '        vert(0).Blue   = w
    '        vert(0).Alpha  = &h0000
    '        vert(1).x      = Xin
    '        vert(1).y      = Yin
    '        vert(1).Red    = r
    '        vert(1).Green  = g
    '        vert(1).Blue   = b
    '        vert(1).Alpha  = &h0000
    '        gRect.UpperLeft  = 0
    '        gRect.LowerRight = 1
    '        GradientFill hDc, vert(0), 2, gRect, 1, %GRADIENT_FILL_RECT_v
            FUNCTION=%TRUE
            EXIT FUNCTION         ' must not let original window procedure get this message
    The win32.hlp file I have is somewhat cryptic, in that it assumes a level and depth of knowledge I don't have yet. What is/are your favorite book(s) on the subject if I may ask.

    Learned a lot.

    Thanks,

    Bob Mechler
    Last edited by BOB MECHLER; 26 Jan 2008, 10:36 AM. Reason: More info

    Leave a comment:


  • Chris Boss
    replied
    Good try, but some serious errors.

    When you process messages in a subclass routine always read the API docs about that message to fully understand how that message works.

    The WM_ERASEBKGND messages passes the DC in wParam. You weren't using it (your code never set the value of hDC so it ended up drawing on the desktop I think). Also use the hWnd parameter passed to the subclass function.

    Next, when you process a message, instead of letting Windows handle it, in a subclass routine, don't forget to not only set the return value but also use:

    EXIT FUNCTION

    so the message is not passed on to the original window procedure call. If you don't then the message gets processed twice, once in your subclass routine and then again by the original window procedure (not good!).

    There is no need to track the WM_MOVE message of the dialog, since Windows will generate the WM_ERASEBKGND message when needed. WM_ERASEBKGND is generated by the BeginPaint function used in WM_PAINT, so whenever WM_PAINT is generated, so will WM_ERASEBKGND.

    Here is your code reworked. I removed the WM_MOVE processing and fixed your subclass routine.

    Code:
    #PBFORMS CREATED V1.50
    '------------------------------------------------------------------------------
    ' The first line in this file is a PB/Forms metastatement.
    ' It should ALWAYS be the first line of the file. Other
    ' PB/Forms metastatements are placed at the beginning and
    ' end of "Named Blocks" of code that should be edited
    ' with PBForms only. Do not manually edit or delete these
    ' metastatements or PB/Forms will not be able to reread
    ' the file correctly.  See the PB/Forms documentation for
    ' more information.
    ' Named blocks begin like this:    #PBFORMS BEGIN ...
    ' Named blocks end like this:      #PBFORMS END ...
    ' Other PB/Forms metastatements such as:
    '     #PBFORMS DECLARATIONS
    ' are used by PB/Forms to insert additional code.
    ' Feel free to make changes anywhere else in the file.
    '------------------------------------------------------------------------------
    #COMPILE EXE
    #DIM ALL
    '------------------------------------------------------------------------------
    '   ** Includes **
    '------------------------------------------------------------------------------
    #PBFORMS BEGIN INCLUDES
    %USEMACROS = 1
    #IF NOT %DEF(%WINAPI)
        #INCLUDE "WIN32API.INC"
    #ENDIF
    #IF NOT %DEF(%COMMCTRL_INC)
        #INCLUDE "COMMCTRL.INC"
    #ENDIF
    #INCLUDE "PBForms.INC"
    #PBFORMS END INCLUDES
    '------------------------------------------------------------------------------
    '------------------------------------------------------------------------------
    '   ** Constants **
    '------------------------------------------------------------------------------
    #PBFORMS BEGIN CONSTANTS
    %IDD_DIALOG1           =  101
    %IDC_SYSTABCONTROL32_1 = 1001
    #PBFORMS END CONSTANTS
    '------------------------------------------------------------------------------
    '------------------------------------------------------------------------------
    '   ** Declarations **
    '------------------------------------------------------------------------------
    DECLARE CALLBACK FUNCTION ShowDIALOG1Proc()
    DECLARE FUNCTION SampleTabCtrl(BYVAL hDlg AS DWORD, BYVAL lID AS LONG, BYVAL _
        lCount AS LONG) AS LONG
    DECLARE FUNCTION ShowDIALOG1(BYVAL hParent AS DWORD) AS LONG
    #PBFORMS DECLARATIONS
    '------------------------------------------------------------------------------
    '------------------------------------------------------------------------------
    '   ** Main Application Entry Point **
    '------------------------------------------------------------------------------
    GLOBAL hdlg AS LONG,NEED_REDRAW AS INTEGER
    FUNCTION PBMAIN()
        PBFormsInitComCtls (%ICC_WIN95_CLASSES OR %ICC_DATE_CLASSES OR _
            %ICC_INTERNET_CLASSES)
        ShowDIALOG1 %HWND_DESKTOP
    END FUNCTION
    '------------------------------------------------------------------------------
    '====================================================================
    FUNCTION Tab1SubClassProc(BYVAL hWnd AS DWORD, BYVAL wMsg AS DWORD, _
                          BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
    '--------------------------------------------------------------------
      ' SubClass procedure
      '------------------------------------------------------------------
      LOCAL lRes AS DWORD, oldProc AS DWORD
      LOCAL lDisPtr AS DRAWITEMSTRUCT PTR
      LOCAL r AS LONG, g AS LONG, b AS LONG, w AS LONG, hDc AS LONG
      LOCAL hCtl&
      LOCAL rc AS Rect
      LOCAL Xin AS LONG
      LOCAL Yin AS LONG
      DIM vert(1) AS TRIVERTEX
      DIM gRect AS GRADIENT_RECT
      '------------------------------------------------------------------
      ' Messages shall normally be passed on to the original procedure
      ' with CallWindowProc for processing, which is why we stored the
      ' return value from SetWindowLong in the dialog's USER memory.
      ' However, it is perfectly ok to break some messages by not
      ' passing them on to the original procedure - see below.
      ' We'll use the GetParent API call to get parent dialog's handle.
      '------------------------------------------------------------------
      DIALOG GET USER GetParent(hWnd), 1 TO oldProc
      IF oldProc = 0 THEN EXIT FUNCTION
      '------------------------------------------------------------------
      SELECT CASE AS LONG wMsg
      '------------------------------------------------------------------
        CASE %WM_ERASEBKGND
            hDC=wParam  ' DC passed to this message from Beginpaint in wParam
            r = 192
            SHIFT LEFT r, 8
            g = 224
            SHIFT LEFT g, 8
            b = 192
            SHIFT LEFT b, 8
            w = 255
            SHIFT LEFT w, 8
            GetClientRect hWnd, rc
            Xin = rc.nRight - rc.nLeft-2            ' don't want to go all the way to the right, or we'll paint over the border
            Yin = rc.nBottom - rc.nTop-2            ' don't want to go all the way to the bottom, or we'll paint over the border
            vert(0).x      = 2                      ' start at pixel 2 so we don't paint over the border
            vert(0).y      = 22                     ' start at pixel 22 so that we don't paint over the tabs
            vert(0).Red    = w
            vert(0).Green  = w
            vert(0).Blue   = w
            vert(0).Alpha  = &h0000
            vert(1).x      = Xin
            vert(1).y      = Yin
            vert(1).Red    = r
            vert(1).Green  = g
            vert(1).Blue   = b
            vert(1).Alpha  = &h0000
            gRect.UpperLeft  = 0
            gRect.LowerRight = 1
            GradientFill hDc, vert(0), 2, gRect, 1, %GRADIENT_FILL_RECT_v
            FUNCTION=%TRUE
            EXIT FUNCTION         ' must not let original window procedure get this message
      '------------------------------------------------------------------
      ' Pass on messages to original control procedure
      END SELECT
      FUNCTION = CallWindowProc(oldProc, hWnd, wMsg, wParam, lParam)
    END FUNCTION
    '------------------------------------------------------------------------------
    '   ** CallBacks **
    '------------------------------------------------------------------------------
    CALLBACK FUNCTION ShowDIALOG1Proc()
      LOCAL lDisPtr AS DRAWITEMSTRUCT PTR
      LOCAL ps AS PAINTSTRUCT
      LOCAL  pNMHDR AS NMHDR PTR
      LOCAL result AS LONG,hTab AS LONG,Rc AS RECT,hpen AS LONG,CurrentItemId AS LONG
      LOCAL hDC AS DWORD,I AS INTEGER
      LOCAL hEdit AS DWORD, oldProc AS DWORD, sText AS STRING
        SELECT CASE AS LONG CBMSG
            CASE %WM_INITDIALOG
              CONTROL HANDLE CBHNDL, %IDC_SYSTABCONTROL32_1 TO hEdit
              oldProc = SetWindowLong(hEdit, %GWL_WNDPROC, CODEPTR(Tab1SubClassProc))
              DIALOG SET USER CBHNDL, 1, oldProc
            CASE %WM_DESTROY
              DIALOG GET USER CBHNDL, 1 TO oldProc
              IF oldProc THEN  ' remove subclassing before exit
                  CONTROL HANDLE CBHNDL, %IDC_SYSTABCONTROL32_1 TO hEdit
                  SetWindowLong hEdit, %GWL_WNDPROC, oldProc
              END IF
            CASE %WM_PAINT
              CALL PaintBg(CBHNDL,192,224,192)
            CASE %WM_DRAWITEM
              IF CBCTL = %IDC_SYSTABCONTROL32_1 THEN
                lDisPtr = CBLPARAM
                IF @lDisPtr.CtlType <> %ODT_TAB THEN EXIT FUNCTION  ' make sure it's a tab
                IF @lDisPtr.itemAction = %ODA_DRAWENTIRE THEN CALL PaintTabBg(CBCTL,@lDisPtr.hdc,192,224,192)
                SELECT CASE @lDisPtr.ItemId
                  CASE 0
                    CALL TabLabel(@lDisPtr.ItemId,CBCTL,@lDisPtr.hdc,@lDisPtr.ItemState,"Account Info 1")
                  CASE 1
                    CALL TabLabel(1,CBCTL,@lDisPtr.hdc,@lDisPtr.ItemState,"Account Info 2")
                  CASE 2
                    CALL TabLabel(2,CBCTL,@lDisPtr.hdc,@lDisPtr.ItemState,"Related Parties      ")
                  CASE 3
                    CALL TabLabel(3,CBCTL,@lDisPtr.hdc,@lDisPtr.ItemState,"Recurring Payments   ")
                  CASE 4
                    CALL TabLabel(4,CBCTL,@lDisPtr.hdc,@lDisPtr.ItemState,"Ticklers             ")
                END SELECT
                FUNCTION = %True
              END IF
            CASE %WM_NOTIFY
              ' Handle Notify messages for tooptips and tab page changes
              pNMHDR = CBLPARAM
              ' Is it a page change message?
              IF @pNMHDR.hWndFrom = GetDlgItem(CBHNDL, %IDC_SYSTABCONTROL32_1) THEN
                  ' Get the current tab page number (zero based)
                  CONTROL SEND CBHNDL, %IDC_SYSTABCONTROL32_1, %TCM_GETCURSEL, 0, 0 TO Result
                  SELECT CASE @pNMHDR.Code
                     CASE %TCN_SELCHANGING ' The page is about to change
                       ' Code to hide any fields on the tab that is about to be moved away from
                          FUNCTION = 0
                      CASE %TCN_SELCHANGE   ' The page is changing
                          ' Code to show any fields on the tab that is about to be moved to
                          FUNCTION = 0
                  END SELECT
              END IF
            CASE %WM_NCACTIVATE
                STATIC hWndSaveFocus AS DWORD
                IF ISFALSE CBWPARAM THEN
                    ' Save control focus
                    hWndSaveFocus = GetFocus()
                ELSEIF hWndSaveFocus THEN
                    ' Restore control focus
                    SetFocus(hWndSaveFocus)
                    hWndSaveFocus = 0
                END IF
            CASE %WM_COMMAND
                ' Process control notifications
                SELECT CASE AS LONG CBCTL
                    CASE %IDC_SYSTABCONTROL32_1
                END SELECT
        END SELECT
    END FUNCTION
    '------------------------------------------------------------------------------
    '------------------------------------------------------------------------------
    '   ** Sample Code **
    '------------------------------------------------------------------------------
    FUNCTION SampleTabCtrl(BYVAL hDlg AS DWORD, BYVAL lID AS LONG, BYVAL lCount _
        AS LONG) AS LONG
        LOCAL i        AS LONG
        LOCAL hCtl     AS DWORD
        LOCAL szBuf    AS ASCIIZ * 32
        LOCAL tTC_Item AS TC_ITEM
        CONTROL HANDLE hDlg, lID TO hCtl
        tTC_Item.Mask    = %TCIF_TEXT
        tTC_Item.iImage  = -1
        tTC_Item.pszText = VARPTR(szBuf)
        szBuf = "Account Info Screen 1"
        TabCtrl_InsertItem(hCtl, 0, tTC_Item)
        szBuf = "Account Info Screen 2 "
        TabCtrl_InsertItem(hCtl, 1, tTC_Item)
        szBuf = "Related Parties       "
        TabCtrl_InsertItem(hCtl, 2, tTC_Item)
        szBuf = "Recurring Payments    "
        TabCtrl_InsertItem(hCtl, 3, tTC_Item)
        szBuf = "Ticklers              "
        TabCtrl_InsertItem(hCtl, 4, tTC_Item)
    END FUNCTION
    '------------------------------------------------------------------------------
    '------------------------------------------------------------------------------
    '   ** Dialogs **
    '------------------------------------------------------------------------------
    FUNCTION ShowDIALOG1(BYVAL hParent AS DWORD) AS LONG
        LOCAL lRslt AS LONG
    #PBFORMS BEGIN DIALOG %IDD_DIALOG1->->
        DIALOG NEW  hParent, "Tab Test", 73, 82, 521, 354, %WS_POPUP OR _
            %WS_BORDER OR %WS_DLGFRAME OR %WS_SYSMENU OR %WS_MINIMIZEBOX OR _
            %WS_MAXIMIZEBOX OR %WS_CLIPSIBLINGS OR %WS_VISIBLE OR %DS_MODALFRAME _
            OR %DS_3DLOOK OR %DS_NOFAILCREATE OR %DS_SETFONT, %WS_EX_WINDOWEDGE _
            OR %WS_EX_CONTROLPARENT OR %WS_EX_LEFT OR %WS_EX_LTRREADING OR _
            %WS_EX_RIGHTSCROLLBAR, TO hDlg
        CONTROL ADD "SysTabControl32", hDlg, %IDC_SYSTABCONTROL32_1, _
            "SysTabControl32_1", 50, 20, 373, 300, %WS_CHILD OR %WS_VISIBLE OR _
            %WS_TABSTOP OR %TCS_SINGLELINE OR %TCS_RIGHTJUSTIFY OR %TCS_OWNERDRAWFIXED, %WS_EX_LEFT OR _
            %WS_EX_LTRREADING
    #PBFORMS END DIALOG
        SampleTabCtrl  hDlg, %IDC_SYSTABCONTROL32_1, 5
        DIALOG SHOW MODAL hDlg, CALL ShowDIALOG1Proc TO lRslt
    #PBFORMS BEGIN CLEANUP %IDD_DIALOG1
    #PBFORMS END CLEANUP
        FUNCTION = lRslt
    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 PaintBg(BYVAL hDialog AS LONG, BYVAL r AS LONG, BYVAL g AS LONG, BYVAL b AS LONG)
         ' this is to paint the background of the dialog
         ' it's all straight out of the MSDN help file.  We can change the values
         ' if we like.
         LOCAL ps AS PAINTSTRUCT
         LOCAL rc AS Rect
         LOCAL hDc AS DWORD
         LOCAL Xin&
         LOCAL Yin&
         DIM vert(1) AS TRIVERTEX
         DIM gRect AS GRADIENT_RECT
         hDC = BeginPaint(hDialog, ps)
           ' Tile the background
         GetClientRect hdialog, rc
         Xin = rc.nRight - rc.nLeft
         Yin = rc.nBottom - rc.nTop
         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
         vert(1).Red    = SetColor(&hff)
         vert(1).Green  = SetColor(&hff)
         vert(1).Blue   = SetColor(&hff)
         vert(1).Alpha  = &h0000
         gRect.UpperLeft  = 0
         gRect.LowerRight = 1
         GradientFill hDc, vert(0), 2, gRect, 1, %GRADIENT_FILL_RECT_v
         EndPaint hDialog, ps
    END SUB
    SUB PaintTabBg(BYVAL cid 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 hCtl&
         LOCAL rc AS Rect
         LOCAL Xin AS LONG
         LOCAL Yin AS LONG
         DIM vert(1) AS TRIVERTEX
         DIM gRect AS GRADIENT_RECT
         CONTROL HANDLE hdlg&, cid& TO hCtl&     ' get the handle to the control
         GetClientRect hCtl, rc
         Xin = rc.nRight - rc.nLeft-2            ' don't want to go all the way to the right, or we'll paint over the border
         Yin = rc.nBottom - rc.nTop-2            ' don't want to go all the way to the bottom, or we'll paint over the border
         vert(0).x      = 2                      ' start at pixel 2 so we don't paint over the border
         vert(0).y      = 22                     ' start at pixel 22 so that we don't paint over the tabs
         vert(0).Red    = SetColor(255)
         vert(0).Green  = SetColor(255)
         vert(0).Blue   = SetColor(255)
         vert(0).Alpha  = &h0000
         vert(1).x      = Xin
         vert(1).y      = Yin
         vert(1).Red    = SetColor(r)
         vert(1).Green  = SetColor(g)
         vert(1).Blue   = SetColor(b)
         vert(1).Alpha  = &h0000
         gRect.UpperLeft  = 0
         gRect.LowerRight = 1
         GradientFill hDc, vert(0), 2, gRect, 1, %GRADIENT_FILL_RECT_v
    END SUB
    SUB TabLabel(BYVAL ItemId AS LONG, BYVAL cid AS LONG,BYVAL hdc AS LONG,BYVAL Selected AS LONG, BYVAL Txt$)
        LOCAL htab&
         LOCAL rc AS Rect
         LOCAL clr&
         LOCAL lZStr  AS ASCIIZ * 64
         LOCAL hFont&
         DIM vert(1) AS TRIVERTEX
         DIM gRect AS GRADIENT_RECT
        CONTROL HANDLE hdlg&, cid& TO hTab&                ' get the control's handle
        CALL TabCtrl_GetItemRect(hTab&, ItemId, rc)         ' get the rectangle to each item (tab label)
        clr& = 224                                          ' set default color
        IF selected& = %ODS_SELECTED THEN clr& = &hdf       ' if it's selected then change it
         vert(0).x      = rc.nLeft
         vert(0).y      = rc.nTop
         vert(0).Red    = SetColor(&hff)
         vert(0).Green  = SetColor(&hff)
         vert(0).Blue   = SetColor(&hff)
         vert(0).Alpha  = &h0000
         vert(1).x      = rc.nRight
         vert(1).y      = rc.nBottom
         vert(1).Red    = SetColor(clr&)
         vert(1).Green  = SetColor(clr&)
         vert(1).Blue   = SetColor(clr&)
         vert(1).Alpha  = &h0000
         gRect.UpperLeft  = 0
         gRect.LowerRight = 1
         GradientFill hDc, vert(0), 2, gRect, 1, %GRADIENT_FILL_RECT_v
        IF Selected = %ODS_SELECTED THEN
            '*Use a bold font if selected
            hFont = CreateFont(-8,0,0,0,%FW_BOLD,0,0,0,0,0,0,0,0,"MS Sans Serif")
        ELSE
            '*Or a normal one if not selected
            hFont = CreateFont(-8,0,0,0,%FW_NORMAL,0,0,0,0,0,0,0,0,"MS Sans Serif")
        END IF
        hFont = SelectObject(hDC,hFont)         ' get the font
        lZstr = txt$                            ' copy the text to the nul terminated string
         SetBkMode hDc, %Transparent             ' set the bg for transparent
         SetTextColor hDc, GetSysColor(%COLOR_BTNTEXT)   ' set the foreground color to black
         TextOut hDc, rc.nLeft + 5, Rc.nTop + 3, lZStr, LEN (lZStr)  'draw the text
         CALL DeleteObject(SelectObject(hdc,hFont))      ' free the font handle
    END SUB
    '------------------------------------------------------------------------------

    Leave a comment:


  • BOB MECHLER
    replied
    I rewrote in using PBForms and tried to follow Chris's suggestion. What I came up with works but feel it might be improved. By subclassing the Tab Control and processing the WM_ERASEBKGND, I got it to redraw continuosly. Then I put in a global toggle variable based on %WM_MOVE in the main dialog callback. Don't know if it is the right way but it works so far.

    Code:
    #PBFORMS CREATED V1.50
    '------------------------------------------------------------------------------
    ' The first line in this file is a PB/Forms metastatement.
    ' It should ALWAYS be the first line of the file. Other   
    ' PB/Forms metastatements are placed at the beginning and 
    ' end of "Named Blocks" of code that should be edited     
    ' with PBForms only. Do not manually edit or delete these 
    ' metastatements or PB/Forms will not be able to reread   
    ' the file correctly.  See the PB/Forms documentation for 
    ' more information.                                       
    ' Named blocks begin like this:    #PBFORMS BEGIN ...     
    ' Named blocks end like this:      #PBFORMS END ...       
    ' Other PB/Forms metastatements such as:                  
    '     #PBFORMS DECLARATIONS                               
    ' are used by PB/Forms to insert additional code.         
    ' Feel free to make changes anywhere else in the file.    
    '------------------------------------------------------------------------------
    
    #COMPILE EXE
    #DIM ALL
    
    '------------------------------------------------------------------------------
    '   ** Includes **
    '------------------------------------------------------------------------------
    #PBFORMS BEGIN INCLUDES 
    %USEMACROS = 1
    #IF NOT %DEF(%WINAPI)
        #INCLUDE "WIN32API.INC"
    #ENDIF
    #IF NOT %DEF(%COMMCTRL_INC)
        #INCLUDE "COMMCTRL.INC"
    #ENDIF
    #INCLUDE "PBForms.INC"
    #PBFORMS END INCLUDES
    '------------------------------------------------------------------------------
    
    '------------------------------------------------------------------------------
    '   ** Constants **
    '------------------------------------------------------------------------------
    #PBFORMS BEGIN CONSTANTS 
    %IDD_DIALOG1           =  101
    %IDC_SYSTABCONTROL32_1 = 1001
    #PBFORMS END CONSTANTS
    '------------------------------------------------------------------------------
    
    '------------------------------------------------------------------------------
    '   ** Declarations **
    '------------------------------------------------------------------------------
    DECLARE CALLBACK FUNCTION ShowDIALOG1Proc()
    DECLARE FUNCTION SampleTabCtrl(BYVAL hDlg AS DWORD, BYVAL lID AS LONG, BYVAL _
        lCount AS LONG) AS LONG
    DECLARE FUNCTION ShowDIALOG1(BYVAL hParent AS DWORD) AS LONG
    #PBFORMS DECLARATIONS
    '------------------------------------------------------------------------------
    
    '------------------------------------------------------------------------------
    '   ** Main Application Entry Point **
    '------------------------------------------------------------------------------
    GLOBAL hdlg AS LONG,NEED_REDRAW AS INTEGER
    FUNCTION PBMAIN()
        PBFormsInitComCtls (%ICC_WIN95_CLASSES OR %ICC_DATE_CLASSES OR _
            %ICC_INTERNET_CLASSES)
    
        ShowDIALOG1 %HWND_DESKTOP
    END FUNCTION
    '------------------------------------------------------------------------------
    
    '====================================================================
    FUNCTION Tab1SubClassProc(BYVAL hWnd AS DWORD, BYVAL wMsg AS DWORD, _
                          BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
    '--------------------------------------------------------------------
      ' SubClass procedure
      '------------------------------------------------------------------
      LOCAL lRes AS DWORD, oldProc AS DWORD
      LOCAL lDisPtr AS DRAWITEMSTRUCT PTR
      LOCAL r AS LONG, g AS LONG, b AS LONG, w AS LONG, hDc AS LONG
      LOCAL hCtl&
      LOCAL rc AS Rect
      LOCAL Xin AS LONG
      LOCAL Yin AS LONG
      DIM vert(1) AS TRIVERTEX
      DIM gRect AS GRADIENT_RECT
      '------------------------------------------------------------------
      ' Messages shall normally be passed on to the original procedure
      ' with CallWindowProc for processing, which is why we stored the
      ' return value from SetWindowLong in the dialog's USER memory.
      ' However, it is perfectly ok to break some messages by not
      ' passing them on to the original procedure - see below.
      ' We'll use the GetParent API call to get parent dialog's handle.
      '------------------------------------------------------------------
      DIALOG GET USER GetParent(hWnd), 1 TO oldProc
      IF oldProc = 0 THEN EXIT FUNCTION
      '------------------------------------------------------------------
      SELECT CASE AS LONG wMsg
      '------------------------------------------------------------------
        CASE %WM_ERASEBKGND
          'this paints the actual TAB body
          IF NEED_REDRAW THEN
            CONTROL HANDLE hdlg&, %IDC_SYSTABCONTROL32_1 TO hCtl&     ' get the handle to the control
            RedrawWindow hCtl&, BYVAL 0, 0, %RDW_ERASE OR %RDW_INVALIDATE
            r = 192
            SHIFT LEFT r, 8
            g = 224
            SHIFT LEFT g, 8
            b = 192
            SHIFT LEFT b, 8
            w = 255
            SHIFT LEFT w, 8
            GetClientRect hCtl, rc
            Xin = rc.nRight - rc.nLeft-2            ' don't want to go all the way to the right, or we'll paint over the border
            Yin = rc.nBottom - rc.nTop-2            ' don't want to go all the way to the bottom, or we'll paint over the border
            vert(0).x      = 2                      ' start at pixel 2 so we don't paint over the border
            vert(0).y      = 22                     ' start at pixel 22 so that we don't paint over the tabs
            vert(0).Red    = w
            vert(0).Green  = w
            vert(0).Blue   = w
            vert(0).Alpha  = &h0000
            vert(1).x      = Xin
            vert(1).y      = Yin
            vert(1).Red    = r
            vert(1).Green  = g
            vert(1).Blue   = b
            vert(1).Alpha  = &h0000
            gRect.UpperLeft  = 0
            gRect.LowerRight = 1
            GradientFill hDc, vert(0), 2, gRect, 1, %GRADIENT_FILL_RECT_v 
            FUNCTION=%TRUE
            NEED_REDRAW = 0
          END IF
      '------------------------------------------------------------------
      ' Pass on messages to original control procedure
      END SELECT
      FUNCTION = CallWindowProc(oldProc, hWnd, wMsg, wParam, lParam)
    
    END FUNCTION
    '------------------------------------------------------------------------------
    '   ** CallBacks **
    '------------------------------------------------------------------------------
    CALLBACK FUNCTION ShowDIALOG1Proc()
      LOCAL lDisPtr AS DRAWITEMSTRUCT PTR
      LOCAL ps AS PAINTSTRUCT
      LOCAL  pNMHDR AS NMHDR PTR
      LOCAL result AS LONG,hTab AS LONG,Rc AS RECT,hpen AS LONG,CurrentItemId AS LONG
      LOCAL hDC AS DWORD,I AS INTEGER
      LOCAL hEdit AS DWORD, oldProc AS DWORD, sText AS STRING
    
        SELECT CASE AS LONG CBMSG
            CASE %WM_INITDIALOG
              CONTROL HANDLE CBHNDL, %IDC_SYSTABCONTROL32_1 TO hEdit
              oldProc = SetWindowLong(hEdit, %GWL_WNDPROC, CODEPTR(Tab1SubClassProc))
              DIALOG SET USER CBHNDL, 1, oldProc
            CASE %WM_DESTROY
              DIALOG GET USER CBHNDL, 1 TO oldProc
              IF oldProc THEN  ' remove subclassing before exit
                  CONTROL HANDLE CBHNDL, %IDC_SYSTABCONTROL32_1 TO hEdit
                  SetWindowLong hEdit, %GWL_WNDPROC, oldProc
              END IF
            CASE %WM_PAINT
              CALL PaintBg(CBHNDL,192,224,192)         
            CASE %WM_DRAWITEM
              IF CBCTL = %IDC_SYSTABCONTROL32_1 THEN
                lDisPtr = CBLPARAM
                IF @lDisPtr.CtlType <> %ODT_TAB THEN EXIT FUNCTION  ' make sure it's a tab
                IF @lDisPtr.itemAction = %ODA_DRAWENTIRE THEN CALL PaintTabBg(CBCTL,@lDisPtr.hdc,192,224,192)
                SELECT CASE @lDisPtr.ItemId
                  CASE 0 
                    CALL TabLabel(@lDisPtr.ItemId,CBCTL,@lDisPtr.hdc,@lDisPtr.ItemState,"Account Info 1")
                  CASE 1 
                    CALL TabLabel(1,CBCTL,@lDisPtr.hdc,@lDisPtr.ItemState,"Account Info 2")
                  CASE 2 
                    CALL TabLabel(2,CBCTL,@lDisPtr.hdc,@lDisPtr.ItemState,"Related Parties      ")
                  CASE 3 
                    CALL TabLabel(3,CBCTL,@lDisPtr.hdc,@lDisPtr.ItemState,"Recurring Payments   ")
                  CASE 4 
                    CALL TabLabel(4,CBCTL,@lDisPtr.hdc,@lDisPtr.ItemState,"Ticklers             ")
                END SELECT    
                FUNCTION = %True
              END IF
            CASE %WM_NOTIFY
              ' Handle Notify messages for tooptips and tab page changes
              pNMHDR = CBLPARAM
              ' Is it a page change message?
              IF @pNMHDR.hWndFrom = GetDlgItem(CBHNDL, %IDC_SYSTABCONTROL32_1) THEN
        
                  ' Get the current tab page number (zero based)
                  CONTROL SEND CBHNDL, %IDC_SYSTABCONTROL32_1, %TCM_GETCURSEL, 0, 0 TO Result
                  SELECT CASE @pNMHDR.Code
                     CASE %TCN_SELCHANGING ' The page is about to change
                       ' Code to hide any fields on the tab that is about to be moved away from
                          FUNCTION = 0
                      CASE %TCN_SELCHANGE   ' The page is changing
                          ' Code to show any fields on the tab that is about to be moved to
                          FUNCTION = 0
                  END SELECT
              END IF 
            CASE %WM_MOVE
              NEED_REDRAW = -1  
            CASE %WM_NCACTIVATE
                STATIC hWndSaveFocus AS DWORD
                IF ISFALSE CBWPARAM THEN
                    ' Save control focus
                    hWndSaveFocus = GetFocus()
                ELSEIF hWndSaveFocus THEN
                    ' Restore control focus
                    SetFocus(hWndSaveFocus)
                    hWndSaveFocus = 0
                END IF
    
            CASE %WM_COMMAND
                ' Process control notifications
                SELECT CASE AS LONG CBCTL
                    CASE %IDC_SYSTABCONTROL32_1
    
                END SELECT
        END SELECT
    END FUNCTION
    '------------------------------------------------------------------------------
    
    '------------------------------------------------------------------------------
    '   ** Sample Code **
    '------------------------------------------------------------------------------
    FUNCTION SampleTabCtrl(BYVAL hDlg AS DWORD, BYVAL lID AS LONG, BYVAL lCount _
        AS LONG) AS LONG
        LOCAL i        AS LONG
        LOCAL hCtl     AS DWORD
        LOCAL szBuf    AS ASCIIZ * 32
        LOCAL tTC_Item AS TC_ITEM
    
        CONTROL HANDLE hDlg, lID TO hCtl
    
        tTC_Item.Mask    = %TCIF_TEXT
        tTC_Item.iImage  = -1
        tTC_Item.pszText = VARPTR(szBuf)
        szBuf = "Account Info Screen 1"
        TabCtrl_InsertItem(hCtl, 0, tTC_Item)
        szBuf = "Account Info Screen 2 "
        TabCtrl_InsertItem(hCtl, 1, tTC_Item)
        szBuf = "Related Parties       "
        TabCtrl_InsertItem(hCtl, 2, tTC_Item)
        szBuf = "Recurring Payments    "
        TabCtrl_InsertItem(hCtl, 3, tTC_Item)
        szBuf = "Ticklers              "
        TabCtrl_InsertItem(hCtl, 4, tTC_Item)
        
    END FUNCTION
    '------------------------------------------------------------------------------
    
    '------------------------------------------------------------------------------
    '   ** Dialogs **
    '------------------------------------------------------------------------------
    FUNCTION ShowDIALOG1(BYVAL hParent AS DWORD) AS LONG
        LOCAL lRslt AS LONG
    
    #PBFORMS BEGIN DIALOG %IDD_DIALOG1->->
    
        DIALOG NEW  hParent, "Tab Test", 73, 82, 521, 354, %WS_POPUP OR _
            %WS_BORDER OR %WS_DLGFRAME OR %WS_SYSMENU OR %WS_MINIMIZEBOX OR _
            %WS_MAXIMIZEBOX OR %WS_CLIPSIBLINGS OR %WS_VISIBLE OR %DS_MODALFRAME _
            OR %DS_3DLOOK OR %DS_NOFAILCREATE OR %DS_SETFONT, %WS_EX_WINDOWEDGE _
            OR %WS_EX_CONTROLPARENT OR %WS_EX_LEFT OR %WS_EX_LTRREADING OR _
            %WS_EX_RIGHTSCROLLBAR, TO hDlg
        CONTROL ADD "SysTabControl32", hDlg, %IDC_SYSTABCONTROL32_1, _
            "SysTabControl32_1", 50, 20, 373, 300, %WS_CHILD OR %WS_VISIBLE OR _
            %WS_TABSTOP OR %TCS_SINGLELINE OR %TCS_RIGHTJUSTIFY OR %TCS_OWNERDRAWFIXED, %WS_EX_LEFT OR _
            %WS_EX_LTRREADING
    #PBFORMS END DIALOG
    
        SampleTabCtrl  hDlg, %IDC_SYSTABCONTROL32_1, 5
    
        DIALOG SHOW MODAL hDlg, CALL ShowDIALOG1Proc TO lRslt
    
    #PBFORMS BEGIN CLEANUP %IDD_DIALOG1
    #PBFORMS END CLEANUP
    
        FUNCTION = lRslt
    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 PaintBg(BYVAL hDialog AS LONG, BYVAL r AS LONG, BYVAL g AS LONG, BYVAL b AS LONG)
    
         ' this is to paint the background of the dialog
         ' it's all straight out of the MSDN help file.  We can change the values
         ' if we like.
         LOCAL ps AS PAINTSTRUCT
         LOCAL rc AS Rect
         LOCAL hDc AS DWORD
         LOCAL Xin&
         LOCAL Yin&
         DIM vert(1) AS TRIVERTEX
         DIM gRect AS GRADIENT_RECT
         hDC = BeginPaint(hDialog, ps)
           ' Tile the background
         GetClientRect hdialog, rc
         Xin = rc.nRight - rc.nLeft
         Yin = rc.nBottom - rc.nTop
    
         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
         vert(1).Red    = SetColor(&hff)
         vert(1).Green  = SetColor(&hff)
         vert(1).Blue   = SetColor(&hff)
         vert(1).Alpha  = &h0000
         gRect.UpperLeft  = 0
         gRect.LowerRight = 1
         GradientFill hDc, vert(0), 2, gRect, 1, %GRADIENT_FILL_RECT_v
         EndPaint hDialog, ps 
         
    END SUB
    SUB PaintTabBg(BYVAL cid 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 hCtl&
         LOCAL rc AS Rect
         LOCAL Xin AS LONG
         LOCAL Yin AS LONG
         DIM vert(1) AS TRIVERTEX
         DIM gRect AS GRADIENT_RECT
         CONTROL HANDLE hdlg&, cid& TO hCtl&     ' get the handle to the control
         GetClientRect hCtl, rc
         Xin = rc.nRight - rc.nLeft-2            ' don't want to go all the way to the right, or we'll paint over the border
         Yin = rc.nBottom - rc.nTop-2            ' don't want to go all the way to the bottom, or we'll paint over the border
         vert(0).x      = 2                      ' start at pixel 2 so we don't paint over the border
         vert(0).y      = 22                     ' start at pixel 22 so that we don't paint over the tabs
         vert(0).Red    = SetColor(255)
         vert(0).Green  = SetColor(255)
         vert(0).Blue   = SetColor(255)
         vert(0).Alpha  = &h0000
         vert(1).x      = Xin
         vert(1).y      = Yin
         vert(1).Red    = SetColor(r)
         vert(1).Green  = SetColor(g)
         vert(1).Blue   = SetColor(b)
         vert(1).Alpha  = &h0000
         gRect.UpperLeft  = 0
         gRect.LowerRight = 1
         GradientFill hDc, vert(0), 2, gRect, 1, %GRADIENT_FILL_RECT_v 
         
    END SUB
    
    SUB TabLabel(BYVAL ItemId AS LONG, BYVAL cid AS LONG,BYVAL hdc AS LONG,BYVAL Selected AS LONG, BYVAL Txt$)
    
        LOCAL htab&
         LOCAL rc AS Rect
         LOCAL clr&
         LOCAL lZStr  AS ASCIIZ * 64
         LOCAL hFont&
         DIM vert(1) AS TRIVERTEX
         DIM gRect AS GRADIENT_RECT
    
        CONTROL HANDLE hdlg&, cid& TO hTab&                ' get the control's handle
        CALL TabCtrl_GetItemRect(hTab&, ItemId, rc)         ' get the rectangle to each item (tab label) 
        clr& = 224                                          ' set default color
        IF selected& = %ODS_SELECTED THEN clr& = &hdf       ' if it's selected then change it
         vert(0).x      = rc.nLeft
         vert(0).y      = rc.nTop
         vert(0).Red    = SetColor(&hff)
         vert(0).Green  = SetColor(&hff)
         vert(0).Blue   = SetColor(&hff)
         vert(0).Alpha  = &h0000
         vert(1).x      = rc.nRight
         vert(1).y      = rc.nBottom
         vert(1).Red    = SetColor(clr&)
         vert(1).Green  = SetColor(clr&)
         vert(1).Blue   = SetColor(clr&)
         vert(1).Alpha  = &h0000
         gRect.UpperLeft  = 0
         gRect.LowerRight = 1
         GradientFill hDc, vert(0), 2, gRect, 1, %GRADIENT_FILL_RECT_v
    
        IF Selected = %ODS_SELECTED THEN
            '*Use a bold font if selected
            hFont = CreateFont(-8,0,0,0,%FW_BOLD,0,0,0,0,0,0,0,0,"MS Sans Serif")
        ELSE
            '*Or a normal one if not selected
            hFont = CreateFont(-8,0,0,0,%FW_NORMAL,0,0,0,0,0,0,0,0,"MS Sans Serif")
        END IF
        hFont = SelectObject(hDC,hFont)         ' get the font
        lZstr = txt$                            ' copy the text to the nul terminated string
         SetBkMode hDc, %Transparent             ' set the bg for transparent
         SetTextColor hDc, GetSysColor(%COLOR_BTNTEXT)   ' set the foreground color to black
    
         TextOut hDc, rc.nLeft + 5, Rc.nTop + 3, lZStr, LEN (lZStr)  'draw the text
         CALL DeleteObject(SelectObject(hdc,hFont))      ' free the font handle
    END SUB
    
    '------------------------------------------------------------------------------

    Leave a comment:


  • Michael Mattias
    replied
    Then they draw a thin gray line on the right and bottom and a white thin line on the left and top. Really can't distinquish it from the tab body.
    Add WS_BORDER style?

    If not, try WS_EX_STATICEDGE and/or WS_EX_CLIENTEDGE extended style. That should give you your border lines... (Hmm......Border line, Border line, I just keep on movin' my love, Over the border line...... betcha didn't know I am a big Madonna fan, did you?)

    MCM

    Leave a comment:


  • BOB MECHLER
    replied
    I've seen some examples where they just do the tabs and replace the body with a number of additional dialogs. Then they draw a thin gray line on the right and bottom and a white thin line on the left and top. Really can't distinquish it from the tab body.

    Didn't understand why at first but that seems to be a way to avoid the subclassing of the tab body.

    Bob Mechler

    Leave a comment:


  • BOB MECHLER
    replied
    I understand what you're saying. I've only subclassed some textboxes but I'm sure I can find some code around the forum for tab controls.

    Thanks for the additional information too.

    Bob Mechler

    Leave a comment:


  • Chris Boss
    replied
    The answer is simple.

    TAB controls only allow painting the TABs using ownerdraw and not the rest of the control (background).

    You are cheating in your code, by attempting to paint the background during the WM_DRAWITEM message. It works, but the problem is the message is only generated when the TAB's need to be updated. If you move the dialog left or right off the screen and then back again, the tabs need repainting so it appears to work fine. But when you move the dialog off the screen moving downward and then back again, the tabs don't need to be repainted, so the control never generates the WM_DRAWITEM message, so your background painting code never gets called. Windows though does generate the WM_ERASEBKGND message for the Tab control (sent to the Tab controls window procedure) to repaint the background and it gets painted using the default color. Only part of the background needs to be repainted and so only part of it is invalidated, which means Windows repaints only the part that went off screen.

    So how do you paint the ownerdraw tab controls background ?

    Not in WM_DRAWITEM

    You have to subclass the control and then process the WM_ERASEBKGND message and draw it there. The tabs though are painted in WM_DRAWITEM.

    Leave a comment:


  • BOB MECHLER
    started a topic Tab Control and gradient shading problem

    Tab Control and gradient shading problem

    The following compilable program is one test for different ways of ownerdrawing a tab control with gradient's etc. The cool code came from one of Chris Boss's example. The rest is some playing around I'm doing with macros.
    Anyway, it's biggest problem is that if you move it off screen partially and come back the painted area becomes messed up. I need to know how to keep it painted or when to repaint the bod of the tab itself.

    BOB MECHLER
    Code:
    #COMPILE EXE 
    #INCLUDE "WIN32API.INC"
    #INCLUDE "INITCTRL.INC"
    %TAB1           = 1001
    GLOBAL FLD AS LONG 'field number on screen
    GLOBAL LST() AS STRING,lbcursel() AS LONG,cbcursel() AS LONG,VBUT AS INTEGER
    GLOBAL TABHIT AS INTEGER
    GLOBAL hfont1 AS LONG,hfont2 AS LONG
    GLOBAL TabText()    AS ASCIIZ * 32
    GLOBAL hdlg AS LONG
    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 PaintBg(BYVAL hDialog AS LONG, BYVAL r AS LONG, BYVAL g AS LONG, BYVAL b AS LONG)
    
         ' this is to paint the background of the dialog
         ' it's all straight out of the MSDN help file.  We can change the values
         ' if we like.
         LOCAL ps AS PAINTSTRUCT
         LOCAL rc AS Rect
         LOCAL hDc AS DWORD
         LOCAL Xin&
         LOCAL Yin&
         DIM vert(1) AS TRIVERTEX
         DIM gRect AS GRADIENT_RECT
         hDC = BeginPaint(hDialog, ps)
           ' Tile the background
         GetClientRect hdialog, rc
         Xin = rc.nRight - rc.nLeft
         Yin = rc.nBottom - rc.nTop
    
         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
         vert(1).Red    = SetColor(&hff)
         vert(1).Green  = SetColor(&hff)
         vert(1).Blue   = SetColor(&hff)
         vert(1).Alpha  = &h0000
         gRect.UpperLeft  = 0
         gRect.LowerRight = 1
         GradientFill hDc, vert(0), 2, gRect, 1, %GRADIENT_FILL_RECT_v
         EndPaint hDialog, ps 
         
    END SUB
    
    SUB PaintTabBg(BYVAL cid 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 hCtl&
         LOCAL rc AS Rect
         LOCAL Xin AS LONG
         LOCAL Yin AS LONG
         DIM vert(1) AS TRIVERTEX
         DIM gRect AS GRADIENT_RECT
         CONTROL HANDLE hDlg, cid& TO hCtl&     ' get the handle to the control
         GetClientRect hCtl, rc
         Xin = rc.nRight - rc.nLeft-2            ' don't want to go all the way to the right, or we'll paint over the border
         Yin = rc.nBottom - rc.nTop-2            ' don't want to go all the way to the bottom, or we'll paint over the border
         vert(0).x      = 2                      ' start at pixel 2 so we don't paint over the border
         vert(0).y      = 22                     ' start at pixel 22 so that we don't paint over the tabs
         vert(0).Red    = SetColor(255)
         vert(0).Green  = SetColor(255)
         vert(0).Blue   = SetColor(255)
         vert(0).Alpha  = &h0000
         vert(1).x      = Xin
         vert(1).y      = Yin
         vert(1).Red    = SetColor(r)
         vert(1).Green  = SetColor(g)
         vert(1).Blue   = SetColor(b)
         vert(1).Alpha  = &h0000
         gRect.UpperLeft  = 0
         gRect.LowerRight = 1
         GradientFill hDc, vert(0), 2, gRect, 1, %GRADIENT_FILL_RECT_v 
         
    END SUB
    
    SUB TabLabel(BYVAL ItemId AS LONG, BYVAL cid AS LONG,BYVAL hdc AS LONG,BYVAL Selected AS LONG, BYVAL Txt$)
    
        LOCAL htab&
         LOCAL rc AS Rect
         LOCAL clr&
         LOCAL lZStr  AS ASCIIZ * 64
         LOCAL hFont&
         DIM vert(1) AS TRIVERTEX
         DIM gRect AS GRADIENT_RECT
    
        CONTROL HANDLE hdlg&, cid& TO hTab&                ' get the control's handle
        CALL TabCtrl_GetItemRect(hTab&, ItemId, rc)         ' get the rectangle to each item (tab label)
        clr& = 224                                          ' set default color
        IF selected& = %ODS_SELECTED THEN clr& = &hdf       ' if it's selected then change it
         vert(0).x      = rc.nLeft
         vert(0).y      = rc.nTop
         vert(0).Red    = SetColor(&hff)
         vert(0).Green  = SetColor(&hff)
         vert(0).Blue   = SetColor(&hff)
         vert(0).Alpha  = &h0000
         vert(1).x      = rc.nRight
         vert(1).y      = rc.nBottom
         vert(1).Red    = SetColor(clr&)
         vert(1).Green  = SetColor(clr&)
         vert(1).Blue   = SetColor(clr&)
         vert(1).Alpha  = &h0000
         gRect.UpperLeft  = 0
         gRect.LowerRight = 1
         GradientFill hDc, vert(0), 2, gRect, 1, %GRADIENT_FILL_RECT_v
    
        IF Selected = %ODS_SELECTED THEN
            '*Use a bold font if selected
            hFont = CreateFont(-8,0,0,0,%FW_BOLD,0,0,0,0,0,0,0,0,"MS Sans Serif")
        ELSE
            '*Or a normal one if not selected
            hFont = CreateFont(-8,0,0,0,%FW_NORMAL,0,0,0,0,0,0,0,0,"MS Sans Serif")
        END IF
        hFont = SelectObject(hDC,hFont)         ' get the font
        lZstr = txt$                            ' copy the text to the nul terminated string
         SetBkMode hDc, %Transparent             ' set the bg for transparent
         SetTextColor hDc, GetSysColor(%COLOR_BTNTEXT)   ' set the foreground color to black
    
         TextOut hDc, rc.nLeft + 5, Rc.nTop + 3, lZStr, LEN (lZStr)  'draw the text
         CALL DeleteObject(SelectObject(hdc,hFont))      ' free the font handle
    END SUB
    
    CALLBACK FUNCTION hdlgcb AS LONG
      LOCAL lDisPtr AS DRAWITEMSTRUCT PTR
      LOCAL ps AS PAINTSTRUCT
      LOCAL  pNMHDR AS NMHDR PTR
      LOCAL result AS LONG,hTab AS LONG,Rc AS RECT,hpen AS LONG,CurrentItemId AS LONG
      LOCAL hDC AS DWORD,I AS INTEGER
      STATIC hTCBrush    AS LONG  ' Maintain a custom background color brush for Tab Control
      SELECT CASE CBMSG
        CASE %WM_INITDIALOG
          hTCBrush = CreateSolidBrush( RGB(213,234,255))
        CASE %WM_DESTROY
          PostQuitMessage 0
        CASE %WM_PAINT
          IF CBHNDL = hDlg& THEN CALL PaintBg(hDlg&,192,224,192)         
        CASE %WM_DRAWITEM
          IF CBCTL = %TAB1 THEN
            lDisPtr = CBLPARAM
            IF @lDisPtr.CtlType <> %ODT_TAB THEN EXIT FUNCTION  ' make sure it's a tab
            IF @lDisPtr.itemAction = %ODA_DRAWENTIRE THEN CALL PaintTabBg(CBCTL,@lDisPtr.hdc,192,224,192) 
            CALL TabLabel(@lDisPtr.ItemId,CBCTL,@lDisPtr.hdc,@lDisPtr.ItemState,TabText( @lDisPtr.ItemId))
            FUNCTION = %True
          END IF
        CASE %WM_NOTIFY
          ' Handle Notify messages for tooptips and tab page changes
          pNMHDR = CBLPARAM
          ' Is it a page change message?
          IF @pNMHDR.hWndFrom = GetDlgItem(CBHNDL, %TAB1) THEN
    
              ' Get the current tab page number (zero based)
              CONTROL SEND CBHNDL, %TAB1, %TCM_GETCURSEL, 0, 0 TO Result
              SELECT CASE @pNMHDR.Code
                 CASE %TCN_SELCHANGING ' The page is about to change
                   ' Code to hide any fields on the tab that is about to be moved away from
                      FUNCTION = 0
                  CASE %TCN_SELCHANGE   ' The page is changing
                      ' Code to show any fields on the tab that is about to be moved to
                      FUNCTION = 0
              END SELECT
          END IF
        CASE %WM_COMMAND
    
      END SELECT
    END FUNCTION
    
    %MAXTAB = 5
    
    FUNCTION TABCTRL(hDlg AS LONG,Iid AS LONG,W AS LONG,H AS LONG,T AS INTEGER) AS LONG
      LOCAL TI AS TC_ITEM
      LOCAL MessageText AS STRING
      LOCAL x AS INTEGER,hCtl AS LONG
      CONTROL ADD "SysTabControl32", hDlg, Iid, "", 10, 20, _
          W, H,%WS_CHILD OR %WS_VISIBLE OR %TCS_RIGHTJUSTIFY OR %TCS_OWNERDRAWFIXED,0
      ' Add tabs to the control
      TI.Mask = %TCIF_TEXT    ' Text field is valid
      TI.iImage = -1          ' no image
      CONTROL HANDLE hdlg&, Iid TO hCtl&        
      FOR x = 0 TO T - 1
        MessageText = TabText(x)
        TI.pszText = STRPTR(MessageText)
        TabCtrl_InsertItem hCtl&, x, TI
      NEXT
      FUNCTION = 0 'Success
    END FUNCTION
    
    FUNCTION Wind(Cap AS STRING,Wid AS LONG,Hei AS LONG,ShowState AS LONG) AS LONG
      LOCAL SCRXSIZE AS INTEGER
      SCRXSIZE =GetSystemMetrics(%SM_CXSCREEN)
      IF SCRXSIZE < 800 THEN
        DIALOG FONT "Arial Bold",6
      ELSEIF SCRXSIZE = 800 THEN
        DIALOG FONT "Arial Bold",8
      ELSEIF SCRXSIZE = > 800 THEN
        DIALOG FONT "Arial Bold",10
      END IF
      DIALOG NEW 0,Cap,,,Wid ,Hei, %WS_MINIMIZEBOX OR %WS_MAXIMIZEBOX OR %WS_SYSMENU,0 TO hdlg&
      MENU NEW POPUP TO hPopup1&
      MENU ADD STRING, hPopup1&, "&Close", 1001, %MF_ENABLED
      ' Attach the popup menu to the menu bar
      MENU ADD POPUP,  hMenu&,   "&File",  hPopup1&,   %MF_ENABLED
      ' Create a popup menu
      MENU NEW POPUP TO hPopup2&
      MENU ADD STRING, hPopup2&, "Cut   Ctrl+X", 1002,%MF_ENABLED
      MENU ADD STRING, hPopup2&, "Copy  Ctrl+C", 1003,%MF_ENABLED
      MENU ADD STRING, hPopup2&, "Paste Ctrl+P", 1004,%MF_ENABLED
      MENU ADD POPUP,  hMenu&,   "&Edit",  hPopup2&,        %MF_ENABLED
      ' Attach the popup menu to the menu bar
      MENU ATTACH hMenu&, hdlg&
      DIALOG SHOW STATE hDlg&,ShowState
      DIALOG SHOW MODELESS hdlg& CALL hdlgcb
      FUNCTION = hdlg&
    END FUNCTION
    FUNCTION PBMAIN AS LONG
    InitCommonControls
    DIM hDlg AS LONG
    DIM TabText(%MAXTAB) AS GLOBAL ASCIIZ * 32
    'Create window 
    hDlg = Wind("Tab Test",380,300,%SW_SHOW)
    TabText(0) = "Account Info Screen 1"
    TabText(1) = "Account Info Screen 2 "
    TabText(2) = "Related Parties       "
    TabText(3) = "Recurring Payments    "
    TabText(4) = "Ticklers              "
    'Establish tab
    TABCTRL(hDlg,%TAB1,360,240,5)
    'Put initial controls on screen
    'SCRN1
    DO
      DIALOG DOEVENTS TO CNT&
    LOOP UNTIL CNT& = 0
    END FUNCTION
Working...
X