VB6实现动态增加和删除控件数组中的控件
2021-6-3修改一个BUG
控件的添加:
1From1名称改为FrmWork
2.添加Picture控件名称改为PicCharacterContainer
3.添加Picture控件名称改为PicShow放入PicCharacterContainer中,设置成控件数组
4.添加Text控件名称改为TxtShow放入PicCharacterContainer中,设置成控件数组
操作:在PicCharacterContainer中鼠标左键添加控件,鼠标右键去除控件(可以点选指定控件)。
代码:
Option Explicit
Dim S1GlngMaxCharactor As Long
Dim ChoiceRemove As Long '选择角色移除对象
Private Sub CmdAdd()
Dim i As Long, n As Long
Dim MaxCharactor As Long
MaxCharactor = 100 '最大控件数
For i = 1 To MaxCharactor
If fChkControls(FrmWork, "PicShow", i) = True Then '控件存在
n = n + 1
End If
Next i
S1GlngMaxCharactor = n + 1
For i = 1 To MaxCharactor
If fChkControls(FrmWork, "PicShow", i) = False Then '控件不存在
AddCharactor i '增加Picture控件
AddCharactorNotice i '增加Text控件
PublicNewArrangeAdd S1GlngMaxCharactor, "PicShow", FrmWork, FrmWork.PicShow '在缺失位置增加控件
PublicNewArrangeAdd S1GlngMaxCharactor, "TxtShow", FrmWork, FrmWork.TxtShow '在缺失位置增加控件
AlignBoxes '对齐控件
TxtShow(i).Text = i '显示控件数组编号
Exit For
End If
Next i
End Sub
Private Sub CmdRemove()
Dim n As Long, i As Long
If ChoiceRemove <> 0 Then
Unload PicShow(ChoiceRemove)
Unload TxtShow(ChoiceRemove)
ChoiceRemove = 0
Else
If S1GlngMaxCharactor >= 1 Then
For i = 1 To 100
If fChkControls(FrmWork, "PicShow", i) = True Then '存在 '2020-8-22修改为True
n = i '找到未删除最大编号
End If
Next i
If n = 0 Then
S1GlngMaxCharactor = S1GlngMaxCharactor - 1
MsgBox "最初控件不能移除"
Exit Sub
End If
Unload PicShow(n)
Unload TxtShow(n)
S1GlngMaxCharactor = S1GlngMaxCharactor - 1
Else
MsgBox "最初控件不能移除"
End If
End If
End Sub
Private Sub PicCharacterContainer_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
CmdAdd
End If
If Button = 2 Then
CmdRemove
End If
End Sub
Rem 判断控件是否存在
Function fChkControls(frmObject As Form, strControlsName As String, ByVal lngIndex As Long) As Boolean
On Error GoTo Err
Dim strContrName As String
If lngIndex >= 0 Then
strContrName = frmObject.Controls(strControlsName)(lngIndex).Name
Else
strContrName = frmObject.Controls(strControlsName).Name
End If
fChkControls = True
Exit Function
Err:
fChkControls = False
End Function
Rem 增加控件
Public Sub AddCharactor(ByVal n As Long)
Dim RowNum As Long
Dim Row As Long, Line As Long
Load FrmWork.PicShow(n)
Set FrmWork.PicShow(n).Container = FrmWork.PicCharacterContainer
RowNum = Int(FrmWork.PicCharacterContainer.Width / FrmWork.PicShow(0).Width) '一排容纳多少控件
If n - 1 >= 0 Then
Line = Int(n / RowNum) + 1 '控件所处行号
Row = (n + 1) - (Line - 1) * RowNum '控件所处列号
FrmWork.PicShow(n).Left = FrmWork.PicShow(0).Left + (Row - 1) * FrmWork.PicShow(n).Width
FrmWork.PicShow(n).Top = FrmWork.PicShow(0).Top + (Line - 1) * (FrmWork.PicShow(n).Height + FrmWork.TxtShow(0).Height)
FrmWork.PicShow(n).Visible = True
End If
End Sub
Rem 增加文字控件
Public Sub AddCharactorNotice(ByVal n As Long)
Load FrmWork.TxtShow(n)
Set FrmWork.TxtShow(n).Container = FrmWork.PicCharacterContainer
If n - 1 >= 0 Then
FrmWork.TxtShow(n).Left = FrmWork.PicShow(n).Left
FrmWork.TxtShow(n).Top = FrmWork.PicShow(n).Top
FrmWork.TxtShow(n).Visible = True
End If
End Sub
Rem MaxNumber 最大数量
Rem ControlBoxName 控件名称
Rem From 工作界面
Rem ControlBox 控件:例子From.PicShow
Public Sub PublicNewArrangeAdd(ByVal MaxNumber As Long, ByVal ControlBoxName As String, _
ByRef From As Object, ByRef ControlBox As Object)
Dim i As Long, l As Long, A As Variant, B As Variant
For l = 1 To MaxNumber
For i = 1 To MaxNumber
If fChkControls(From, ControlBoxName, i) = True And fChkControls(From, ControlBoxName, i + l) = True Then
If ControlBox(i).Left > ControlBox(i + l).Left Then
If ControlBox(i).Top = ControlBox(i + l).Top Then '2021-6-2增加,作用是同行才交换位置
A = ControlBox(i + l).Left
B = ControlBox(i).Left
ControlBox(i + l).Left = B
ControlBox(i).Left = A
End If
End If
End If
Next i
Next l
End Sub
Public Sub AlignBoxes()
Dim i As Long
On Error Resume Next '防止控件没有出错
For i = 1 To S1GlngMaxCharactor
FrmWork.TxtShow(i).Left = FrmWork.PicShow(i).Left
FrmWork.TxtShow(i).Top = FrmWork.PicShow(i).Top + FrmWork.PicShow(i).Height
Next i
End Sub
Private Sub PicShow_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then
ChoiceRemove = Index
CmdRemove
End If
If Button = 1 Then
CmdAdd
End If
End Sub