Sub CallNewForm()
ThisWorkbook.Save
Application.VBE.MainWindow.Visible = False
Call CreateUF
Call CreateCode
Call ShowUf
End Sub
Private Sub CreateUF()
Dim uf As Object
Dim cmd As MSForms.CommandButton
Dim chb As MSForms.CheckBox
Dim iRow As Integer, iTop As Integer
iRow = 1
iTop = 10
Set uf = ThisWorkbook.VBProject.VBComponents.Add(3)
Do Until IsEmpty(Cells(iRow, 1))
Set chb = uf.designer.Controls.Add("Forms.CheckBox.1")
With chb
.Top = iTop
.Left = 5
.Width = 100
.Height = 15
.Caption = Cells(iRow, 1).Value
End With
iTop = iTop + 20
iRow = iRow + 1
Loop
Set cmd = uf.designer.Controls.Add("Forms.CommandButton.1")
With cmd
.Caption = "OK"
.Accelerator = "o"
.Width = 100
.Height = 25
.Left = 110
.Top = 10
.Name = "cmdOK"
End With
With uf
.Properties("Name") = "frmDogs"
.Properties("Caption") = "Treffen Sie Ihre Auswahl:"
.Properties("Width") = 230
.Properties("Height") = iTop + 20
End With
End Sub
Private Sub CreateCode()
Dim iRow As Integer
Dim sCode As String
With ThisWorkbook.VBProject.VBComponents("frmDogs").CodeModule
.CreateEventProc "Click", "cmdOK"
iRow = .ProcBodyLine("cmdOK_Click", 0)
sCode = " Dim iRow as Integer" & vbLf
sCode = sCode & " For iRow = 0 to " & _
Range("A1").CurrentRegion.Rows.Count - 1 & vbLf
sCode = sCode & " If Controls(""CheckBox"" & iRow + 1)" & _
".Value = True Then" & vbLf
sCode = sCode & " Cells(iRow + 1, 1)" & _
".Interior.ColorIndex = 6" & vbLf
sCode = sCode & " End If" & vbLf
sCode = sCode & " Next iRow" & vbLf
sCode = sCode & " Unload Me" & vbLf
.InsertLines iRow + 1, sCode
End With
End Sub
Private Sub ShowUf()
Columns(1).Interior.ColorIndex = xlColorIndexNone
frmDogs.Show
With ThisWorkbook.VBProject
.VBComponents.Remove .VBComponents("frmDogs")
End With
End Sub