分享
 
 
 

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

王朝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

 
 
 
免责声明:本文为网络用户发布,其观点仅代表作者个人观点,与本站无关,本站仅提供信息存储服务。文中陈述内容未经本站证实,其真实性、完整性、及时性本站不作任何保证或承诺,请读者仅作参考,并请自行核实相关内容。
2023年上半年GDP全球前十五强
 百态   2023-10-24
美众议院议长启动对拜登的弹劾调查
 百态   2023-09-13
上海、济南、武汉等多地出现不明坠落物
 探索   2023-09-06
印度或要将国名改为“巴拉特”
 百态   2023-09-06
男子为女友送行,买票不登机被捕
 百态   2023-08-20
手机地震预警功能怎么开?
 干货   2023-08-06
女子4年卖2套房花700多万做美容:不但没变美脸,面部还出现变形
 百态   2023-08-04
住户一楼被水淹 还冲来8头猪
 百态   2023-07-31
女子体内爬出大量瓜子状活虫
 百态   2023-07-25
地球连续35年收到神秘规律性信号,网友:不要回答!
 探索   2023-07-21
全球镓价格本周大涨27%
 探索   2023-07-09
钱都流向了那些不缺钱的人,苦都留给了能吃苦的人
 探索   2023-07-02
倩女手游刀客魅者强控制(强混乱强眩晕强睡眠)和对应控制抗性的关系
 百态   2020-08-20
美国5月9日最新疫情:美国确诊人数突破131万
 百态   2020-05-09
荷兰政府宣布将集体辞职
 干货   2020-04-30
倩女幽魂手游师徒任务情义春秋猜成语答案逍遥观:鹏程万里
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案神机营:射石饮羽
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案昆仑山:拔刀相助
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案天工阁:鬼斧神工
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案丝路古道:单枪匹马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:与虎谋皮
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:李代桃僵
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:指鹿为马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:小鸟依人
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:千金买邻
 干货   2019-11-12
 
推荐阅读
 
 
 
>>返回首頁<<
 
靜靜地坐在廢墟上,四周的荒凉一望無際,忽然覺得,淒涼也很美
© 2005- 王朝網路 版權所有