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

Screen Drag Rectangle Demonstration (Vista Compatible)

  • Filter
  • Time
  • Show
Clear All
new posts

  • Screen Drag Rectangle Demonstration (Vista Compatible)

    '  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][/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)
      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
      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
         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
         ' Standard border...
         hBrush = hWhiteBrush
      End If
      If (nThickness < 1) Then
         ' Use default line width if not specified....
         If (nAnimated) Then
            ' Use thick frame width...
   = GetSystemMetrics(%SM_CXDLGFRAME)
   = GetSystemMetrics(%SM_CYDLGFRAME)
            ' Use very thin frame...
   = 1
   = 1
         End If
         ' User specified line width... = nThickness = 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
                  ' 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)
                     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...
             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
    Last edited by Kev Peel; 4 Aug 2008, 02:57 PM. | Slam DBMS | PrpT Control | Other Downloads | Contact Me