Rubber Band (Focus Rectangle)

[zapman*]

Code updated For 5.20+

Code: Select all

Procedure Set_Rect (x1,y1,x2,y2, *FRect.Rect)
  If x2<x1
    mx = x1
    x1 = x2
    x2 = mx
  EndIf
  If y2<y1
    my = y1
    y1 = y2
    y2 = my
  EndIf
  If x1<0 : x1 = 0 : EndIf
  If y1<0 : y1 = 0 : EndIf
  *FRect\left = x1
  *FRect\Top = y1
  *FRect\Right = x2
  *FRect\Bottom = y2
EndProcedure

If OpenWindow(0,0,0,745,425,"Démo Rectangle de sélection",#PB_Window_SystemMenu|#PB_Window_ScreenCentered| #PB_Window_MinimizeGadget)
  hdc = GetDC_(WindowID(0))
  DraggingOn = 0
  Repeat
    EventID = WaitWindowEvent()
    If EventID = #WM_LBUTTONDOWN
      GetCursorPos_(@StartPos.Point) ; Memorise Start position of the cursor
      GetWindowRect_(WindowID(0) ,@SDRect.RECT)
      If PtInRect_(SDRect,PeekQ(StartPos)) ; if the cursor is inside the window
        StartPos\x - SDRect\Left-2 ; calculate relative corrdinates
        StartPos\y - SDRect\Top - 27
        MPos.Point\x = StartPos\x
        MPos\y = StartPos\y
        DraggingOn = 1
        Set_Rect(WindowX(0)+3,WindowY(0)+29,WindowX(0)+3+WindowWidth(0),WindowY(0)+29+WindowHeight(0),WRect.Rect)
        ClipCursor_(WRect) ; clip cursor to be sure to get the #WM_LBUTTONUP event
      EndIf
    EndIf
    
    If GetAsyncKeyState_(#VK_LBUTTON) And DraggingOn ; if button is still pressed
      GetCursorPos_(@OverPos.Point)
      GetWindowRect_(WindowID(0) ,@SDRect.RECT)
      If PtInRect_(SDRect,PeekQ(OverPos)) ; if the cursor is inside the window
        OverPos\x - SDRect\Left-2 ; calculate relative corrdinates
        OverPos\y - SDRect\Top - 27
        If MPos.Point\x<>StartPos.Point\x Or MPos\y<>StartPos\y  ; if cursor has move since start
          Set_Rect (StartPos\x,StartPos\y,MPos.Point\x,MPos\y, FRect.Rect)
          DrawFocusRect_(hdc,FRect) ; Erase last drawing
        EndIf
        If MPos.Point\x<>OverPos\x Or MPos\y<>OverPos\y
          Set_Rect (StartPos\x,StartPos\y,OverPos\x,OverPos\y, FRect.Rect)
          MPos\x = OverPos\x ; Memorise new drawing
          MPos\y = OverPos\y
          DrawFocusRect_(hdc,FRect) ; and draw it
        EndIf
      EndIf
    EndIf
    
    If EventID = #WM_LBUTTONUP And DraggingOn
      Set_Rect (StartPos\x,StartPos\y,MPos.Point\x,MPos\y, FRect.Rect)
      DrawFocusRect_(hdc,FRect) ; erase last drawing
      DraggingOn = 0
      ClipCursor_(0) ; free cursor
    EndIf
  Until  EventID = #PB_Event_CloseWindow
  
  ReleaseDC_(WindowID(0),hdc)
EndIf

[Fred]

Nice one !

[ebs]

zapman,

Very nice!

I think I found a bug, though

If you drag the rectangle to the very bottom of the window and back up a few times, the lines at the bottom don't get erased properly. Can you reproduce this?

Regards,
Eric

[zapman*]

Yes, I can. This is due to a non-perfect management of the ClipCursor function.

[Dare2]

This is neat (as always).

Noticed that if you click once (no drag) you can get a dot left on screen.

[PB]

On my system, the bottom-right corner of the rectangle is about 5 pixels
higher than the tip of my mouse pointer. The X position is correct, though.

[einander]

Here is another approach to keep dragging when mouse is outside window.
PB.3.91 - Tested with win XP.

Code: Select all

Procedure RubberBox(DC,RGB,*Rubber.RECT)    
    BKG = CreateCompatibleDC_(DC) 
    w=WindowWidth():H=WindowHeight() 
    
    GetWindowRect_(WindowID(), @R.RECT)   ; Window bounding rectangle 
    Rim = (R\right - R\left - w) / 2              ; window rim width 
    HiTitle = R\bottom - R\top - H - Rim     ;title height 
    
    SelectObject_(BKG,CreateImage(0,w,H))  ; keep background image  
    BitBlt_(BKG,0,0,w,H,DC,0,0,#SRCCOPY) 
    x=WindowMouseX():y=WindowMouseY() 
    lplb.LOGBRUSH 
    lplb\lbStyle=#BS_SOLID 
    lplb\lbColor=RGB 
    
    Repeat 
        EV=WindowEvent() 
        DMX=DesktopMouseX():DMY=DesktopMouseY() 
        X1=WindowMouseX():Y1=WindowMouseY() 
        If X1=-1 : X1=DMX-WindowX()-rim : EndIf 
        If Y1=-1 : Y1=DMY-WindowY()-HiTitle : EndIf 
        If X1<>xOld Or Y1 <>yOld 
            If x<>X1 Or y <>Y1 
                BitBlt_(DC,0,0,w,H,BKG,0,0,#SRCCOPY) ;delete previous rectangle 
                SelectObject_(DC,GetStockObject_(#NULL_BRUSH )) 
                Pen=ExtCreatePen_(#PS_COSMETIC| #PS_ALTERNATE,1,@lplb,0,0)              
                SelectObject_(DC,Pen) 
                Rectangle_(DC,x,y,X1,Y1)    
                xOld=X1:yOld=Y1 
                DeleteObject_(Pen)                  
            EndIf 
        Else 
            Delay(20) 
        EndIf 
    Until  GetAsyncKeyState_(#VK_LBUTTON)=0    
    BitBlt_(DC,0,0,w,H,BKG,0,0,#SRCCOPY)  ; restore background 
    DeleteDC_(BKG) ;recover memory 
    *Rubber.RECT\left=x:*Rubber\top=y:*Rubber\right=X1:*Rubber\bottom=Y1 ; keep coords of selected rectangle 
EndProcedure 
    ;_____________________________________________________ 
    
hwnd = OpenWindow(0, 100, 100, 600,400, #WS_OVERLAPPEDWINDOW , "RubberBox") 
hdc = GetDC_(hwnd) 
StartDrawing(WindowOutput())    
Repeat 
    EV = WaitWindowEvent()    
    If EV=#WM_LBUTTONDOWN 
        RubberBox(hdc,#Red,@Rubber.RECT) ;Rubber.Rect is updated with the selected values 
 Box(rubber\left,rubber\Top,rubber\right-rubber\left,rubber\bottom-rubber\top,Random($ffffff))
    EndIf 
Until EV= #PB_Event_CloseWindow  

[zapman*]

Wonderfull !

My PB did'nt understand DMX=DesktopMouseX():DMY=DesktopMouseY(), so I replaced it by :
GetCursorPos_(@CPos.Point)
DMX=CPos\x:DMY=CPos\y
and it works well.

[einander]

Hi Zapman:
DesktopMouseX() and DesktopMouseY() are commands from the new Desktop Library in PB 3.91

[Dare2]

Nice, einander. Thanks.