VB6实现动态增加和删除控件数组中的控件2021-06-02

           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