VBA自动创建窗体及控件

lss001

Sub VBAzdcjct() 'VBA自动创建窗体及控件
    Dim Usm As Object'声明窗体
    Set Usm = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm)t '创建窗体
    On Error Resume Next '忽略错误代码
    With Usm
        '由于该窗体还未运行，相当于处于设计状态
        '对于该窗体的属性，则需要用Properties属性
        .Properties("Caption") = "自动创建窗体" '窗体命名
        .Properties("Height") = 350 '窗体高度
        .Properties("Width") = 400 '窗体宽度
        With .Designer
        '要在该窗体上创建控件对象，则需要用Designer属性
            For j = 1 To 2 '创建标签对象，可循环创建
                Set Lal = .Controls.Add("Forms.Label.1")
                '*特别注意创建任何控件对象应加上.1
                With Lal '设置Label标签属性
                    .Top = 12 + 18 * (j - 1) '标签与窗体上边框距离
                    .Left = 18 '标签与窗体左边框距离
                    .Height = 12 '标签高度
                    .Width = 110 '标签宽度
                    .Caption = j '标签命名
                    .Font.Size = 11 '字体大小
                    .ForeColor = 0 '标签前景(字体)颜色
                    .BackColor = 14136213 '标签背景颜色
                    '其它设置可按照以上添加
                End With
            Next
            Set Lix = .Controls.Add("Forms.ListBox.1")
            '创建ListBox对象
        End With
        With .CodeModule
        '设置ListBox控件关联事件代码，则需要用CodeModule属性
            .DeleteLines 1, .CountOfLines
            '以下双引号中的代码即为ListBox控件关联事件代码
            .InsertLines 1, "Private Sub UserForm_Initialize()"
            .InsertLines 2, "Dim arr()"
            .InsertLines 3, "arr = Range(""A2:G"" & Cells(Rows.Count, 1).End(xlUp).Row)"
            .InsertLines 4, "    With ListBox1"
            .InsertLines 5, "        .Top = 50"
            .InsertLines 6, "        .Left = 50"
            .InsertLines 7, "        .Height = 250"
            .InsertLines 8, "        .Width = 300"
            .InsertLines 9, "        .ColumnCount = 7"
            .InsertLines 10, "       .ColumnWidths = ""35,45,45,45,45,40,50"""
            .InsertLines 11, "       .BoundColumn = 1"
            .InsertLines 12, "       .ColumnHeads = True"
            .InsertLines 13, "       .TextAlign = 1"
            .InsertLines 14, "       .List = arr"
            .InsertLines 15, "    End With"
            .InsertLines 16, "End Sub"
            
            .InsertLines 17, "Private Sub ListBox1_Click()"
            .InsertLines 18, "    Dim r As Integer"
            .InsertLines 19, "    Dim i As Integer"
            .InsertLines 20, "    With Sheet1"
            .InsertLines 21, "    r = .Cells(.Rows.Count, 1).End(xlUp).Row + 1"
            .InsertLines 22, "        For i = 1 To ListBox1.ColumnCount"
            .InsertLines 23, "            .Cells(r, i) = ListBox1.Column(i - 1)"
            .InsertLines 24, "        Next"
            .InsertLines 25, "    End With"
            .InsertLines 26, "End Sub"
        End With
    End With
    On Error GoTo 0 '关闭错误处理
    VBA.UserForms.Add(Usm.Name).Show  '加载并显示该窗体，注意与平时加载不同ThisWorkbook.VBProject.VBComponents.Remove Usm  '窗体运行完后自动删除
End Sub
   

王跃峰

Set Usm = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm)t '创建窗体         这句话错误

lss001

王跃峰 发表于 2022-2-2 11:26
Set Usm = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm)t '创建窗体         这句话错误

更正→
Set Usm = ThisWorkbook.VBProject.VBComponents.Add(3)