如何模拟一个象窗体一样的控件(标题栏、焦点、拖动、改变大小、关闭等等)

王朝vb·作者佚名  2006-01-08
窄屏简体版  字體: |||超大  

用过SQL Server视图设计或Access查询设计的都见过这样的控件,控件外形象一个窗体,有边框、标题栏、图标、关闭按钮,可拖动、改变大小等等

我前一段时间在做一个自定义查询,想把界面做成象SQL Server的设计视图那样,终于在MSDN里面找到了一些资料

MSDN的一些URL(把msdn的安装路径改成你自己的路径):

mk:@MSITStore:d:Program%20FilesMicrosoft%20Visual%20StudioMSDN2001JAN1033winui.chm::/hh/winui/mousinpt_7ik4.htm

mk:@MSITStore:d:Program%20FilesMicrosoft%20Visual%20StudioMSDN2001JAN1033winui.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

 
 
 
免责声明:本文为网络用户发布,其观点仅代表作者个人观点,与本站无关,本站仅提供信息存储服务。文中陈述内容未经本站证实,其真实性、完整性、及时性本站不作任何保证或承诺,请读者仅作参考,并请自行核实相关内容。
 
 
© 2005- 王朝網路 版權所有 導航