| |
Форма: перемещение элементов формы |
|
| |
Добавьте данную процедуру в вашу программу, и
вы сможете перемещать любой элемент,
расположенный на форме, в любое место вашей
формы.
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function ClipCursor Lib "user32" (lpRect As RECT) As Long
Private Declare Function ClipCursorByNum Lib "user32" Alias
"ClipCursor" (ByVal lpRect As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As
Integer
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect
As RECT) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long,
lpPoint As POINTAPI) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect
As RECT, ByVal bErase As Long) As Long
Private Declare Function InvalidateRectByNum Lib "user32" Alias
"InvalidateRect" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As
Long) As Long
' Перемещение любого контрола с помощью
клавиатуры и правой клавиши мыши
'
' Для того, чтобы задействовать перемещение, вы
должны в процедуру контрола MouseDown
' добавить несколько строчек кода. С помощью
клавиши Ctrl и правой клавиши мыши
' вы можете перемещать любой контрол на форме
' Для примера:
' Private Sub Command1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As
Single)
' If Button = vbRightButton And Shift = vbCtrlMask Then
' DragControl Command1
' End If
' End Sub
Sub DragControl(ctrl As Control)
Dim startButton As Integer
Dim startPoint As POINTAPI
Dim currPoint As POINTAPI
Dim contRect As RECT
Dim contScaleMode As Integer
' get mouse position and buttons pressed
GetCursorPos startPoint
If GetAsyncKeyState(vbLeftButton) Then startButton = vbLeftButton
If GetAsyncKeyState(vbRightButton) Then startButton = startButton Or vbRightButton
If GetAsyncKeyState(vbMiddleButton) Then startButton = startButton Or vbMiddleButton
' get container upper-left corner position
' in screen coordinates (currPoint is Zero)
ClientToScreen ctrl.Container.hwnd, currPoint
' get container size
GetClientRect ctrl.Container.hwnd, contRect
' convert to screen coordintes
contRect.Left = currPoint.X
contRect.Top = currPoint.Y
contRect.Right = contRect.Right + currPoint.X
contRect.Bottom = contRect.Bottom + currPoint.Y
' limit the cursor within the parent control
ClipCursor contRect
' get the ScaleMode that is active for the control
' this is the ScaleMode of its container, or it
' is vbTwips if its container does not support
' the ScaleMode property
On Error Resume Next
contScaleMode = vbTwips
' ignore next assignement if the container
' dows not support ScaleMode property
contScaleMode = ctrl.Container.ScaleMode
Do
' exit if all mouse buttons are released
If (startButton And vbLeftButton) = 0 Or GetAsyncKeyState(vbLeftButton) = 0 Then
If (startButton And vbRightButton) = 0 Or GetAsyncKeyState(vbRightButton) = 0 Then
If (startButton And vbMiddleButton) = 0 Or GetAsyncKeyState(vbMiddleButton) = 0 Then
Exit Do
End If
End If
End If
' get current mouse position
GetCursorPos currPoint
' move the control if they are different
If currPoint.X <> startPoint.X Or currPoint.Y <> startPoint.Y Then
' move the control
With ctrl.Parent
ctrl.Move ctrl.Left + .ScaleX(currPoint.X - startPoint.X, _
vbPixels, contScaleMode), ctrl.Top + .ScaleY(currPoint.Y - _
startPoint.Y, vbPixels, contScaleMode)
' refresh container
InvalidateRectByNum .hwnd, 0, False
.Refresh
End With
LSet startPoint = currPoint
End If
' allow background processing
DoEvents
Loop
' restore full mouse movement
ClipCursorByNum 0
End Sub
Private Sub Command1_Click()
MsgBox "привет"
End Sub
Private Sub Command1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As
Single)
If Button = vbRightButton And Shift = vbCtrlMask Then
DragControl Command1
End If
End Sub
Private Sub List1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbRightButton And Shift = vbCtrlMask Then
DragControl List1
End If
End Sub
|
|
| |
|
|
|
|