Date: 02-16-2022
Return to Index
created by gbSnippets
'Compilable Example: (Jose Includes)
'��������������������������������������������������������������������
' DrawRect sample, showing a completely flicker free way to draw a
' hollow rectangle in a window, by using a global memDC as buffer
' and temporary memDC for drawing, before copying all to screen.
'
' Also included is code for grid background points via pattern brush.
' Note: pattern brushes can only be 8x8 pixels in Win95. In all other
' systems, Win98 and up, brush can be larger. Commented code - hope
' it's understandable..
'
' Public Domain by Borje Hagsten, March 2003
'
' Can be used as base for a paint program, or why not a visual designer?
' Just add a few bytes of code for creating and resizing controls with
' the mouse, and you have made yourself your own visual designer..
'--------------------------------------------------------------------
#Compiler PBWin 9, PBWin 10
#Compile EXE
#Include "WIN32API.INC"
'--------------------------------------------------------------------
%IDC_CHK1 = 121
%IDC_CHK2 = 122
'--------------------------------------------------------------------
Declare CallBack Function DlgProc() As Long
Declare Function MakeGridBrush (ByVal hDlg AS DWord) AS DWord
Declare SUB selRectBegin (ByVal hWnd AS DWord)
Declare SUB selRectDraw (ByVal hWnd AS DWord, ByVal x As Long, ByVal y As Long)
Declare SUB selRectEnd (ByVal hWnd AS DWord)
'--------------------------------------------------------------------
Global cGridX As Long, cGridY As Long, gShowGrid As Long, gSnapToGrid As Long
Global ghBit AS DWord, ghBrush AS DWord, gMemDC AS DWord
Global gPt AS POINTAPI, gRc AS RECT
'��������������������������������������������������������������������
' Main entrance
'--------------------------------------------------------------------
Function PBMain () As Long
Local hDlg AS DWord, lRes As Long
DIALOG NEW 0, "DrawRect and grid sample",,, 321, 179, _
%WS_CAPTION OR %WS_CLIPCHILDREN OR %WS_SYSMENU, 0 TO hDlg
CONTROL ADD CHECKBOX, hDlg, %IDC_CHK1, "&Snap to grid ", 255, 130, 60, 10
CONTROL ADD CHECKBOX, hDlg, %IDC_CHK2, "&Show grid ", 255, 142, 60, 10
CONTROL SET CHECK hDlg, %IDC_CHK1, 1
CONTROL SET CHECK hDlg, %IDC_CHK2, 2
CONTROL ADD BUTTON, hDlg, %IDCANCEL, "&Quit", 255, 160, 60, 14
DIALOG SHOW MODAL hDlg CALL DlgProc
End Function
'��������������������������������������������������������������������
' Main callback
'--------------------------------------------------------------------
CallBack Function DlgProc() As Long
Local lRes As Long
SELECT CASE CBMSG
CASE %WM_INITDIALOG
STATIC hCur AS DWord ' for static grid brush handle
cGridX = 10 ' horizontal grid size
cGridY = 10 ' vertical grid size
gShowGrid = 1 ' show grid at start
gSnapToGrid = 1 ' snap drawing to grid at start
hCur = LoadCursor(0, ByVal %IDC_CROSS) ' store handle of cursot to use at draw
ghBrush = MakeGridBrush(CBHNDL) ' and create grid brush
CASE %WM_CTLCOLORDLG ' paint grid if gShowGrid is on..
IF gShowGrid AND ghBrush THEN Function = ghBrush
CASE %WM_DESTROY 'delete what we created on exit, to avoid mem leaks
IF ghBrush THEN DeleteObject ghBrush
IF ghBit THEN DeleteObject SelectObject(gMemDC, ghBit)
IF gMemDC THEN DeleteDC gMemDC 'should already be deleted, but to make sure..
CASE %WM_SETCURSOR
' If mouse button is pressed, over-ride default cursor and
' set "own", here cross cursor. Note - in dialogs, we must return
' %TRUE to inform dialog engine we have taken charge. In SDK-style
' windows, we would have had to return zero and break out.
IF CBWPARAM = CBHNDL AND HIWRD(CBLPARAM) = %WM_LBUTTONDOWN THEN
IF GetCursor <> hCur THEN SetCursor hCur
Function = 1
END IF
CASE %WM_LBUTTONDOWN, %WM_LBUTTONDBLCLK 'start selrect draw
selRectBegin CBHNDL
CASE %WM_MOUSEMOVE
IF (CBWPARAM AND %MK_LBUTTON) THEN 'if mouse button is down while moved, draw rect
selRectDraw CBHNDL, LOWRD(CBLPARAM), HIWRD(CBLPARAM)
END IF
CASE %WM_LBUTTONUP 'mouse button released - end draw
selRectEnd CBHNDL
' Now, when mouse button is released, global RECT (gRc)
' will hold coordinates of final drawn rect. If you
' for example want to select a group of controls or
' other objects, you can use IntersectRect API to see
' if parts of other RECT's are withing this global rect.
' Or use the coordinates to create a control/object of
' this size, whatever..
CASE %WM_COMMAND ' <- a control is calling
SELECT CASE CBCTL ' <- look at control's id
CASE %IDC_CHK1
IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
CONTROL GET CHECK CBHNDL, CBCTL TO gSnapToGrid
END IF
CASE %IDC_CHK2
IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
CONTROL GET CHECK CBHNDL, CBCTL TO gShowGrid
RedrawWindow CBHNDL, ByVal %NULL, 0, _
%RDW_ERASE OR %RDW_INVALIDATE OR %RDW_UPDATENOW
END IF
CASE %IDCANCEL
IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN 'end prog
DIALOG END CBHNDL
END IF
END SELECT
END SELECT
End Function
'��������������������������������������������������������������������
' initialize sel rect drawing
' Copy dialog to global "screen buffer" for use as base for flicker
' free drawing and later restore.
'--------------------------------------------------------------------
Sub selRectBegin (ByVal hWnd AS DWord)
Local hDC AS DWord, hBit AS DWord, pt AS POINTAPI, rc AS RECT
SetCapture hWnd ' set capture to desired window
GetClientRect hWnd, rc ' get client size
MapWindowPoints hWnd, 0, ByVal VarPTR(rc), 2 ' map client coordiantes to screen
ClipCursor rc ' clip cursor to client coordinates
GetCursorPos gPt ' get cursor pos on screen
ScreenToClient hWnd, gPt ' convert to client coordinates
IF gSnapToGrid THEN
gPt.x = (gPt.x \ cGridX) * cGridX ' if snap to grid, calculate "grid'd pos"
gPt.y = (gPt.y \ cGridY) * cGridY ' via multiply of integer divide result
END IF
GetClientRect hWnd, rc 'create a global memDC and copy window to it.
hDC = GetDc(hWnd)
gMemDC = CreateCompatibleDC (hDC)
ghBit = CreateCompatibleBitmap(hDC, rc.nRight, rc.nBottom)
ghBit = SelectObject(gMemDC, ghBit)
BitBlt gMemDC, 0, 0, rc.nRight, rc.nBottom, hDC, 0, 0, %SRCCOPY
ReleaseDc hWnd, hDC
End Sub
'��������������������������������������������������������������������
' perform sel rect drawing
'--------------------------------------------------------------------
Sub selRectDraw (ByVal hWnd AS DWord, ByVal x As Long, ByVal y As Long)
Local hDC AS DWord, hBrush AS DWord, hPen AS DWord, rc AS RECT
Local memDC AS DWord, hBit AS DWord
IF gSnapToGrid THEN
' MS cross cursor has mis-aligned hotspot - it should be at
' cross, but is upper-left corner. We should use own cross,
' but this is just a sample, so instead cheat and add 4 to pos..
x = x + 4 '<- depends on where hotspot in cursor is..
y = y + 4
x = (x \ cGridX) * cGridX 'first integer divide, then multiply for "grid effect".
y = (y \ cGridY) * cGridY
END IF
' must make sure rect coordinates are correct,
' so right side always is larger than left, etc.
IF (gPt.x <= x) AND (gPt.y >= y) THEN
SetRect gRc, gPt.x, y, x, gPt.y
ELSEIF (gPt.x > x) AND (gPt.y > y) THEN
SetRect gRc, x, y, gPt.x, gPt.y
ELSEIF (gPt.x >= x) AND (gPt.y <= y) THEN
SetRect gRc, x, gPt.y, gPt.x, y
ELSE
SetRect gRc, gPt.x, gPt.y, x, y
END IF
GetClientRect hWnd, rc
IF gRc.nLeft = gRc.nRight THEN INCR gRc.nRight '<- ensure we never get a "null rect"
IF gRc.nTop = gRc.nBottom THEN INCR gRc.nBottom
hDC = GetDc(hWnd)
memDC = CreateCompatibleDC (hDC) 'create temporary memDC to draw in
hBit = CreateCompatibleBitmap(hDC, rc.nRight, rc.nBottom)
hBit = SelectObject(memDC, hBit)
hBrush = SelectObject(memDC, GetStockObject(%NULL_BRUSH)) 'for hollow rect
BitBlt memDC, 0, 0, rc.nRight, rc.nBottom, gMemDC, 0, 0, %SRCCOPY 'copy original buffer to temp DC
hPen = SelectObject(memDC, CreatePen(%PS_SOLID, 2, GetSysColor(%COLOR_3DSHADOW))) 'create pen
Rectangle memDC, gRc.nLeft, gRc.nTop, gRc.nRight + 1, gRc.nBottom + 1 'draw rect
DeleteObject SelectObject(memDC, hPen)
BitBlt hDC, 0, 0, rc.nRight, rc.nBottom, memDC, 0, 0, %SRCCOPY 'copy temp DC to window
SelectObject memDC, hBrush
IF hBit THEN DeleteObject SelectObject(memDC, hBit) 'clean up to avoid mem leaks
IF memDC THEN DeleteDC memDC
ReleaseDc hWnd, hDC
End Sub
'��������������������������������������������������������������������
' end sel rect drawing
' Copy original window buffer back to screen to wipe out drawn
' rectangle, delete global memDC, release capture and clipped cursor.
'--------------------------------------------------------------------
Sub selRectEnd (ByVal hWnd AS DWord)
Local hDC AS DWord, rc AS RECT
hDC = GetDc(hWnd)
GetClientRect hWnd, rc
BitBlt hDC, 0, 0, rc.nRight, rc.nBottom, gMemDC, 0, 0, %SRCCOPY
ReleaseDc hWnd, hDC
IF ghBit THEN DeleteObject SelectObject(gMemDC, ghBit) : ghBit = 0
IF gMemDC THEN DeleteDC gMemDC : gMemDC = 0
ReleaseCapture
ClipCursor ByVal %NULL
End Sub
'��������������������������������������������������������������������
' Create a patterned brush for grid. By using this, grid draw becomes
' very quick, even on full size dialogs. Must warn though - in Win95,
' brush can be max 8x8 pixels. In Win98 and later, brush can be bigger,
' so never a problem there.
'--------------------------------------------------------------------
Function MakeGridBrush(ByVal hDlg AS DWord) AS DWord
Local hDC AS DWord, memDC AS DWord, hBit AS DWord, hBitOld AS DWord, rc AS RECT
hDC = GetDC(hDlg)
memDC = CreateCompatibleDC(hDC)
hBit = CreateCompatibleBitmap(hDC, cGridX, cGridY)
hBitOld = SelectObject(memDC, hBit)
rc.nRight = cGridX
rc.nBottom = cGridY
FillRect memDC, rc, GetSysColorBrush(%COLOR_3DFACE)
SetPixelV memDC, 0, 0, 0 'paint "dots" in all four corners
SetPixelV memDC, 0, cGridY, 0
SetPixelV memDC, cGridX, 0, 0
SetPixelV memDC, cGridX, cGridY, 0
Function = CreatePatternBrush (hBit)
SelectObject memDC, hBitOld 'clean up to avoid mem leaks
DeleteObject hBit
DeleteDC memDC
ReleaseDC hDlg, hDC
End Function
'gbs_01098
'Date: 03-10-2012
http://www.garybeene.com/sw/gbsnippets.htm