-
Notifications
You must be signed in to change notification settings - Fork 4
/
Copy pathfrmControls.frm
513 lines (474 loc) · 20.5 KB
/
frmControls.frm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
VERSION 5.00
Begin VB.Form frmControls
BorderStyle = 0 'None
Caption = "控件箱"
ClientHeight = 2340
ClientLeft = 0
ClientTop = 0
ClientWidth = 3630
LinkTopic = "Form1"
ScaleHeight = 2340
ScaleWidth = 3630
ShowInTaskbar = 0 'False
StartUpPosition = 2 'CenterScreen
Begin VB.CheckBox cmdControls
Appearance = 0 'Flat
Height = 360
Index = 19
Left = 360
Picture = "frmControls.frx":0000
Style = 1 'Graphical
TabIndex = 22
ToolTipText = "RTF文本框"
Top = 1080
Width = 360
End
Begin VB.CheckBox cmdControls
Appearance = 0 'Flat
Height = 360
Index = 0
Left = 0
Picture = "frmControls.frx":076A
Style = 1 'Graphical
TabIndex = 21
ToolTipText = "图片"
Top = 0
Width = 360
End
Begin VB.CheckBox cmdControls
Appearance = 0 'Flat
Height = 360
Index = 1
Left = 360
Picture = "frmControls.frx":0ED4
Style = 1 'Graphical
TabIndex = 20
ToolTipText = "标签"
Top = 0
Width = 360
End
Begin VB.CheckBox cmdControls
Appearance = 0 'Flat
Height = 360
Index = 2
Left = 720
Picture = "frmControls.frx":163E
Style = 1 'Graphical
TabIndex = 19
ToolTipText = "文本框"
Top = 0
Width = 360
End
Begin VB.CheckBox cmdControls
Appearance = 0 'Flat
Height = 360
Index = 3
Left = 1080
Picture = "frmControls.frx":1DA8
Style = 1 'Graphical
TabIndex = 18
ToolTipText = "组框"
Top = 0
Width = 360
End
Begin VB.CheckBox cmdControls
Appearance = 0 'Flat
Height = 360
Index = 4
Left = 1440
Picture = "frmControls.frx":2512
Style = 1 'Graphical
TabIndex = 17
ToolTipText = "按钮"
Top = 0
Width = 360
End
Begin VB.CheckBox cmdControls
Appearance = 0 'Flat
Height = 360
Index = 5
Left = 1800
Picture = "frmControls.frx":2C7C
Style = 1 'Graphical
TabIndex = 16
ToolTipText = "复选框"
Top = 0
Width = 360
End
Begin VB.CheckBox cmdControls
Appearance = 0 'Flat
Height = 360
Index = 6
Left = 0
Picture = "frmControls.frx":33E6
Style = 1 'Graphical
TabIndex = 15
ToolTipText = "单选框"
Top = 360
Width = 360
End
Begin VB.CheckBox cmdControls
Appearance = 0 'Flat
Height = 360
Index = 7
Left = 360
Picture = "frmControls.frx":3B50
Style = 1 'Graphical
TabIndex = 14
ToolTipText = "组合框"
Top = 360
Width = 360
End
Begin VB.CheckBox cmdControls
Appearance = 0 'Flat
Height = 360
Index = 8
Left = 720
Picture = "frmControls.frx":42BA
Style = 1 'Graphical
TabIndex = 13
ToolTipText = "列表框"
Top = 360
Width = 360
End
Begin VB.CheckBox cmdControls
Appearance = 0 'Flat
Height = 360
Index = 9
Left = 1080
Picture = "frmControls.frx":4A24
Style = 1 'Graphical
TabIndex = 12
ToolTipText = "水平滚动条"
Top = 360
Width = 360
End
Begin VB.CheckBox cmdControls
Appearance = 0 'Flat
Height = 360
Index = 10
Left = 1440
Picture = "frmControls.frx":518E
Style = 1 'Graphical
TabIndex = 11
ToolTipText = "垂直滚动条"
Top = 360
Width = 360
End
Begin VB.CheckBox cmdControls
Appearance = 0 'Flat
Height = 360
Index = 11
Left = 1800
Picture = "frmControls.frx":58F8
Style = 1 'Graphical
TabIndex = 10
ToolTipText = "调节按钮"
Top = 360
Width = 360
End
Begin VB.CheckBox cmdControls
Appearance = 0 'Flat
Height = 360
Index = 12
Left = 0
Picture = "frmControls.frx":6062
Style = 1 'Graphical
TabIndex = 9
ToolTipText = "进度条"
Top = 720
Width = 360
End
Begin VB.CheckBox cmdControls
Appearance = 0 'Flat
Height = 360
Index = 13
Left = 360
Picture = "frmControls.frx":67CC
Style = 1 'Graphical
TabIndex = 8
ToolTipText = "滑块"
Top = 720
Width = 360
End
Begin VB.CheckBox cmdControls
Appearance = 0 'Flat
Height = 360
Index = 14
Left = 720
Picture = "frmControls.frx":6F36
Style = 1 'Graphical
TabIndex = 7
ToolTipText = "热键"
Top = 720
Width = 360
End
Begin VB.CheckBox cmdControls
Appearance = 0 'Flat
Height = 360
Index = 15
Left = 1080
Picture = "frmControls.frx":76A0
Style = 1 'Graphical
TabIndex = 6
ToolTipText = "列表视图"
Top = 720
Width = 360
End
Begin VB.CheckBox cmdControls
Appearance = 0 'Flat
Height = 360
Index = 16
Left = 1440
Picture = "frmControls.frx":7E0A
Style = 1 'Graphical
TabIndex = 5
ToolTipText = "树视图"
Top = 720
Width = 360
End
Begin VB.CheckBox cmdControls
Appearance = 0 'Flat
Height = 360
Index = 17
Left = 1800
Picture = "frmControls.frx":8574
Style = 1 'Graphical
TabIndex = 4
ToolTipText = "选项卡"
Top = 720
Width = 360
End
Begin VB.CheckBox cmdControls
Appearance = 0 'Flat
Height = 360
Index = 18
Left = 0
Picture = "frmControls.frx":8CDE
Style = 1 'Graphical
TabIndex = 3
ToolTipText = "动画"
Top = 1080
Width = 360
End
Begin VB.CheckBox cmdControls
Appearance = 0 'Flat
Height = 360
Index = 20
Left = 720
Picture = "frmControls.frx":9448
Style = 1 'Graphical
TabIndex = 2
ToolTipText = "日期时间选择器"
Top = 1080
Width = 360
End
Begin VB.CheckBox cmdControls
Appearance = 0 'Flat
Height = 360
Index = 21
Left = 1080
Picture = "frmControls.frx":9BB2
Style = 1 'Graphical
TabIndex = 1
ToolTipText = "月历"
Top = 1080
Width = 360
End
Begin VB.CheckBox cmdControls
Height = 360
Index = 22
Left = 1440
Picture = "frmControls.frx":A31C
Style = 1 'Graphical
TabIndex = 0
ToolTipText = "IP地址输入框"
Top = 1080
Width = 360
End
End
Attribute VB_Name = "frmControls"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public LastClickTime As Long '上一次点击的时间
Public LastClickIndex As Long '上一次点击的编号
Public CurrentControlType As Integer '当前即将被创建的控件的类型【0-23】
Public IsDragToCreate As Boolean '是否通过鼠标拖控件
Public cx As Single, cy As Single, _
cW As Single, cH As Single '即将创建的控件的坐标及尺寸
'获取一个可用的控件序号
' 描述：遍历目标窗体里的所有控件，返回指定控件中可以使用的序号，防止控件的序号冲突
'必选参数：ControlType：指定类型的控件
'可选参数：无
' 返回值：指定类型控件可以使用的控件序号
Private Function GetCtlFreeIndex(ControlType As Integer) As Integer
Dim i As PictureBox '遍历的图片框
Dim j As Integer '用来遍历数组的控制循环变量
Dim SplitTemp() As String 'Tag分割缓存
Dim TargetIndex As Integer '当前遍历到的图片框的序号
Dim UsedIndex() As Boolean '当前类型图片框的计数（数组对应序号的元素标记着该序号是否被占用）
ReDim UsedIndex(0) '初始化数组
For Each i In frmTarget.picControlContainer '遍历所有的图片框（即控件的容器）
If i.Index <> 0 And i.Tag <> "" Then '排除掉序号为0的控件（即预先创建的空控件）和Tag为空的控件（即刚刚创建的容器）
SplitTemp = Split(i.Tag, "|") '对目标图片框的Tag进行分割
If SplitTemp(1) = ControlType Then '如果是指定的控件类型
TargetIndex = CInt(SplitTemp(2)) '获得目标图片框的序号
If TargetIndex > UBound(UsedIndex) Then '如果图片框的序号超出数组范围则扩充数组
ReDim Preserve UsedIndex(TargetIndex)
End If
UsedIndex(TargetIndex) = True '数组中有对应的控件序号的元素标记为真
End If
End If
Next i
For j = 1 To UBound(UsedIndex) '遍历数组，找到未标记的控件序号
If UsedIndex(j) = False Then
GetCtlFreeIndex = j '找到未标记的控件序号则返回对应的控件序号
Exit Function
End If
Next j
GetCtlFreeIndex = UBound(UsedIndex) + 1 '如果数组里的所有序号都被标记为真则返回（数组的范围 + 1）
End Function
'创建控件函数
' 描述：用来在指定的母窗体里创建指定的控件
'必选参数：ClassName：控件对应的类名；
' ControlContainer：控件所在的容器（图片框）
'可选参数：Style：控件样式，默认使用(WS_VISIBLE Or WS_CHILD)；
' ExStyle：控件扩展样式；
' WindowName：控件标题；
' 返回值：创建的控件的句柄
Public Function CreateControl(ByVal ClassName As String, ByVal ControlContainer As PictureBox, _
Optional ByVal Style As Long = WS_VISIBLE Or WS_CHILD, _
Optional ByVal ExStyle As Long, Optional ByVal WindowName As String) As Long
Dim cRect As RECT '控件容器的大小
GetWindowRect ControlContainer.hWnd, cRect '获取容器大小
CreateControl = CreateWindowEx(ExStyle, ClassName, WindowName, Style Or WS_VISIBLE Or WS_CHILD, _
0, 0, cRect.Right - cRect.Left, cRect.Bottom - cRect.Top, ControlContainer.hWnd, 0, App.hInstance, 0)
'设置容器的Tag属性为创建的控件的信息 【句柄|类型|此种类型控件计数】
ControlContainer.Tag = CreateControl & "|" & CurrentControlType & "|" & GetCtlFreeIndex(CurrentControlType)
End Function
Private Sub cmdControls_Click(Index As Integer)
If Me.cmdControls(Index).Value = 1 Then '如果是按下状态
frmTarget.IsCreatingControl = True '拖控件状态标记为真
frmTarget.MousePointer = 2 '更换光标图标
Else
frmTarget.IsCreatingControl = False '拖控件状态标记为假
frmTarget.MousePointer = 0 '更换光标图标
End If
End Sub
Public Sub cmdControls_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 Then
Dim i As Integer
For i = 0 To 22 '让凹陷的按钮重新弹起来
If i <> Index Then
Me.cmdControls(i).Value = 0
End If
Next i
'双击条件：
'1) 两次按左键的间隔小于系统设定的双击的时间
'2) 两次按键所在的按钮都是同一个
CurrentControlType = Index '设置当前即将被创建的控件的类型
If (GetTickCount - LastClickTime < GetDoubleClickTime) And (GetTickCount - LastClickTime >= 0) And (LastClickIndex = Index) Then
'双击事件
Dim Container As PictureBox '创建的控件容器
Dim nHwnd As Long '创建的控件的句柄
'创建一个放置控件的容器
'如果是通过鼠标双击拖放的控件
If IsDragToCreate Then
Set Container = frmTarget.NewControlContainer(cx, cy, cW, cH) '按照指定的坐标创建容器
IsDragToCreate = False '切换鼠标拖放控件状态
Else
Set Container = frmTarget.NewControlContainer() '在窗体中心创建容器
End If
Select Case Index
Case 0 '图像
nHwnd = CreateControl("STATIC", Container, SS_BLACKFRAME, WS_EX_NOPARENTNOTIFY)
Case 1 '标签
nHwnd = CreateControl("STATIC", Container, , WS_EX_NOPARENTNOTIFY, "Label")
Case 2 '文本框
nHwnd = CreateControl("EDIT", Container, ES_AUTOHSCROLL, WS_EX_CLIENTEDGE, "")
Case 3 '组框
nHwnd = CreateControl("BUTTON", Container, BS_GROUPBOX, , "Frame")
Case 4 '按钮
nHwnd = CreateControl("BUTTON", Container, , , "Button")
Case 5 '复选框
nHwnd = CreateControl("BUTTON", Container, BS_AUTOCHECKBOX, , "CheckBox")
Case 6 '单选框
nHwnd = CreateControl("BUTTON", Container, BS_AUTORADIOBUTTON, , "Option")
Case 7 '组合框
nHwnd = CreateControl("COMBOBOX", Container, CBS_DROPDOWN Or CBS_HASSTRINGS, _
WS_EX_NOPARENTNOTIFY, "ComboBox")
Case 8 '列表框
nHwnd = CreateControl("LISTBOX", Container, LBS_NOTIFY Or LBS_NOINTEGRALHEIGHT Or LBS_HASSTRINGS, _
WS_EX_NOPARENTNOTIFY Or WS_EX_CLIENTEDGE, "ListBox")
Case 9 '水平
nHwnd = CreateControl("SCROLLBAR", Container, SBS_HORZ)
Case 10 '垂直
nHwnd = CreateControl("SCROLLBAR", Container, SBS_VERT)
Case 11 '上下调节按钮
nHwnd = CreateControl("msctls_updown32", Container)
Case 12 '进度条
nHwnd = CreateControl("msctls_progress32", Container)
Case 13 '滑块
nHwnd = CreateControl("msctls_trackbar32", Container, TBS_AUTOTICKS)
Case 14 '热键
nHwnd = CreateControl("msctls_hotkey32", Container)
Case 15 '列表视图
nHwnd = CreateControl("SysListView32", Container, LVS_REPORT)
Case 16 '树视图
nHwnd = CreateControl("SysTreeView32", Container, WS_BORDER)
Case 17 '选项卡
nHwnd = CreateControl("SysTabControl32", Container)
Case 18 '动画
nHwnd = CreateControl("SysAnimate32", Container)
Case 19 'RTF文本框
nHwnd = CreateControl("RichEdit20A", Container, WS_VSCROLL, WS_EX_CLIENTEDGE)
Case 20 '日期时间选取器
nHwnd = CreateControl("SysDateTimePick32", Container)
Case 21 '月历
nHwnd = CreateControl("SysMonthCal32", Container)
Case 22 'IP地址
nHwnd = CreateControl("SysIPAddress32", Container)
End Select
'--------------------------------------------
Container.Visible = False '强制刷新控件
Container.Visible = True
IsSaved = False '记录当前工程已更改
frmTarget.IsCreatingControl = False '拖控件状态标记为假
frmTarget.MousePointer = 0 '更换光标图标
SetWindowPos nHwnd, 0, 0, 0, _
Container.Width / Screen.TwipsPerPixelX, _
Container.Height / Screen.TwipsPerPixelY, 0 '调整容器内部的控件大小
If Me.cmdControls(Index).Value = 0 Then
Me.cmdControls(Index).Value = 1 '弹起按钮
End If
frmTarget.picControls_MouseDown Container.Index, 1, 0, 0, 0 '拉取控件属性列表
End If
LastClickTime = GetTickCount '记录上一次按按键的时间和编号
LastClickIndex = Index
End If
End Sub
Private Sub Form_Resize()
'自动排版窗体里的按钮
On Error Resume Next
Dim lnMax As Integer
Dim TotalLn As Integer
Dim i As Integer, j As Integer
lnMax = Me.Width \ Me.cmdControls(0).Width '计算每行最多的个数
TotalLn = IIf(23 Mod lnMax = 0, 23 / lnMax, 23 \ lnMax + 1) '计算需要的行数
For i = 0 To TotalLn
For j = 0 To lnMax
If i * lnMax + j < 23 Then '判断有没有超出按钮个数
'排版
Me.cmdControls(i * lnMax + j).Visible = False
Me.cmdControls(i * lnMax + j).Left = Me.cmdControls(0).Width * j
Me.cmdControls(i * lnMax + j).Top = Me.cmdControls(0).Height * i
Me.cmdControls(i * lnMax + j).Visible = True
Else '所有按钮已经排版完毕
Exit For
End If
Next j
Next i
End Sub