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
[This message has been edited by Borje Hagsten (edited March 12, 2001).]