Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

PB/DLL Custom Control Progressbar, gradient style..

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

  • PB/DLL Custom Control Progressbar, gradient style..

    Code:
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    ' Custom control Progressbar include file, PGBAR3D.INC, version 1.1, for PB/DLL
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    ' Public Domain, by Borje Hagsten, Mars 2001
    ' Feel free to use and enhance, but as always - use at own risk..
    ' NOTE: save this file as PGBAR3D.INC in your PBDLL6 include file directory.
    '       See sample program, PGBAR3D.BAS, for tips on how to use it.
    '
    ' UPDATED: (March 12)
    ' Pens are resource eaters - storing them is stupid. Now they are used
    ' and then immediately properly deleted, for "lighter" control..
    ' Added several custom settings, like direction, colors, ability to set text, even
    ' separately for background and bar (neat fade-in/out effect), etc. See below.
    '
    ' COMMENTS:
    ' Control is becoming pretty advanced. Can also be used as label, with possibility to
    ' set separate text on bar/background for "fade in/out" effects. See sample program.
    ' Future plans involve adding different styles and better managing of rotated text.
    ' Currently, only 90, 180 and 270 degrees angle is somewhat handled, for centered text
    ' only. May also add possibility to use images in both background and bar, some day..
    '
    ' Drawing gradients takes time, but by pre-drawing and using double memDC's,
    ' speed became pretty good. Simple test program, PGBAR3D.BAS provided. Should
    ' be enough to see how easy it can be to use it in you code, via InitPGBAR3D
    ' and CONTROL ADD "PGBAR3D", etc. Note - %PGB_BUILDBARS message must always
    ' be used after CONTROL ADD + settings have been made or changed!
    '
    ' Special thanks to Semen Matusovski for his wonderful samples of standard
    ' progressbars, which lead me to this one. Tips from many others in the PB
    ' community have also been of great help. Thanks to you all!
    ' Hope it can be of any use.. :-)
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
     
    #INCLUDE "WIN32API.INC"
     
    'some custom control messages
    %PGB_SETMAX         = %WM_USER + 100 'wParam sets max number of steps
    %PGB_STEPUP         = %WM_USER + 103 'increases step while < max - wParam and lParam shall be 0
    %PGB_STEPDN         = %WM_USER + 104 'decreases step while > 0   - wParam and lParam shall be 0
    %PGB_SETVALUE       = %WM_USER + 105 'wParam sets progessbar value, lParam controls redraw
    %PGB_BUILDBARS      = %WM_USER + 109 'build/rebuild the scrollbars, lParam controls redraw
    %PGB_REFRESH        = %WM_USER + 110 'redraw the control - wParam and lParam shall be 0
     
    %PGB_GETMAX         = %WM_USER + 120 'returns max number of steps
    %PGB_GETVALUE       = %WM_USER + 121 'returns step value
    %PGB_GETTXTON       = %WM_USER + 122 'returns txtOnOff value
    %PGB_GETTXTPOS      = %WM_USER + 123 'returns text position in control
    %PGB_GETTXTCOLBAR   = %WM_USER + 124 'returns bar text color
    %PGB_GETTXTCOLBKG   = %WM_USER + 125 'returns background text color
    %PGB_GETCOLBKG      = %WM_USER + 126 'returns background color
     
    %PGB_SETTXTON       = %WM_USER + 150 'lParam sets: 0 = no text, 1 = auto text (%), 2 = custom text
    %PGB_SETTXTBAR      = %WM_USER + 151 'wParam points to text for bar, lParam controls redraw
    %PGB_SETTXTBKG      = %WM_USER + 152 'wParam points to text for background, lParam controls redraw
    %PGB_SETTXTPOS      = %WM_USER + 153 'wParam sets text position in control
    %PGB_SETTXTCOLBAR   = %WM_USER + 154 'wParam sets bar text color
    %PGB_SETTXTCOLBKG   = %WM_USER + 155 'wParam sets background text color
    %PGB_SETCOLBKG      = %WM_USER + 156 'wParam sets background color, lParam controls rebuild of bar
    %PGB_SETBARCOLEDGE  = %WM_USER + 157 'wParam sets bar's edge's color, lParam controls rebuild of bar
    %PGB_SETBARCOLMID   = %WM_USER + 158 'wParam sets bar's mid color, lParam controls rebuild of bar
    %PGB_SETBARDIR      = %WM_USER + 159 'wParam sets bar direction, 0:left/right 1:upside down 2:bottom/top 3:top/bottom, lParam controls rebuild of bar
    %PGB_SETGRADIENTDIR = %WM_USER + 160 'wParam sets gradient direction - 0:horizontal, 1:vertical, lParam controls rebuild of bar
    %PGB_SETTXTANGLE    = %WM_USER + 161 'wParam sets set rotated font, lParam controls rebuild of bar
     
    TYPE PGB3DDATA             'for storing control specific data in memory block
      pStep       AS LONG         'for tracking what step we are on
      pMax        AS LONG         'for storing max number of steps, usually 100 (%)
      hbBack      AS LONG         'handle for background brush
      barDC       AS LONG         'memCD for Progressbar
      barBit      AS LONG         'handle to Progressbar bitmap
      barDC2      AS LONG         'memCD for Progressbar buffer
      barBit2     AS LONG         'handle to Progressbar buffer bitmap
      memDc       AS LONG         'memCD for main buffer
      hBit        AS LONG         'handle to main buffer bitmap
      hRotateFont AS LONG         'handle to rotated font style
      hImageBar   AS LONG         'bar image handle
      hImageBkg   AS LONG         'background image handle
      direction   AS LONG         'bar direction - left to right, or right to left?
      gradientDir AS LONG         'gradient direction - left to right, or right to left?
      bkgColor    AS LONG         'background color
      barColEdge  AS LONG         'bar color, edges
      barColMid   AS LONG         'bar color, middle
      txtColBar   AS LONG         'custom text color in bar
      txtColBkg   AS LONG         'custom text color on background
      txtOnOff    AS LONG         '0 = no text, 1 = auto text (%), 2 = custom text
      txtPos      AS LONG         'text position in control, see DrawText API..
      txtBkg      AS ASCIIZ * 50  'text to be painted on background, increase/decrease size to suit your needs
      txtBar      AS ASCIIZ * 50  'text to be painted on bar, increase/decrease size to suit your needs
    END TYPE
     
    DECLARE FUNCTION CreateGradientBars(BYVAL hWnd AS LONG) AS LONG
     
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    ' Register control class
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    FUNCTION InitPGBAR3D AS LONG
      LOCAL wc          AS WNDCLASSEX
      LOCAL szClassName AS ASCIIZ * 20
     
      'register ProgressBar3D Class
      szClassName      = "PGBAR3D"
      wc.cbSize        = SIZEOF(wc)
      wc.style         = %CS_HREDRAW OR %CS_VREDRAW OR %CS_PARENTDC OR %CS_GLOBALCLASS
      wc.lpfnWndProc   = CODEPTR(PgbWndProc)
      wc.cbClsExtra    = 0
      wc.cbWndExtra    = 4  'for pointer to user defined TYPE with control-specific data
      wc.hInstance     = GetModuleHandle (BYVAL 0)
      wc.hIcon         = %NULL
      wc.hCursor       = LoadCursor(%NULL, BYVAL %IDC_ARROW )
      wc.hbrBackground = GetStockObject(%NULL_BRUSH)
      wc.lpszMenuName  = %NULL
      wc.lpszClassName = VARPTR(szClassName)
      wc.hIconSm       = %NULL
      FUNCTION = RegisterClassEx(wc)
    END FUNCTION
     
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    ' Progressbar procedure
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    FUNCTION PgbWndProc (BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, _
                         BYVAL wParam AS LONG, BYVAL lParam AS LONG) AS LONG
      LOCAL pgb AS PGB3DDATA PTR
     
      SELECT CASE wMsg
         CASE %WM_CREATE  'store control specific data, PGB3DDATA structure, in memory
            pgb = HeapAlloc(GetProcessHeap(), %HEAP_ZERO_MEMORY, SIZEOF(@pgb))
            IF pgb THEN
               SetWindowLong hWnd, 0, pgb     'Store the pointer for later use
            ELSE
               FUNCTION = -1 : EXIT FUNCTION  'failed to allocate memory, so return -1 to break the action
            END IF
     
            LOCAL hDC AS LONG, ic AS LONG, J AS LONG, L AS LONG, xPos AS LONG, yPos AS LONG, _
                  hFontOld AS LONG, rc AS RECT, rcTxt AS RECT, _
                  ps AS PAINTSTRUCT, lpSize AS SIZEL, tp AS ASCIIZ PTR
     
            @pgb.txtOnOff   = 0  'some initial values, to be changed via custom control messages
            @pgb.txtPos     = %DT_SINGLELINE OR %DT_CENTER OR %DT_VCENTER OR %DT_NOCLIP OR %DT_NOPREFIX
            @pgb.txtColBar  = RGB(0, 0, 0)
            @pgb.txtColBkg  = RGB(255, 255, 0)
            @pgb.bkgColor   = RGB(128, 128, 128)              'Background color
            @pgb.barColEdge = RGB(0, 128, 128)
            @pgb.barColMid  = RGB(0, 255, 255)
            @pgb.hbBack     = CreateSolidBrush(@pgb.bkgColor) 'Background brush
            EXIT FUNCTION
     
    'CUSTOM CONTROL MESSAGES
         CASE %PGB_STEPUP
            pgb = GetWindowLong(hWnd, 0)                      'Get control specific data
            IF @pgb.pStep < @pgb.pMax THEN                    'step up while < max
               INCR @pgb.pStep
               SendMessage hWnd, %PGB_REFRESH, 0, 0           'repaint window (bar)
               FUNCTION = 0 : EXIT FUNCTION
            END IF
     
          CASE %PGB_STEPDN
            pgb = GetWindowLong(hWnd, 0)                        'get control specific data
            IF @pgb.pStep > 0 THEN                              'step down while above 0
               DECR @pgb.pStep
               SendMessage hWnd, %PGB_REFRESH, 0, 0             'repaint window (bar)
               FUNCTION = 0 : EXIT FUNCTION
            END IF
     
          CASE %PGB_SETVALUE
            pgb = GetWindowLong(hWnd, 0)                        'get control specific data
            @pgb.pStep = wParam
            IF lParam THEN SendMessage hWnd, %PGB_REFRESH, 0, 0 'refresh if lParam says so
            FUNCTION = 0 : EXIT FUNCTION
     
         CASE %PGB_BUILDBARS
            CALL CreateGradientBars(hWnd)                       'build the scrollbars
            IF lParam THEN SendMessage hWnd, %PGB_REFRESH, 0, 0 'refresh if lParam says so
            FUNCTION = 0 : EXIT FUNCTION
     
         CASE %PGB_REFRESH                                      'redraw control
            InvalidateRect hWnd, BYVAL %NULL, 0 : UpdateWindow hWnd
            FUNCTION = 0 : EXIT FUNCTION
     
    'BAR SETTINGS
         CASE %PGB_SETMAX
            pgb = GetWindowLong(hWnd, 0)                      'Get control specific data
            @pgb.pMax = wParam                                'set max number of steps
            FUNCTION = 0 : EXIT FUNCTION
     
         CASE %PGB_GETMAX
            pgb = GetWindowLong(hWnd, 0)                      'Get control specific data
            FUNCTION = @pgb.pMax : EXIT FUNCTION              'Get max number of steps
     
         CASE %PGB_GETVALUE
            pgb = GetWindowLong(hWnd, 0)                      'Get control specific data
            FUNCTION = @pgb.pStep : EXIT FUNCTION             'return current step value
     
         CASE %PGB_SETCOLBKG
            pgb = GetWindowLong(hWnd, 0)                      'Get control specific data
            @pgb.bkgColor = wParam                            'Set background color via wParam
            IF @pgb.hbBack THEN DeleteObject @pgb.hbBack      'delete old brush, if any
            @pgb.hbBack = CreateSolidBrush(@pgb.bkgColor)     'create background color brush
            IF lParam THEN SendMessage hWnd, %PGB_BUILDBARS, 1, 0 'refresh if lParam says so
            FUNCTION = 0 : EXIT FUNCTION
     
         CASE %PGB_SETBARCOLEDGE
            pgb = GetWindowLong(hWnd, 0)                        'Get control specific data
            @pgb.barColEdge = wParam                            'Set bar color, edges
            IF lParam THEN SendMessage hWnd, %PGB_BUILDBARS, 0, 1 'rebuild and refresh if lParam says so
            FUNCTION = 0 : EXIT FUNCTION
     
         CASE %PGB_SETBARCOLMID
            pgb = GetWindowLong(hWnd, 0)                        'Get control specific data
            @pgb.barColMid = wParam                             'Set bar color, middle
            IF lParam THEN SendMessage hWnd, %PGB_BUILDBARS, 0, 1 'rebuild and refresh if lParam says so
            FUNCTION = 0 : EXIT FUNCTION
     
         CASE %PGB_SETBARDIR
            pgb = GetWindowLong(hWnd, 0)                        'Get control specific data
            @pgb.direction = wParam                             'left to right = 0, default
            IF lParam THEN SendMessage hWnd, %PGB_BUILDBARS, 0, 1 'rebuild and refresh if lParam says so
            FUNCTION = 0 : EXIT FUNCTION
     
         CASE %PGB_SETGRADIENTDIR
            pgb = GetWindowLong(hWnd, 0)                        'Get control specific data
            @pgb.gradientDir = wParam                           'horizontal = 0, default
            IF lParam THEN SendMessage hWnd, %PGB_BUILDBARS, 0, 1 'rebuild and refresh if lParam says so
            FUNCTION = 0 : EXIT FUNCTION
     
    'TEXT MESSAGES
         CASE %PGB_SETTXTON
            pgb = GetWindowLong(hWnd, 0)                      'Get control specific data
            @pgb.txtOnOff = lParam                            'set text on/off
            FUNCTION = 0 : EXIT FUNCTION
     
         CASE %PGB_GETTXTON
            pgb = GetWindowLong(hWnd, 0)                      'Get control specific data
            FUNCTION = @pgb.txtOnOff : EXIT FUNCTION          'return txtOnOff setting
     
         CASE %PGB_SETTXTPOS
            pgb = GetWindowLong(hWnd, 0)                      'Get control specific data
            @pgb.txtPos = wParam                              'set text position in control
            FUNCTION = 0 : EXIT FUNCTION
     
         CASE %PGB_GETTXTPOS
            pgb = GetWindowLong(hWnd, 0)                      'Get control specific data
            FUNCTION = @pgb.txtPos : EXIT FUNCTION            'return txtPos setting
     
         CASE %PGB_SETTXTBAR
            pgb = GetWindowLong(hWnd, 0)                      'Get control specific data
            tp = wParam
            @pgb.txtBar = @tp
            IF lParam THEN SendMessage hWnd, %PGB_REFRESH, 0, 0 'refresh if lParam says so
            FUNCTION = 0 : EXIT FUNCTION
     
         CASE %PGB_SETTXTBKG
            pgb = GetWindowLong(hWnd, 0)                      'Get control specific data
            tp = wParam
            @pgb.txtBkg = @tp
            IF lParam THEN SendMessage hWnd, %PGB_REFRESH, 0, 0 'refresh if lParam says so
            FUNCTION = 0 : EXIT FUNCTION
     
         CASE %PGB_SETTXTCOLBAR
            pgb = GetWindowLong(hWnd, 0)                      'Get control specific data
            @pgb.txtColBar = wParam                           'set bar's text color
            FUNCTION = 0 : EXIT FUNCTION
     
         CASE %PGB_SETTXTCOLBKG
            pgb = GetWindowLong(hWnd, 0)                      'Get control specific data
            @pgb.txtColBkg = wParam                           'set background's text color
            FUNCTION = 0 : EXIT FUNCTION
     
         CASE %PGB_SETTXTANGLE
            pgb = GetWindowLong(hWnd, 0)                        'Get control specific data
            LOCAL lf AS LOGFONT, tFont AS LONG
     
            tFont = SendMessage(hWnd, %WM_GETFONT, 0, 0)
            IF tFont = %NULL THEN tFont = GetStockObject(%ANSI_VAR_FONT) 'null if system font..
            CALL GetObject(tFont, SIZEOF(lf), BYVAL VARPTR(lf) )
     
            lf.lfescapement  = wParam * 10   'angle is given in tenths of degrees
            lf.lforientation = wParam * 10   'both should be same
            lf.lfWeight = %FW_BOLD           'whatever, this one looks something like system font..
            lf.lfFaceName = "Arial"          'must be True Type font for rotation purposes
            @pgb.hRotateFont = CreateFontIndirect(lf) 'create the font and store its handle
     
            IF lParam THEN SendMessage hWnd, %PGB_BUILDBARS, 0, 1 'rebuild and refresh if lParam says so
            FUNCTION = 0 : EXIT FUNCTION
     
    'STANDARD CONTROL MESSAGES
         CASE %WM_ERASEBKGND: FUNCTION = 1: EXIT FUNCTION     'we handle background redraw ourselves
     
         CASE %WM_PAINT                                       'time to paint bar
            pgb = GetWindowLong(hWnd, 0)                      'Get control specific data
     
            GetClientRect hWnd, rc                            'get size of control
            BeginPaint hWnd, ps                               'begin action
            FillRect @pgb.memDC, rc, @pgb.hbBack              'clear background
            xPos = @pgb.pStep * rc.nright / @pgb.pMax         'pre-calculate, since often used
            yPos = @pgb.pStep * rc.nBottom / @pgb.pMax        'pre-calculate, since often used
     
            IF @pgb.txtOnOff THEN                             'WITH TEXT
               IF @pgb.txtOnOff = 1 THEN
                  @pgb.txtBar = FORMAT$(@pgb.pStep) + "%"     'auto text to paint on bar
                  @pgb.txtBkg = @pgb.txtBar                   'auto text to paint on background
               END IF
               rcTxt = rc                                          'copy rect for drawtext
     
               IF @pgb.hRotateFont THEN
                  hFontOld    = SelectObject(@pgb.memDC, @pgb.hRotateFont)  'store original font for later use
                  hFontOld    = SelectObject(@pgb.barDC2, @pgb.hRotateFont) 'is same in both DC's
     
                  IF @pgb.direction = 1 THEN     'upside down
                     @pgb.txtPos = %DT_SINGLELINE OR %DT_CENTER OR %DT_VCENTER OR %DT_NOCLIP OR %DT_NOPREFIX
                     CALL GetTextExtentPoint32(@pgb.memDC, @pgb.txtBar, LEN(@pgb.txtBar), lpSize)
                     rcTxt.nBottom = rcTxt.nBottom + lpSize.cy * 2
                     rcTxt.nRight  = rcTxt.nRight + lpSize.cx * 2
     
                  ELSEIF @pgb.direction = 2 THEN 'bottom to top
                     @pgb.txtPos = %DT_SINGLELINE OR %DT_LEFT OR %DT_VCENTER OR %DT_NOCLIP OR %DT_NOPREFIX
                     CALL GetTextExtentPoint32(@pgb.memDC, @pgb.txtBar, LEN(@pgb.txtBar), lpSize)
                     rcTxt.nLeft    = (rcTxt.nRight - lpSize.cy) / 2
                     rcTxt.nBottom = rcTxt.nBottom + lpSize.cx * 1.25
     
                  ELSEIF @pgb.direction = 3 THEN 'top to bottom
                     @pgb.txtPos = %DT_SINGLELINE OR %DT_LEFT OR %DT_VCENTER OR %DT_NOCLIP OR %DT_NOPREFIX
                     CALL GetTextExtentPoint32(@pgb.memDC, @pgb.txtBar, LEN(@pgb.txtBar), lpSize)
                     rcTxt.nLeft = (rcTxt.nRight + lpSize.cy) / 2
                     rcTxt.nTop = rcTxt.nTop - lpSize.cx / 1.35
                  END IF
     
               END IF
     
               BitBlt @pgb.barDC2, 0, 0, rc.nright, rc.nbottom, _
                      @pgb.barDC, 0, 0, %SRCCOPY                   'paint original bar to buffer
     
               SetTextColor @pgb.barDC2, @pgb.txtColBar                  'set color on bar
               DrawText @pgb.barDC2, @pgb.txtBar, -1, rcTxt, @pgb.txtPos 'draw text on bar
     
               SetTextColor @pgb.memDC, @pgb.txtColBkg                   'set color on background
               DrawText @pgb.memDC, @pgb.txtBkg, -1, rcTxt, @pgb.txtPos  'draw text on background
     
               IF @pgb.direction = 0 THEN 'LEFT TO RIGHT - WITH TEXT
                  BitBlt @pgb.memDC, 0, 0, xPos, rc.nbottom, _
                         @pgb.barDC2, 0, 0, %SRCCOPY               'paint proper part of gradiate bar
     
               ELSEIF @pgb.direction = 1 THEN  'RIGHT TO LEFT - WITH TEXT
                  BitBlt @pgb.memDC, rc.nright - xPos, 0, xPos, rc.nbottom, _
                         @pgb.barDC2, rc.nright - xPos, 0, %SRCCOPY
     
               ELSEIF @pgb.direction = 2 THEN  'BOTTOM TO TOP - WITH TEXT
                  BitBlt @pgb.memDC, 0, rc.nbottom - yPos, rc.nright, rc.nbottom, _
                         @pgb.barDC2, 0, rc.nbottom - yPos, %SRCCOPY
     
               ELSEIF @pgb.direction = 3 THEN  'TOP TO BOTTOM - WITH TEXT
                  BitBlt @pgb.memDC, 0, 0, rc.nright, yPos, _
                         @pgb.barDC2, 0, 0, %SRCCOPY
     
               END IF
     
            ELSE                                               'WITHOUT TEXT
               IF @pgb.direction = 0 THEN      'LEFT TO RIGHT - NO TEXT
                  BitBlt @pgb.memDC, 0, 0, xPos, rc.nbottom, _
                         @pgb.barDC, 0, 0, %SRCCOPY                'paint proper part of gradiate bar
     
               ELSEIF @pgb.direction = 1 THEN  'RIGHT TO LEFT - NO TEXT
                  BitBlt @pgb.memDC, rc.nright - xPos, 0, xPos, rc.nbottom, _
                         @pgb.barDC, rc.nright - xPos, 0, %SRCCOPY
     
               ELSEIF @pgb.direction = 2 THEN  'BOTTOM TO TOP - NO TEXT
                  BitBlt @pgb.memDC, 0, rc.nbottom - yPos, rc.nright, rc.nbottom, _
                         @pgb.barDC, 0, rc.nbottom - yPos, %SRCCOPY
     
               ELSEIF @pgb.direction = 3 THEN  'TOP TO BOTTOM - NO TEXT
                  BitBlt @pgb.memDC, 0, 0, rc.nright, yPos, _
                         @pgb.barDC, 0, 0, %SRCCOPY
     
               END IF
     
            END IF
     
            BitBlt ps.hDC, 0, 0, rc.nright, rc.nbottom, _
                   @pgb.memDC, 0, 0, %SRCCOPY                 'paint it all to screen
     
            IF hFontOld THEN
                CALL SelectObject(@pgb.memDC, hFontOld)       'select the original font back
                CALL SelectObject(@pgb.barDC2, hFontOld)      'was the same in both DC's
            END IF
     
            EndPaint hWnd, ps                                 'finish up
            FUNCTION = 0 : EXIT FUNCTION
     
         CASE %WM_DESTROY                                     'clean up, to avoid nasty memory leaks
            pgb = GetWindowLong(hWnd, 0)                      'Get control specific data
     
            IF @pgb.hRotateFont THEN DeleteObject @pgb.hRotateFont 'may be a stockobject, but doesn't matter
            IF @pgb.hbBack  THEN DeleteObject @pgb.hbBack          'delete brush
            IF @pgb.memDC   THEN DeleteDC @pgb.memDC               'and memory DC's + bitmaps
            IF @pgb.hbit    THEN DeleteObject @pgb.hbit
            IF @pgb.barDC   THEN DeleteDC @pgb.barDC
            IF @pgb.barBit  THEN DeleteObject @pgb.barBit
            IF @pgb.barDC2  THEN DeleteDC @pgb.barDC2
            IF @pgb.barBit2 THEN DeleteObject @pgb.barBit2
            CALL HeapFree(GetProcessHeap(), 0, BYVAL pgb)          'free memory
            FUNCTION = 0 : EXIT FUNCTION
     
      END SELECT
      FUNCTION = DefWindowProc(hWnd, wMsg, wParam, lParam)
    END FUNCTION
     
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    ' Create actual ProgressBar, based on previously made settings
    ' Note: one could also load a couple of bitmaps here instead,
    ' for some terrific effects.. :-)
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    FUNCTION CreateGradientBars(BYVAL hWnd AS LONG) AS LONG
      LOCAL pgb AS PGB3DDATA PTR
      pgb = GetWindowLong(hWnd, 0)                      'Get control specific data
     
      LOCAL hDC AS LONG, ic AS LONG, J AS LONG, L AS LONG, hPen AS LONG, hPenOld AS LONG, rc AS RECT
     
      IF @pgb.memDC   THEN DeleteDC @pgb.memDC          'delete old memDC's and bitmaps, if any
      IF @pgb.hbit    THEN DeleteObject @pgb.hbit
      IF @pgb.barDC   THEN DeleteDC @pgb.barDC
      IF @pgb.barBit  THEN DeleteObject @pgb.barBit
      IF @pgb.barDC2  THEN DeleteDC @pgb.barDC2
      IF @pgb.barBit2 THEN DeleteObject @pgb.barBit2
     
      GetClientRect hWnd, rc                               'get control height and width
     
      hDC = GetDc(hWnd)
      IF hDC THEN                                          'create 3 compatible memory DC's based on
         @pgb.memDC  = CreateCompatibleDC(hDC)             'control's DC, for faster action in WM_PAINT
         @pgb.hbit   = CreateCompatibleBitmap(hDC, rc.nRight, rc.nBottom)
         SelectObject @pgb.memDC, @pgb.hbit
         @pgb.barDC  = CreateCompatibleDC(hDC)
         @pgb.barBit = CreateCompatibleBitmap(hDC, rc.nRight, rc.nBottom)
         SelectObject @pgb.barDC, @pgb.barBit
         @pgb.barDC2 = CreateCompatibleDC(hDC)
         @pgb.barBit2= CreateCompatibleBitmap(hDC, rc.nRight, rc.nBottom)
         SelectObject @pgb.barDC2, @pgb.barBit2
         SetBkMode @pgb.memDC, %TRANSPARENT                  'set text background modes
         SetBkMode @pgb.barDC2, %TRANSPARENT
     
         LOCAL r AS LONG, g AS LONG, b AS LONG, r2 AS LONG, g2 AS LONG, b2 AS LONG
     
         'Calculate gradient colors. Not fully pleased with this one.
         'It works, but I'll try to do a better one later on.
         r = (@pgb.barColEdge AND &h0000FF&)                'pick out red component
         g = (@pgb.barColEdge AND &h00FF00&) \ &h100&       'pick out green component
         b = (@pgb.barColEdge AND &hFF0000&) \ &h10000&     'pick out blue component
         r2 = MAX&(0, (@pgb.barColMid AND &h0000FF&) - r)   'pick out difference between edge and mid part
         g2 = MAX&(0, (@pgb.barColMid AND &h00FF00&) \ &h100& - g)   'never less than zero..
         b2 = MAX&(0, (@pgb.barColMid AND &hFF0000&) \ &h10000& - b)
     
         IF @pgb.gradientDir = 0 THEN                      'HORIZONTAL BAR
            r2 = r2 / (rc.nBottom / 2)                     'calculate steps for each component
            g2 = g2 / (rc.nBottom / 2)
            b2 = b2 / (rc.nBottom / 2)
            ic = rc.nBottom / 2                            'for 3D, we only need half height
         ELSE                                              'VERTICAL BAR
            r2 = r2 / (rc.nRight / 2)                      'calculate steps for each component
            g2 = g2 / (rc.nRight / 2)
            b2 = b2 / (rc.nRight / 2)
            ic = rc.nRight / 2                             'for 3D, we only need half width
         END IF
     
         J = 0
         IF @pgb.gradientDir = 0 THEN 'HORIZONTAL BAR
            L = rc.nBottom / 2
            FOR ic = 0 TO rc.nBottom - 1                      'draw the whole gradient bar
               hPen = CreatePen(%PS_SOLID, 1, _
                      RGB(MIN&(255, r + J * r2), MIN&(255, g + J * g2), MIN&(255, b + J * b2))) 'create pen
     
               hPenOld = SelectObject(@pgb.barDC, hPen)       'select pen into DC, store original pen
               MoveTo @pgb.barDC, 0, ic                       'move into position
               LineTo @pgb.barDC, rc.nRight, ic               'and draw a line from left to right
     
               CALL SelectObject(@pgb.barDC2, hPen)           'select pen into DC, old pen same as above, so no need to store it
               MoveTo @pgb.barDC2, 0, ic                      'move into position
               LineTo @pgb.barDC2, rc.nRight, ic              'and draw a line from left to right
     
               CALL SelectObject(@pgb.barDC, hPenOld)         'select original pen into DC
               CALL SelectObject(@pgb.barDC2, hPenOld)        'was same in both DC's..
               DeleteObject hPen                              'delete pen to avoid memory leaks
               IF ic < L THEN INCR J ELSE DECR J              'increase color to midpoint, decrease after
            NEXT
     
         ELSE                         'VERTICAL BAR
            L = rc.nRight / 2
            FOR ic = 0 TO rc.nRight - 1                       'draw the whole gradient bar
               hPen = CreatePen(%PS_SOLID, 1, _
                      RGB(MIN&(255, r + J * r2), MIN&(255, g + J * g2), MIN&(255, b + J * b2))) 'create pen
     
               hPenOld = SelectObject(@pgb.barDC, hPen)       'select pen into DC, store original pen
               MoveTo @pgb.barDC, ic, 0                       'move into position
               LineTo @pgb.barDC, ic, rc.nBottom              'and draw a line from top to bottom
     
               CALL SelectObject(@pgb.barDC2, hPen)           'select pen into DC, old pen same as above, so no need to store it
               MoveTo @pgb.barDC2, ic, 0                      'move into position
               LineTo @pgb.barDC2, ic, rc.nBottom             'and draw a line from top to bottom
     
               CALL SelectObject(@pgb.barDC, hPenOld)         'select original pen into DC
               CALL SelectObject(@pgb.barDC2, hPenOld)        'was same in both DC's..
               DeleteObject hPen                              'delete pen to avoid memory leaks
     
               IF ic < L THEN INCR J ELSE DECR J              'increase color to midpoint, decrease after
            NEXT
     
         END IF
     
         ReleaseDc hWnd, hDC                                   'release the temporary DC
         FUNCTION = %TRUE                                      'return true on success
      END IF
     
    END FUNCTION
    Updated version, March 12..



    [This message has been edited by Borje Hagsten (edited March 12, 2001).]
Working...
X