Looking for a more customizable MsgBox.
Some users suggested to others: build a form "on the fly".
I'm trying to add a form and it's code programmatically from my VBA Sub BuildFrmOnTheFly.
My form is shown, but suddenly disappears.
It remains open 10/secs, maybe 100/secs.
No errors.
In VBE the form exists and if I run it from project browser, all is OK. The form remains open till I click on OK (Unload form) or close it from the X.
I got Windows 11 x64, Office 2021 x32. I'm working in my PERSONALS.XLSB so my "custom MsgBox" is enabled in all my other XLSM files. I declared a Public Sub for the same reason.
Option Explicit
Public Sub BuildFrmOnTheFly(ByVal strFrmTitle As String, ByVal strFrmTxt As String)
' GestErr.
On Error GoTo GesErr
Dim VBComp As Object
Dim frmZZZ As Object
Dim txtZZZ As MSForms.TextBox
Dim btnZZZ As MSForms.CommandButton
' If a FORM named frmZZZ exist, delete!
For Each VBComp In ThisWorkbook.VBProject.VBComponents
With VBComp
If .Type = 3 Then
If .Name = "frmZZZ" Then
ThisWorkbook.VBProject.VBComponents.Remove ThisWorkbook.VBProject.VBComponents("frmZZZ")
End If
End If
End With
Next VBComp
' Save file if isn't.
If Application.Workbooks("PERSONAL.XLSB").Saved = False Then
Application.DisplayAlerts = False
Application.Workbooks("PERSONAL.XLSB").Save
Application.DisplayAlerts = True
End If
' Hide VBE win.
Application.VBE.MainWindow.Visible = False
' Add and build Form frmZZZ.
Set frmZZZ = ThisWorkbook.VBProject.VBComponents.Add(3)
With frmZZZ
.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
' Build TextBox txtZZZ.
Set txtZZZ = frmZZZ.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
' Build Button btnZZZ (OK)
Set btnZZZ = frmZZZ.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
' Add module to the Form.
With frmZZZ.CodeModule
' Initialize Form.
.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) - (frmZZZ.Height / 2)"
.InsertLines .CountOfLines + 1, " LeftOffset = (Application.UsableWidth / 2) - (frmZZZ.Width / 2)"
.InsertLines .CountOfLines + 1, " frmZZZ.Top = Application.Top + TopOffset"
.InsertLines .CountOfLines + 1, " frmZZZ.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 = (frmZZZ.InsideWidth - txtZZZ.Width) / 2"
.InsertLines .CountOfLines + 1, " btnZZZ.Left = (frmZZZ.InsideWidth - btnZZZ.Width) / 2"
.InsertLines .CountOfLines + 1, "End Sub"
' Terminate Form.
.InsertLines .CountOfLines + 1, "Private Sub UserForm_Terminate()"
' Remove Form from VBA Proj.
.InsertLines .CountOfLines + 1, " ThisWorkbook.VBProject.VBComponents.Remove ThisWorkbook.VBProject.VBComponents(""frmZZZ"")"
.InsertLines .CountOfLines + 1, " Application.VBE.MainWindow.Visible = True"
.InsertLines .CountOfLines + 1, "End Sub"
' Btn OK close Form.
.InsertLines .CountOfLines + 1, "Private Sub btnZZZ_Click()"
.InsertLines .CountOfLines + 1, " Unload Me"
.InsertLines .CountOfLines + 1, "End Sub"
End With
' Add Form frmZZZ and show it.
Set frmZZZ = VBA.UserForms.Add("frmZZZ")
frmZZZ.Show
' Exit sub, before empty vars.
Uscita: strFrmTitle = Empty
strFrmTxt = Empty
Set btnZZZ = Nothing
Set txtZZZ = Nothing
Set frmZZZ = Nothing
Exit Sub
' If error comes.
GesErr: MsgBox "Error in Sub" & vbCrLf & "'BuildFrmOnTheFly'" & vbCrLf & vbCrLf & Err.Description
Resume Uscita
' End.
End Sub
How I call it:
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
Problem seems to be when I start filling
With frZZZ.CodeModule
....
End With
Already a simple Button like btnZZZ gives me the problem.
.InsertLines .CountOfLines + 1, "Private Sub btnZZZ_Click()"
.InsertLines .CountOfLines + 1, " Unload Me"
.InsertLines .CountOfLines + 1, "End Sub"
After show, add the parameter VBModal
frmZZZ.Show vbModal