对于想用VB6开发IDE程序的人来说很实用的代码，存下备忘。
frmFormDesign.frm
Option Explicit
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
'Windows declarations
Private Declare Function SetCapture Lib "user32 " (ByVal hwnd As Long) As Long
Private Declare Function ClipCursor Lib "user32 " (lpRect As Any) As Long
Private Declare Function ReleaseCapture Lib "user32 " () As Long
Private Declare Function GetWindowRect _
Lib "user32 " (ByVal hwnd As Long, _
lpRect As RECT) As Long
Private Declare Function GetCursorPos Lib "user32 " (lpPoint As POINTAPI) As Long
Private Declare Function GetDC Lib "user32 " (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC _
Lib "user32 " (ByVal hwnd As Long, _
ByVal hdc As Long) As Long
Private Declare Function SelectObject _
Lib "gdi32 " (ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32 " (ByVal hObject As Long) As Long
Private Declare Function GetStockObject Lib "gdi32 " (ByVal nIndex As Long) As Long
Private Declare Function CreatePen _
Lib "gdi32 " (ByVal nPenStyle As Long, _
ByVal nWidth As Long, _
ByVal crColor As Long) As Long
Private Declare Function SetROP2 _
Lib "gdi32 " (ByVal hdc As Long, _
ByVal nDrawMode As Long) As Long
Private Declare Function Rectangle _
Lib "gdi32 " (ByVal hdc As Long, _
ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
Private Const NULL_BRUSH = 5
Private Const PS_SOLID = 0
Private Const R2_NOT = 6
Enum ControlState
StateNothing = 0
StateDragging
StateSizing
End Enum
Private m_CurrCtl As Control
Private m_DragState As ControlState
Private m_DragHandle As Integer
Private m_DragRect As New CRect
Private m_DragPoint As POINTAPI
Private m_bDesignMode As Boolean
Private Sub Form_Load()
DragInit 'Initialize drag code
End Sub
Private Sub mnuMode_Click()
mnuModeDesign.Checked = m_bDesignMode
End Sub
Private Sub mnuModeDesign_Click()
m_bDesignMode = Not m_bDesignMode
If Not m_bDesignMode Then
DragEnd
End If
End Sub
Private Sub mnuModeExit_Click()
Unload Me
End Sub
'=========================== Sample controls ===========================
'To drag a control, simply call the DragBegin function with
'the control to be dragged
'=======================================================================
Private Sub Label1_MouseDown(Button As Integer, _
Shift As Integer, _
X As Single, _
Y As Single)
If Button = vbLeftButton And m_bDesignMode Then
DragBegin Label1
End If
End Sub
Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbLeftButton And m_bDesignMode Then
DragBegin Text1
End If
End Sub
Private Sub List1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbLeftButton And m_bDesignMode Then
DragBegin List1
End If
End Sub
Private Sub Image1_MouseDown(Button As Integer, _
Shift As Integer, _
X As Single, _
Y As Single)
If Button = vbLeftButton And m_bDesignMode Then
DragBegin Image1
End If
End Sub
Private Sub Picture1_MouseDown(Button As Integer, _
Shift As Integer, _
X As Single, _
Y As Single)
If Button = vbLeftButton And m_bDesignMode Then
DragBegin Picture1
End If
End Sub
'========================== Dragging Code ================================
'Initialization -- Do not call more than once
Private Sub DragInit()
Dim i As Integer, xHandle As Single, yHandle As Single
'Use black Picture box controls for 8 sizing handles
'Calculate size of each handle
xHandle = 5 * Screen.TwipsPerPixelX
yHandle = 5 * Screen.TwipsPerPixelY
'Load array of handles until we have 8
For i = 0 To 7
If i <> 0 Then
Load picHandle(i)
End If
picHandle(i).Width = xHandle
picHandle(i).Height = yHandle
'Must be in front of other controls
picHandle(i).ZOrder
Next i
'Set mousepointers for each sizing handle
picHandle(0).MousePointer = vbSizeNWSE
picHandle(1).MousePointer = vbSizeNS
picHandle(2).MousePointer = vbSizeNESW
picHandle(3).MousePointer = vbSizeWE
picHandle(4).MousePointer = vbSizeNWSE
picHandle(5).MousePointer = vbSizeNS
picHandle(6).MousePointer = vbSizeNESW
picHandle(7).MousePointer = vbSizeWE
'Initialize current control
Set m_CurrCtl = Nothing
End Sub
'Drags the specified control
Private Sub DragBegin(ctl As Control)
Dim rc As RECT
'Hide any visible handles
ShowHandles False
'Save reference to control being dragged
Set m_CurrCtl = ctl
'Store initial mouse position
GetCursorPos m_DragPoint
'Save control position (in screen coordinates)
'Note: control might not have a window handle
m_DragRect.SetRectToCtrl m_CurrCtl
m_DragRect.TwipsToScreen m_CurrCtl
'Make initial mouse position relative to control
m_DragPoint.X = m_DragPoint.X - m_DragRect.Left
m_DragPoint.Y = m_DragPoint.Y - m_DragRect.Top
'Force redraw of form without sizing handles
'before drawing dragging rectangle
Refresh
'Show dragging rectangle
DrawDragRect
'Indicate dragging under way
m_DragState = StateDragging
'In order to detect mouse movement over any part of the form,
'we set the mouse capture to the form and will process mouse
'movement from the applicable form events
ReleaseCapture 'This appears needed before calling SetCapture
SetCapture hwnd
'Limit cursor movement within form
GetWindowRect hwnd, rc
ClipCursor rc
End Sub
'Clears any current drag mode and hides sizing handles
Private Sub DragEnd()
Set m_CurrCtl = Nothing
ShowHandles False
m_DragState = StateNothing
End Sub
'Because some lightweight controls do not have a MouseDown event,
'when we get a MouseDown event on a form, we do a scan of the
'Controls collection to see if any lightweight controls are under
'the mouse. Note that this code does not work for controls within
'containers. Also, if no control is under the mouse, then we
'remove the sizing handles and clear the current control.
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Integer
If Button = vbLeftButton And m_bDesignMode Then
'Hit test over light-weight (non-windowed) controls
For i = 0 To (Controls.Count - 1)
'Check for visible, non-menu controls
'[Note 1]
'If any of the sizing handle controls are under the mouse
'pointer, then they must not be visible or else they would
'have already intercepted the MouseDown event.
'[Note 2]
'This code will fail if you have a control such as the
'Timer control which has no Visible property. You will
'either need to make sure your form has no such controls
'or add code to handle them.
If Not TypeOf Controls(i) Is Menu And Controls(i).Visible Then
m_DragRect.SetRectToCtrl Controls(i)
If m_DragRect.PtInRect(X, Y) Then
DragBegin Controls(i)
Exit Sub
End If
End If
Next i
'No control is active
Set m_CurrCtl = Nothing
'Hide sizing handles
ShowHandles False
End If
End Sub
'To handle all mouse message anywhere on the form, we set the mouse
'capture to the form. Mouse movement is processed here
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim nWidth As Single, nHeight As Single
Dim pt As POINTAPI
If m_DragState = StateDragging Then
'Save dimensions before modifying rectangle
nWidth = m_DragRect.Right - m_DragRect.Left
nHeight = m_DragRect.Bottom - m_DragRect.Top
'Get current mouse position in screen coordinates
GetCursorPos pt
'Hide existing rectangle
DrawDragRect
'Update drag rectangle coordinates
m_DragRect.Left = pt.X - m_DragPoint.X
m_DragRect.Top = pt.Y - m_DragPoint.Y
m_DragRect.Right = m_DragRect.Left + nWidth
m_DragRect.Bottom = m_DragRect.Top + nHeight
'Draw new rectangle
DrawDragRect
ElseIf m_DragState = StateSizing Then
'Get current mouse position in screen coordinates
GetCursorPos pt
'Hide existing rectangle
DrawDragRect
'Action depends on handle being dragged
Select Case m_DragHandle
Case 0
m_DragRect.Left = pt.X
m_DragRect.Top = pt.Y
Case 1
m_DragRect.Top = pt.Y
Case 2
m_DragRect.Right = pt.X
m_DragRect.Top = pt.Y
Case 3
m_DragRect.Right = pt.X
Case 4
m_DragRect.Right = pt.X
m_DragRect.Bottom = pt.Y
Case 5
m_DragRect.Bottom = pt.Y
Case 6
m_DragRect.Left = pt.X
m_DragRect.Bottom = pt.Y
Case 7
m_DragRect.Left = pt.X
End Select
'Draw new rectangle
DrawDragRect
End If
End Sub
'To handle all mouse message anywhere on the form, we set the mouse
'capture to the form. Mouse up is processed here
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbLeftButton Then
If m_DragState = StateDragging Or m_DragState = StateSizing Then
'Hide drag rectangle
DrawDragRect
'Move control to new location
m_DragRect.ScreenToTwips m_CurrCtl
m_DragRect.SetCtrlToRect m_CurrCtl
'Restore sizing handles
ShowHandles True
'Free mouse movement
ClipCursor ByVal 0&
'Release mouse capture
ReleaseCapture
'Reset drag state
m_DragState = StateNothing
End If
End If
End Sub
'Process MouseDown over handles
Private Sub picHandle_MouseDown(Index As Integer, _
Button As Integer, _
Shift As Integer, _
X As Single, _
Y As Single)
Dim i As Integer
Dim rc As RECT
'Handles should only be visible when a control is selected
Debug.Assert (Not m_CurrCtl Is Nothing)
'NOTE: m_DragPoint not used for sizing
'Save control position in screen coordinates
m_DragRect.SetRectToCtrl m_CurrCtl
m_DragRect.TwipsToScreen m_CurrCtl
'Track index handle
m_DragHandle = Index
'Hide sizing handles
ShowHandles False
'We need to force handles to hide themselves before drawing drag rectangle
Refresh
'Indicate sizing is under way
m_DragState = StateSizing
'Show sizing rectangle
DrawDragRect
'In order to detect mouse movement over any part of the form,
'we set the mouse capture to the form and will process mouse
'movement from the applicable form events
SetCapture hwnd
'Limit cursor movement within form
GetWindowRect hwnd, rc
ClipCursor rc
End Sub
'Display or hide the sizing handles and arrange them for the current rectangld
Private Sub ShowHandles(Optional bShowHandles As Boolean = True)
Dim i As Integer
Dim xFudge As Long, yFudge As Long
Dim nWidth As Long, nHeight As Long
If bShowHandles And Not m_CurrCtl Is Nothing Then
With m_DragRect
'Save some calculations in variables for speed
nWidth = (picHandle(0).Width \ 2)
nHeight = (picHandle(0).Height \ 2)
xFudge = (0.5 * Screen.TwipsPerPixelX)
yFudge = (0.5 * Screen.TwipsPerPixelY)
'Top Left
picHandle(0).Move (.Left - nWidth) + xFudge, (.Top - nHeight) + yFudge
'Bottom right
picHandle(4).Move (.Left + .Width) - nWidth - xFudge, .Top + .Height - nHeight - yFudge
'Top center
picHandle(1).Move .Left + (.Width / 2) - nWidth, .Top - nHeight + yFudge
'Bottom center
picHandle(5).Move .Left + (.Width / 2) - nWidth, .Top + .Height - nHeight - yFudge
'Top right
picHandle(2).Move .Left + .Width - nWidth - xFudge, .Top - nHeight + yFudge
'Bottom left
picHandle(6).Move .Left - nWidth + xFudge, .Top + .Height - nHeight - yFudge
'Center right
picHandle(3).Move .Left + .Width - nWidth - xFudge, .Top + (.Height / 2) - nHeight
'Center left
picHandle(7).Move .Left - nWidth + xFudge, .Top + (.Height / 2) - nHeight
End With
End If
'Show or hide each handle
For i = 0 To 7
picHandle(i).Visible = bShowHandles
Next i
End Sub
'Draw drag rectangle. The API is used for efficiency and also
'because drag rectangle must be drawn on the screen DC in
'order to appear on top of all controls
Private Sub DrawDragRect()
Dim hPen As Long, hOldPen As Long
Dim hBrush As Long, hOldBrush As Long
Dim hScreenDC As Long, nDrawMode As Long
'Get DC of entire screen in order to
'draw on top of all controls
hScreenDC = GetDC(0)
'Select GDI object
hPen = CreatePen(PS_SOLID, 2, 0)
hOldPen = SelectObject(hScreenDC, hPen)
hBrush = GetStockObject(NULL_BRUSH)
hOldBrush = SelectObject(hScreenDC, hBrush)
nDrawMode = SetROP2(hScreenDC, R2_NOT)
'Draw rectangle
Rectangle hScreenDC, m_DragRect.Left, m_DragRect.Top, m_DragRect.Right, m_DragRect.Bottom
'Restore DC
SetROP2 hScreenDC, nDrawMode
SelectObject hScreenDC, hOldBrush
SelectObject hScreenDC, hOldPen
ReleaseDC 0, hScreenDC
'Delete GDI objects
DeleteObject hPen
End Sub
Crect.cls
Option Explicit
'Unfortunately, a fair amount of additional logic
'is required only for line controls
#Const ADD_LINE_LOGIC = True
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 ClientToScreen Lib "user32 " (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient Lib "user32 " (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private m_Rect As RECT
#If ADD_LINE_LOGIC Then
'
Private Const SWAP_NONE = &H0
Private Const SWAP_X = &H1
Private Const SWAP_Y = &H2
Private m_fRectSwap As Integer
#End If
Public Property Let Left(NewLeft As Long)
m_Rect.Left = NewLeft
End Property
Public Property Get Left() As Long
Left = m_Rect.Left
End Property
Public Property Let Top(NewTop As Long)
m_Rect.Top = NewTop
End Property
Public Property Get Top() As Long
Top = m_Rect.Top
End Property
Public Property Let Right(NewRight As Long)
m_Rect.Right = NewRight
End Property
Public Property Get Right() As Long
Right = m_Rect.Right
End Property
Public Property Let Bottom(NewBottom As Long)
m_Rect.Bottom = NewBottom
End Property
Public Property Get Bottom() As Long
Bottom = m_Rect.Bottom
End Property
Public Property Let Width(NewWidth As Long)
m_Rect.Right = m_Rect.Left + NewWidth
End Property
Public Property Get Width() As Long
Width = m_Rect.Right - m_Rect.Left
End Property
Public Property Let Height(NewHeight As Long)
m_Rect.Bottom = m_Rect.Top + NewHeight
End Property
Public Property Get Height() As Long
Height = m_Rect.Bottom - m_Rect.Top
End Property
Public Sub SetRectToCtrl(ctl As Control)
#If ADD_LINE_LOGIC Then
'Reset swap flags
m_fRectSwap = SWAP_NONE
If TypeOf ctl Is Line Then
m_Rect.Left = ctl.X1
m_Rect.Top = ctl.Y1
m_Rect.Right = ctl.X2
m_Rect.Bottom = ctl.Y2
'Need valid rect for hit testing but
'must swap back in SetCtrlToRect
If m_Rect.Left > m_Rect.Right Then
m_fRectSwap = m_fRectSwap Or SWAP_X
End If
If m_Rect.Top > m_Rect.Bottom Then
m_fRectSwap = m_fRectSwap Or SWAP_Y
End If
'Normalize if needed
If m_fRectSwap <> SWAP_NONE Then
NormalizeRect
End If
Else
m_Rect.Left = ctl.Left
m_Rect.Top = ctl.Top
m_Rect.Right = ctl.Left + ctl.Width
m_Rect.Bottom = ctl.Top + ctl.Height
End If
#Else
m_Rect.Left = ctl.Left
m_Rect.Top = ctl.Top
m_Rect.Right = ctl.Left + ctl.Width
m_Rect.Bottom = ctl.Top + ctl.Height
#End If
End Sub
Public Sub SetCtrlToRect(ctl As Control)
#If ADD_LINE_LOGIC Then
If TypeOf ctl Is Line Then
'Restore normalized rectangle if needed
If m_fRectSwap And SWAP_X Then
ctl.X1 = m_Rect.Right
ctl.X2 = m_Rect.Left
Else
ctl.X1 = m_Rect.Left
ctl.X2 = m_Rect.Right
End If
If m_fRectSwap And SWAP_Y Then
ctl.Y1 = m_Rect.Bottom
ctl.Y2 = m_Rect.Top
Else
ctl.Y1 = m_Rect.Top
ctl.Y2 = m_Rect.Bottom
End If
'Force to valid rectangle
NormalizeRect
Else
'Force to valid rectangle
NormalizeRect
ctl.Move m_Rect.Left, m_Rect.Top, Width, Height
End If
#Else
'Force to valid rectangle
NormalizeRect
ctl.Move m_Rect.Left, m_Rect.Top, Width, Height
#End If
End Sub
Public Sub ScreenToTwips(ctl As Object)
Dim pt As POINTAPI
pt.X = m_Rect.Left
pt.Y = m_Rect.Top
ScreenToClient ctl.Parent.hwnd, pt
m_Rect.Left = pt.X * Screen.TwipsPerPixelX
m_Rect.Top = pt.Y * Screen.TwipsPerPixelX
pt.X = m_Rect.Right
pt.Y = m_Rect.Bottom
ScreenToClient ctl.Parent.hwnd, pt
m_Rect.Right = pt.X * Screen.TwipsPerPixelX
m_Rect.Bottom = pt.Y * Screen.TwipsPerPixelX
End Sub
Public Sub TwipsToScreen(ctl As Object)
Dim pt As POINTAPI
pt.X = m_Rect.Left / Screen.TwipsPerPixelX
pt.Y = m_Rect.Top / Screen.TwipsPerPixelX
ClientToScreen ctl.Parent.hwnd, pt
m_Rect.Left = pt.X
m_Rect.Top = pt.Y
pt.X = m_Rect.Right / Screen.TwipsPerPixelX
pt.Y = m_Rect.Bottom / Screen.TwipsPerPixelX
ClientToScreen ctl.Parent.hwnd, pt
m_Rect.Right = pt.X
m_Rect.Bottom = pt.Y
End Sub
Public Sub NormalizeRect()
Dim nTemp As Long
If m_Rect.Left > m_Rect.Right Then
nTemp = m_Rect.Right
m_Rect.Right = m_Rect.Left
m_Rect.Left = nTemp
End If
If m_Rect.Top > m_Rect.Bottom Then
nTemp = m_Rect.Bottom
m_Rect.Bottom = m_Rect.Top
m_Rect.Top = nTemp
End If
End Sub
Public Function PtInRect(X As Single, Y As Single) As Integer
If X >= m_Rect.Left And X < m_Rect.Right And Y >= m_Rect.Top And Y < m_Rect.Bottom Then
PtInRect = True
Else
PtInRect = False
End If
End Function
扫一扫
4680
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
