VBA动态生成的自定义MsgBox表单几秒后自动消失求助

问题现象 #

通过BuildFrmOnTheFly过程动态创建无模态UserForm，窗体显示后数秒自动消失且无报错；但从VBE项目浏览器直接运行窗体则可正常留存，直到点击OK按钮卸载或关闭窗口。运行环境为Windows 11 x64、Office 2021 x32，代码存放于PERSONAL.XLSB中，用于在所有XLSM文件中启用自定义MsgBox功能。

问题原因 #

无模态UserForm的显示不会阻塞代码执行，BuildFrmOnTheFly过程结束后，局部变量frmZZZ被执行Set frmZZZ = Nothing释放，导致窗体失去对象引用，系统自动销毁窗体。而从VBE运行时，VBE会持有窗体的引用，因此不会自动关闭。此外，UserForm_Terminate事件中直接删除窗体组件的操作也可能引发意外冲突。

解决方案 #

1. 将frmZZZ声明为模块级变量，确保过程结束后仍持有窗体引用；
2. 调整UserForm_Terminate中的组件删除逻辑，添加错误处理避免冲突；
3. 在窗体初始化事件中改用Me引用当前窗体，避免硬编码问题；
4. 优化窗体查找循环，提升执行效率。

修改后的代码 #

模块级变量声明（放置在模块最顶部）

Option Explicit
Private frmZZZ As Object ' 模块级变量，持续持有窗体引用

动态创建表单的核心代码

Public Sub BuildFrmOnTheFly(ByVal strFrmTitle As String, ByVal strFrmTxt As String)
    On Error GoTo GesErr

    Dim VBComp As Object
    Dim txtZZZ As MSForms.TextBox
    Dim btnZZZ As MSForms.CommandButton
    
    ' 删除已存在的frmZZZ窗体
    For Each VBComp In ThisWorkbook.VBProject.VBComponents
        If VBComp.Type = 3 And VBComp.Name = "frmZZZ" Then
            ThisWorkbook.VBProject.VBComponents.Remove VBComp
            Exit For ' 找到目标后立即退出循环，提升效率
        End If
    Next VBComp
    
    ' 保存PERSONAL.XLSB
    If Not Application.Workbooks("PERSONAL.XLSB").Saved Then
        Application.DisplayAlerts = False
        Application.Workbooks("PERSONAL.XLSB").Save
        Application.DisplayAlerts = True
    End If

    Application.VBE.MainWindow.Visible = False

    ' 创建新窗体
    Set VBComp = ThisWorkbook.VBProject.VBComponents.Add(3)
    With VBComp
        .Properties("BackColor") = RGB(255, 255, 255)
        .Properties("BorderColor") = RGB(64, 64, 64)
        .Properties("Caption") = strFrmTitle
        .Properties("Height") = 150
        .Properties("Name") = "frmZZZ"
        .Properties("ShowModal") = False
        .Properties("Width") = 501
    End With

    ' 添加文本框控件
    Set txtZZZ = VBComp.Designer.Controls.Add("Forms.TextBox.1")
    With txtZZZ
        .Name = "txtZZZ"
        .BorderStyle = fmBorderStyleNone
        .BorderColor = RGB(169, 169, 169)
        .Font.Name = "Calibri"
        .Font.Size = 12
        .ForeColor = RGB(70, 70, 70)
        .SpecialEffect = fmSpecialEffectFlat
        .MultiLine = True
        .Left = 0
        .Top = 10
        .Height = 75
        .Width = 490
        .Text = strFrmTxt
    End With

    ' 添加OK按钮控件
    Set btnZZZ = VBComp.Designer.Controls.Add("Forms.commandbutton.1")
    With btnZZZ
        .Name = "btnZZZ"
        .Caption = "OK"
        .Accelerator = "M"
        .Top = 90
        .Left = 0
        .Width = 70
        .Height = 20
        .Font.Size = 12
        .Font.Name = "Calibri"
        .BackStyle = fmBackStyleOpaque
    End With
    
    ' 写入窗体事件代码
    With VBComp.CodeModule
        ' 窗体初始化事件
        .InsertLines .CountOfLines + 1, "Private Sub UserForm_Initialize()"
        .InsertLines .CountOfLines + 1, "    Dim TopOffset As Integer"
        .InsertLines .CountOfLines + 1, "    Dim LeftOffset As Integer"
        .InsertLines .CountOfLines + 1, "    TopOffset = (Application.UsableHeight / 2) - (Me.Height / 2)"
        .InsertLines .CountOfLines + 1, "    LeftOffset = (Application.UsableWidth / 2) - (Me.Width / 2)"
        .InsertLines .CountOfLines + 1, "    Me.Top = Application.Top + TopOffset"
        .InsertLines .CountOfLines + 1, "    Me.Left = Application.Left + LeftOffset"
        .InsertLines .CountOfLines + 1, "    txtZZZ.WordWrap = True"
        .InsertLines .CountOfLines + 1, "    txtZZZ.MultiLine = True"
        .InsertLines .CountOfLines + 1, "    txtZZZ.Font.Size = 12"
        .InsertLines .CountOfLines + 1, "    txtZZZ.Left = (Me.InsideWidth - txtZZZ.Width) / 2"
        .InsertLines .CountOfLines + 1, "    btnZZZ.Left = (Me.InsideWidth - btnZZZ.Width) / 2"
        .InsertLines .CountOfLines + 1, "End Sub"

        ' OK按钮点击事件
        .InsertLines .CountOfLines + 1, "Private Sub btnZZZ_Click()"
        .InsertLines .CountOfLines + 1, "    Unload Me"
        .InsertLines .CountOfLines + 1, "End Sub"

        ' 窗体终止事件
        .InsertLines .CountOfLines + 1, "Private Sub UserForm_Terminate()"
        .InsertLines .CountOfLines + 1, "    Application.VBE.MainWindow.Visible = True"
        .InsertLines .CountOfLines + 1, "    ' 添加错误处理，避免删除组件时的异常"
        .InsertLines .CountOfLines + 1, "    On Error Resume Next"
        .InsertLines .CountOfLines + 1, "    ThisWorkbook.VBProject.VBComponents.Remove ThisWorkbook.VBProject.VBComponents(""frmZZZ"")"
        .InsertLines .CountOfLines + 1, "    On Error GoTo 0"
        .InsertLines .CountOfLines + 1, "End Sub"
    End With
    
    ' 显示窗体，通过模块级变量持有引用
    Set frmZZZ = VBA.UserForms.Add("frmZZZ")
    frmZZZ.Show
    
Uscita:
    ' 不释放模块级变量frmZZZ，避免窗体失去引用被销毁
    strFrmTitle = Empty
    strFrmTxt = Empty
    Set btnZZZ = Nothing
    Set txtZZZ = Nothing
    Set VBComp = Nothing
    Exit Sub
    
GesErr:
    MsgBox "Error in Sub" & vbCrLf & "'BuildFrmOnTheFly'" & vbCrLf & vbCrLf & Err.Description
    Resume Uscita
End Sub

调用代码（保持不变）

Option Explicit
Sub TryBuildFrmOnTheFly()
    Dim strText As String
    strText = "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut MQ" '95 chars
    Call BuildFrmOnTheFly("This is the form title", strText)
End Sub

关键修改说明 #

• 模块级变量持有引用：将frmZZZ声明为模块级，过程结束后不会被销毁，确保无模态窗体持续存在；
• 改用Me引用窗体：在初始化事件中用Me代替硬编码的窗体名称，避免引用错误；
• 优化组件删除逻辑：在终止事件中添加错误处理，防止删除组件时的异常导致窗体提前关闭；
• 循环效率优化：删除窗体时找到目标后立即退出循环，减少不必要的遍历。

内容的提问来源于stack exchange，提问作者Emanuele Tinari