Tweet
Code:
'________________________________________________________________________________________
'
' Screen Drag Rectangle Demonstration
' -----------------------------------
'
' Demonstration of how to draw a drag rectangle on the screen DC without the performance
' loss seen when GetDC(NULL) is used to access the screen DC.
'
' This code will work fine with Vista's Aero (DWM) enabled, unlike code that uses GetDC(NULL) or CreateDC "DESKTOP".
'
' Org. discussion: [URL]http://www.powerbasic.com/support/pbforums/showthread.php?t=35876[/URL]
'
' Posted: August 2008.
'________________________________________________________________________________________
#Compile Exe
#Dim All
%USEMACROS = 1
#Include "WIN32API.INC" ' Windows API definitions.
Global gDragStarted As Long ' TRUE if drag operation in process.
Global gDraghWnd As Dword ' Window handle that the drag operation is in.
Global gDragLockWindow As Long ' TRUE if the desktop window was locked.
Global gDragHDC As Dword ' Device context of the desktop (screen).
Global gDragHalftoneBrush As Dword ' Halftone brush used for animated rectangles.
'------------------------------------------------------------------------------
' Creates an 8 pixel half-tone brush used with drawing "animated" rectangles.
'------------------------------------------------------------------------------
Function DragHalftoneBrush As Dword
Dim grayPattern(0 To 7) As Word
Local grayBitmap As Dword
Local i As Long
For i = 0 To 7
grayPattern(i) = &H5555
Shift Left grayPattern(i), (i And 1)
Next i
grayBitmap = CreateBitmap(8, 8, 1, 1, ByVal VarPtr(grayPattern(0)))
If (grayBitmap) Then
Function = CreatePatternBrush(grayBitmap)
DeleteObject(grayBitmap)
End If
End Function
'------------------------------------------------------------------------------
' Core function. Draws the drag rectangle on the previously obtained screen DC.
' Note: any previous rectangle is erased.
'------------------------------------------------------------------------------
Function DragPaint(ByRef rcArea As RECT, _
ByRef szlArea As SIZEL, _
ByRef rcAreaLast As RECT, _
ByRef szlLast As SIZEL, _
ByRef hBrush As Dword, _
ByRef hBrushLast As Dword) As Long
Local rgnNew As Dword
Local rgnOutside As Dword
Local rgnInside As Dword
Local rgnLast As Dword
Local rgnUpdate As Dword
Local hBrushOld As Dword
Local rc As RECT
Local szl As SIZEL
' Create an update region from the drag rectangle...
rgnOutside = CreateRectRgnIndirect(rcArea)
rc = rcArea
InflateRect(rc, -szlArea.cx, -szlArea.cy)
IntersectRect(rc, rc, rcArea)
rgnInside = CreateRectRgnIndirect(rc)
rgnNew = CreateRectRgn(0, 0, 0, 0)
CombineRgn(rgnNew, rgnOutside, rgnInside, %RGN_XOR)
If (hBrush = %NULL) Then hBrush = DragHalfToneBrush
If (hBrushLast = %NULL) Then hBrushLast = hBrush
If (IsRectEmpty(rcAreaLast) = %FALSE) Then
' find difference between new region and old region
rgnLast = CreateRectRgn(0, 0, 0, 0)
SetRectRgn(rgnOutside, rcAreaLast.nLeft, rcAreaLast.nTop, rcAreaLast.nRight, rcAreaLast.nBottom)
rc = rcAreaLast
InflateRect(rc, -szlLast.cx, -szlLast.cy)
IntersectRect(rc, rc, rcAreaLast)
SetRectRgn(rgnInside, rc.nLeft, rc.nTop, rc.nRight, rc.nBottom)
CombineRgn(rgnLast, rgnOutside, rgnInside, %RGN_XOR)
' only diff them if brushes are the same
If (hBrush = hBrushLast) Then
rgnUpdate = CreateRectRgn(0, 0, 0, 0)
CombineRgn(rgnUpdate, rgnLast, rgnNew, %RGN_XOR)
End If
End If
If (hBrush <> hBrushLast) And (IsRectEmpty(rcAreaLast) = %FALSE) Then
' brushes are different -- erase old region first
SelectClipRgn(gDragHDC, rgnLast)
GetClipBox(gDragHDC, rc)
hBrushOld = SelectObject(gDragHDC, hBrushLast)
PatBlt(gDragHDC, rc.nleft, rc.ntop, rc.nRight-rc.nLeft, rc.nBottom-rc.nTop, %PATINVERT)
SelectObject(gDragHDC, hBrushOld)
hBrushOld = %NULL
End If
' draw into the update/new region
SelectClipRgn(gDragHDC, IIf&(rgnUpdate <> %NULL, rgnUpdate, rgnNew))
GetClipBox(gDragHDC, rc)
hBrushOld = SelectObject(gDragHDC, hBrush)
PatBlt(gDragHDC, rc.nleft, rc.ntop, rc.nRight-rc.nLeft, rc.nBottom-rc.nTop, %PATINVERT)
If (hBrushOld <> %NULL) Then SelectObject(gDragHDC, hBrushOld)
SelectClipRgn(gDragHDC, %NULL)
Function = %TRUE
End Function
'------------------------------------------------------------------------------
' Draws a drag rectangle in the specified style to the window.
' Note: if rcArea is empty, the last rectangle drawn is removed.
'------------------------------------------------------------------------------
Function DragDraw(ByRef rcArea As RECT, _
ByVal nAnimated As Long, _
ByVal nThickness As Long) As Long
Local hWhiteBrush As Dword
Local hAniBrush As Dword
Local hBrush As Dword
Local szl As SIZEL
Static rcAreaLast As RECT
Static szlLast As SIZEL
Static bAniLast As Byte
If (gDragStarted = %FALSE) Then Exit Function
hWhiteBrush = GetStockObject(%WHITE_BRUSH)
hAniBrush = DragHalftoneBrush
If nAnimated Then
' Animated border...
hBrush = hAnibrush
Else
' Standard border...
hBrush = hWhiteBrush
End If
If (nThickness < 1) Then
' Use default line width if not specified....
If (nAnimated) Then
' Use thick frame width...
szl.cx = GetSystemMetrics(%SM_CXDLGFRAME)
szl.cy = GetSystemMetrics(%SM_CYDLGFRAME)
Else
' Use very thin frame...
szl.cx = 1
szl.cy = 1
End If
Else
' User specified line width...
szl.cx = nThickness
szl.cy = nThickness
End If
If DragPaint(rcArea, szl, rcAreaLast, szlLast, hBrush, IIf&(bAniLast, hAniBrush, hWhiteBrush)) Then
If VarPtr(rcArea) Then
' Save last...
rcAreaLast = rcArea
szlLast = szl
bAniLast = nAnimated
End If
Function = %TRUE
End If
End Function
CallBack Function dlgProc
Local hDesktop As Dword
Local msg As TAGMSG
Select Case CbMsg
Case %wm_lbuttondown
' Only start once per drag session...
If gDragStarted Then Exit Function
' Clear the message queue of any WM_PAINT messages...
While (PeekMessage(msg, %NULL, %wm_paint, %wm_paint, %PM_NOREMOVE))
If (GetMessage(msg, %NULL, %wm_paint, %wm_paint) = %FALSE) Then
Exit Loop
End If
DispatchMessage(msg)
Loop
' Use specific window or desktop...
gDraghWnd = %NULL 'cbhndl
' Lock all updates...
gDragLockWindow = LockWindowUpdate(gDraghWnd)
If (gDragLockWindow) Then
gDragHDC = GetDCEx(gDraghWnd, %NULL, %DCX_WINDOW Or %DCX_CACHE Or %DCX_LOCKWINDOWUPDATE)
Else
gDragHDC = GetDCEx(gDraghWnd, %NULL, %DCX_WINDOW Or %DCX_CACHE)
End If
' Must have a valid screen DC...
If (gDragHDC) Then
' Create halftone brush for later use...
gDragHalftoneBrush = DragHalftoneBrush
gDragStarted = %TRUE
End If
' Capture the mouse now...
SetCapture CbHndl
Case %wm_mousemove
' Draw the rectangle...
If (gDragStarted = %FALSE) Then Exit Function
Local rc As RECT
GetCursorPos ByVal VarPtr(rc)
rc.nRight = rc.nLeft + 50
rc.nBottom = rc.nTop + 50
rc.nLeft = rc.nLeft - 50
rc.nTop = rc.nTop - 50
DragDraw rc, 0, 0
Case %wm_lbuttonup
' Trigger WM_CAPTURECHANGED...
ReleaseCapture
Case %wm_capturechanged
Local rcEmpty As RECT
' Must have started...
If (gDragStarted = %FALSE) Then Exit Function
' Clear last rectangle...
DragDraw rcEmpty, 0, 0
' Remove the temporary brush...
DeleteObject DragHalftoneBrush
' Remove the window lock and device context...
If (gDragLockWindow) Then LockWindowUpdate %NULL
ReleaseDC gDraghWnd, gDragHDC
' Signal we're finished...
gDragStarted = %FALSE
End Select
End Function
'------------------------------------------------------------------------------
' Program Start Point
'------------------------------------------------------------------------------
Function PBMain
Local hDlg As Dword
' Create the main program interface with DDT...
Dialog New %HWND_DESKTOP, "Click 'n' Drag", , , 350, 200, %ws_caption Or %ws_border Or %ws_sysmenu To hDlg
' Display the main dialog...
Dialog Show Modal hDlg Call dlgProc
End Function