用过SQL Server视图设计或Access查询设计的都见过这样的控件，控件外形象一个窗体，有边框、标题栏、图标、关闭按钮，可拖动、改变大小等等
我前一段时间在做一个自定义查询，想把界面做成象SQL Server的设计视图那样，终于在MSDN里面找到了一些资料
MSDN的一些URL（把msdn的安装路径改成你自己的路径）：
mk:@MSITStore:d:\Program%20Files\Microsoft%20Visual%20Studio\MSDN\2001JAN\1033\winui.chm::/hh/winui/mousinpt_7ik4.htm
mk:@MSITStore:d:\Program%20Files\Microsoft%20Visual%20Studio\MSDN\2001JAN\1033\winui.chm::/hh/winui/mousinpt_6085.htm
一、添加一个User Control，控件结构如下
VERSION 5.00
Begin VB.UserControl TableView
AutoRedraw = -1 'True
ClientHeight = 4260
ClientLeft = 0
ClientTop = 0
ClientWidth = 3855
EditAtDesignTime= -1 'True
KeyPreview = -1 'True
ScaleHeight = 4260
ScaleWidth = 3855
Begin VB.PictureBox picTitle
BackColor = &H80000003&
BorderStyle = 0 'None
Height = 315
Left = 120
ScaleHeight = 315
ScaleWidth = 2715
TabIndex = 1
Top = 120
Width = 2715
Begin VB.Image imgClose
Height = 210
Index = 1
Left = 2400
Picture = "TableView.ctx":0000
Top = 0
Width = 240
End
Begin VB.Image imgTitle
Height = 180
Left = 60
Picture = "TableView.ctx":02E2
Top = 60
Width = 180
End
Begin VB.Image imgClose
Height = 210
Index = 0
Left = 1560
Picture = "TableView.ctx":04D4
Top = 0
Width = 240
End
Begin VB.Label lblTitle
BackColor = &H80000003&
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H8000000F&
Height = 255
Left = 240
TabIndex = 3
Top = 120
Width = 1995
End
End
Begin VB.ListBox lstColumn
Height = 1275
IntegralHeight = 0 'False
ItemData = "TableView.ctx":07B6
Left = 360
List = "TableView.ctx":07B8
OLEDragMode = 1 'Automatic
OLEDropMode = 1 'Manual
Style = 1 'Checkbox
TabIndex = 0
TabStop = 0 'False
Top = 600
Width = 2175
End
Begin VB.CommandButton cmdBack
Height = 2655
Left = 0
TabIndex = 2
TabStop = 0 'False
Top = 0
Width = 2895
End
End
Attribute VB_Name = "TableView"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
二、声明
' WM_NCHITTEST and MOUSEHOOKSTRUCT Mouse Position Codes
Const HTERROR = (-2)
Const HTTRANSPARENT = (-1)
Const HTNOWHERE = 0
Const HTCLIENT = 1
Const HTCAPTION = 2
Const HTSYSMENU = 3
Const HTGROWBOX = 4
Const HTSIZE = HTGROWBOX
Const HTMENU = 5
Const HTHSCROLL = 6
Const HTVSCROLL = 7
Const HTMINBUTTON = 8
Const HTMAXBUTTON = 9
Const HTLEFT = 10
Const HTRIGHT = 11
Const HTTOP = 12
Const HTTOPLEFT = 13
Const HTTOPRIGHT = 14
Const HTBOTTOM = 15
Const HTBOTTOMLEFT = 16
Const HTBOTTOMRIGHT = 17
Const HTBORDER = 18
Const HTREDUCE = HTMINBUTTON
Const HTZOOM = HTMAXBUTTON
Const HTSIZEFIRST = HTLEFT
Const HTSIZELAST = HTBOTTOMRIGHT
Const WM_SIZE = &H5
Const WM_NCLBUTTONDOWN = &HA1
Const HTCAPTION = 2
Const WM_CLOSE = &H10
Const WM_LBUTTONDOWN = &H201
Const MK_LBUTTON = &H1
Const WM_MOUSEMOVE = &H200
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
三、代码
'拖动
Private Sub picTitle_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
ReleaseCapture
SendMessage UserControl.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End If
End Sub
Private Sub UserControl_Resize()
On Error Resume Next
CloseBt = True
cmdBack.left = 0
cmdBack.width = UserControl.width
cmdBack.top = 0
cmdBack.height = UserControl.height
picTitle.left = 60
picTitle.top = 60
picTitle.width = UserControl.width - 150
picTitle.height = 255
imgClose(0).top = 30
imgClose(0).left = picTitle.width - 240
imgClose(0).Visible = CloseBt
imgClose(1).top = 30
imgClose(1).left = picTitle.width - 240
imgClose(1).Visible = (Not CloseBt)
lstColumn.left = 60
lstColumn.top = picTitle.height + 60
lstColumn.width = UserControl.width - lstColumn.left - 60
lstColumn.height = UserControl.height - lstColumn.top - 60
lblTitle.top = 60
lblTitle.left = 300
lblTitle.width = picTitle.width - 720
End Sub
Private Sub cmdBack_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim mvDir As Integer
If Button <> 1 Then Exit Sub
ReleaseCapture
If (X <= 60 And Y <= 60) Then
mvDir = HTTOPLEFT
ElseIf (cmdBack.width - X <= 60 And cmdBack.height - Y <= 60) Then
mvDir = HTBOTTOMRIGHT
ElseIf (X <= 60 And cmdBack.height - Y <= 60) Then
mvDir = HTBOTTOMLEFT
ElseIf (Y <= 60 And cmdBack.width - X <= 60) Then
mvDir = HTTOPRIGHT
ElseIf Y <= 60 And X > 60 And cmdBack.width - X > 60 Then
mvDir = HTTOP
ElseIf cmdBack.height - Y <= 60 And X > 60 And cmdBack.width - X > 60 Then
mvDir = HTBOTTOM
ElseIf X <= 60 And Y > 60 And cmdBack.height - Y > 60 Then
mvDir = HTLEFT
ElseIf cmdBack.width - X <= 60 And Y > 60 And cmdBack.height - Y > 60 Then
mvDir = HTRIGHT
End If
SendMessage UserControl.hwnd, WM_NCLBUTTONDOWN, mvDir, 0&
SendMessage UserControl.hwnd, WM_SIZE, 0, 0
UserControl_Resize
lstColumn.SetFocus
End Sub
Private Sub cmdBack_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If (X <= 60 And Y <= 60) Then
cmdBack.MousePointer = 8
ElseIf (cmdBack.width - X <= 60 And cmdBack.height - Y <= 60) Then
cmdBack.MousePointer = 8
ElseIf (X <= 60 And cmdBack.height - Y <= 60) Then
cmdBack.MousePointer = 6
ElseIf (Y <= 60 And cmdBack.width - X <= 60) Then
cmdBack.MousePointer = 6
ElseIf Y <= 60 And X > 60 And cmdBack.width - X > 60 Then
cmdBack.MousePointer = 7
ElseIf cmdBack.height - Y <= 60 And X > 60 And cmdBack.width - X > 60 Then
cmdBack.MousePointer = 7
ElseIf X <= 60 And Y > 60 And cmdBack.height - Y > 60 Then
cmdBack.MousePointer = 9
ElseIf cmdBack.width - X <= 60 And Y > 60 And cmdBack.height - Y > 60 Then
cmdBack.MousePointer = 9
End If
End Sub
|
