This is a tough one...at least for me...any help??

I want to be able to draw a focus rectangle with the mouse. Just like you can on the windows desktop to select multiple icons. I have the API declare which is DrawFocusRect....but I have no clue how to approach this. Anyone done this yet??

Thanks for any input!!

This might help get you started, paste the code in your declarations section, and play around with the form's drawStyle property to change the appearance of the box.

Code:

---

Private drawing As Boolean
Private startX As Integer, startY As Integer

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
drawing = True
startX = X
startY = Y
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If drawing Then
    Form1.Cls
    Form1.Line (startX, startY)-(X, Y), , B
End If
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
drawing = False
End Sub

---

Try this.

Code:

---

Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Dim FocusRect As RECT


Private Sub Form_Load()

    Me.ScaleMode = 3
    Me.AutoRedraw = True
   
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

    'Set the starting points
    If Button = 1 Then
        FocusRect.Left = X
        FocusRect.Top = Y
    End If
   
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

    'Draw the Focus Rectangle
    If Button = 1 Then
        Cls
        FocusRect.Right = X
        FocusRect.Bottom = Y
        DrawFocusRect Me.hdc, FocusRect
    End If
   
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

    'Clear the Screen
    Cls
   
End Sub

---

First you need a RECT Type

Code:

---

Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

---

This is how the API References a Rectangle, It is fairly self explanitory but all Mearurements are in Pixels

the hDC parameter is just the hDC propperty of what you want to draw it on, most controlls have an hDC property, just plug it straight in. This Draws a Rectangle on the Control, nothing else, to get rid of it do the Same Call Again, for example something like this

Code:

---

Option Explicit
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type


Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long

Dim R As RECT

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

If Button = vbLeftButton Then

    R.Left = Me.ScaleX(X, Me.ScaleMode, vbPixels)
    R.Top = Me.ScaleY(Y, Me.ScaleMode, vbPixels)
   
    R.Right = R.Left
    R.Bottom = R.Top
 
    DrawFocusRect Me.hdc, R
   

End If

End Sub


Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

Static boolCheck As Boolean

boolCheck = Not boolCheck

If Button = vbLeftButton And (R.Left <= Me.ScaleX(X, Me.ScaleMode, vbPixels)) And (R.Top <= Me.ScaleY(Y, Me.ScaleMode, vbPixels)) And boolCheck Then

    'Get Rid of old focus Rect
    DrawFocusRect Me.hdc, R
   
    'Set new focus rect position
    R.Right = Me.ScaleX(X, Me.ScaleMode, vbPixels)
    R.Bottom = Me.ScaleY(Y, Me.ScaleMode, vbPixels)

    'draw the new rect
    DrawFocusRect Me.hdc, R
   
    'Refresh Form To Make Sure Rect Appears
    Me.Refresh

End If
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbLeftButton And R.Left <= Me.ScaleX(X, Me.ScaleMode, vbPixels) And R.Top <= Me.ScaleY(Y, Me.ScaleMode, vbPixels) Then

    'Get Rid of old focus Rect
    DrawFocusRect Me.hdc, R
    Me.Refresh
   
End If
End Sub

---

just replace me with the control you want to draw the rects in (and the event titles too.

Found this old thread because I had to do something similar. I modified Megatron's code a bit to make the focus rectangle appear in all 4 quadrants. So no matter where you drag the mouse you will always have your focus rectangle on the screen. Enjoy.

Code:

---

Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Dim FocusRect As RECT
Dim LeftStart As Long
Dim TopStart As Long

Private Sub Form_Load()

    Me.ScaleMode = 3
    Me.AutoRedraw = True
   
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

    'Set the starting points
  If Button = 1 Then
      FocusRect.Left = X
      FocusRect.Top = Y
      LeftStart = X
      TopStart = Y
  End If
   
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

    'Draw the Focus Rectangle
  If Button = 1 Then
      Cls
      If X < LeftStart And Y > TopStart Then 'Q3
        FocusRect.Right = LeftStart
        FocusRect.Left = X
        FocusRect.Bottom = Y
        FocusRect.Top = TopStart
      ElseIf X > LeftStart And Y < TopStart Then 'Q2
        FocusRect.Right = X
        FocusRect.Left = LeftStart
        FocusRect.Bottom = TopStart
        FocusRect.Top = Y
      ElseIf X < LeftStart And Y < TopStart Then 'Q1
        FocusRect.Right = LeftStart
        FocusRect.Left = X
        FocusRect.Bottom = TopStart
        FocusRect.Top = Y
      Else 'Q4 X < LeftStart and Y > TopStart
        FocusRect.Right = X
        FocusRect.Left = LeftStart
        FocusRect.Bottom = Y
        FocusRect.Top = TopStart
      End If
       
      DrawFocusRect Me.hdc, FocusRect
  End If
   
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

    'Clear the Screen
    Cls
   
End Sub

---