关于动态调整控件大小(要求用鼠彪拖动)

[ccbl]

鼠彪拖动,调整控件大小

[wgku]

看：运行时控件可设计。不过

[happybeyond]

'文本框为text1
Dim x0, y0 As Integer

Private Sub Form_Load()
Text1.Text = "控件的缩放"
End Sub

Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
x0 = X
y0 = Y
End Sub

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

If X > Text1.Width - 100 And X < Text1.Width + 100 Then
If Y < Text1.Height - 200 And Y > 100 Then
Text1.MousePointer = 9
If Button > 0 Then
Text1.Text = "右侧缩放"
Text1.Width = X
End If
Else
If Y > Text1.Height - 100 And Y < Text1.Height + 100 Then

Text1.MousePointer = 8
If Button > 0 Then
Text1.Text = "双向缩放"
Text1.Width = X
Text1.Height = Y
End If
End If
End If
Else
If Y > Text1.Height - 100 And Y < Text1.Height + 100 Then
Text1.MousePointer = 7
If Button > 0 Then
Text1.Text = "下侧缩放"
Text1.Height = Y
End If
Else
Text1.MousePointer = 0
If Button > 0 Then
Text1.MousePointer = 5
Text1.Text = " 移动"
Text1.Left = Text1.Left + X - x0
Text1.Top = Text1.Top + Y - y0
End If
End If
End If
End Sub

Private Sub Text1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Text1.Text = "控件的缩放"
End Sub

[wgku]

好长啊。。。。。。。。谁帮我UP：（
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "CRect"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False

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 A
s Long, lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd A
s 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

VERSION 5.00
Begin VB.Form frmFormDesign
Caption = "Form Design Demo"
ClientHeight = 4140
ClientLeft = 165
ClientTop = 450
ClientWidth = 6870
LinkTopic = "Form1"
ScaleHeight = 4140
ScaleWidth = 6870
StartUpPosition = 2 'CenterScreen
Begin VB.PictureBox Picture1
Height = 615
Left = 3960
Picture = "FormDsgn.frx":0000
ScaleHeight = 555
ScaleWidth = 795
TabIndex = 4
Top = 3360
Width = 855
End
Begin VB.ListBox List1
Height = 645
Left = 2040
TabIndex = 3
Top = 3360
Width = 855
End
Begin VB.TextBox Text1
Height = 645
Left = 1080
TabIndex = 2
Text = "Text1"
Top = 3360
Width = 855
End
Begin VB.PictureBox picHandle
Appearance = 0 'Flat
BackColor = &H80000008&
BorderStyle = 0 'None
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 375
Index = 0
Left = 6240
ScaleHeight = 375
ScaleWidth = 375
TabIndex = 0
Top = 120
Visible = 0 'False
Width = 375
End
Begin VB.Line Line1
X1 = 5880
X2 = 6720
Y1 = 3360
Y2 = 3960
End
Begin VB.Image Image1
Height = 615
Left = 4920
Picture = "FormDsgn.frx":0442
Stretch = -1 'True
Top = 3360
Width = 855
End
Begin VB.Shape Shape1
Height = 615
Left = 3000
Top = 3360
Width = 855
End
Begin VB.Label Label1
Caption = "Label1"
Height = 615
Left = 120
TabIndex = 1
Top = 3360
Width = 855
End
Begin VB.Menu mnuMode
Caption = "&Mode"
Begin VB.Menu mnuModeDesign
Caption = "&Design Mode"
End
Begin VB.Menu mnuModeSep10
Caption = "-"
End
Begin VB.Menu mnuModeExit
Caption = "E&xit"
End
End
End
Attribute VB_Name = "frmFormDesign"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'
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

[wgku]

'Windows declarations
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Lo
ng) As Long
Private Declare Function ClipCursor Lib "user32" (lpRect As Any) A
s 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 POI
NTAPI) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) A
s Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Lon
g, ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Lo
ng, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject A
s 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, B
yVal 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 Singl
e, 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 Singl
e, 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 Sin
gle, 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


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

[mindd]

你要的是那种鼠标放在两个控件中间，鼠标变成与分界线垂直的图标，按下鼠标就可以调整两个控件大小的样子吗？如果是的话，我以前做过的，可以给你源代码。

[wgku]

'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 A
s 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 rectan
gle
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 rectan
gld
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 + .He
ight - 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 - nHeig
ht + yFudge
'Bottom left
picHandle(6).Move .Left - nWidth + xFudge, .Top + .Height - nHei
ght - yFudge
'Center right
picHandle(3).Move .Left + .Width - nWidth - xFudge, .Top + (.Hei
ght / 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

[孙小雄]

http://211.141.67.12/vb/z.zip

[孙小雄]

up