Public regKey As String
''**************************************************************************
Sub cmdCreateNewForm()
On Error Resume Next
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim sheetcount As Long
Dim usform As Object, clsModule As Object
Dim c As Integer, r As Integer, iLeft As Integer, iTop As Integer
sheetcount = ThisWorkbook.Worksheets.Count
Dim MyObj
Set usform = ThisWorkbook.VBProject.VBComponents("usfSheetSelect")
ThisWorkbook.VBProject.VBComponents.Remove usform
With ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm)
.Properties("Height") = 340
.Properties("Width") = 520
.Properties("Caption") = "USERFORM WITH SHEET OPTION"
.CodeModule.InsertLines 2, AddCodeInForm
For r = 1 To sheetcount
iTop = Fix(c / 5): iLeft = (c Mod 5)
With .Designer.Add("Forms.OptionButton.1", "Opt" & ThisWorkbook.Worksheets(r).Name)
.Top = 6 + 24 * iTop
.Left = 6 + 102 * iLeft
.Height = 18
.Width = 96
.BackColor = &HFFFF80
.Caption = ThisWorkbook.Worksheets(r).Name
End With
c = c + 1
Next
.Properties("Name") = "usfSheetSelect"
End With
Set clsModule = ThisWorkbook.VBProject.VBComponents("clsControl")
ThisWorkbook.VBProject.VBComponents.Remove clsModule
With ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_ClassModule)
.CodeModule.InsertLines 2, AddCodeInClass
.Properties("Name") = "clsControl"
End With
Set clsModule = Nothing
Set usform = Nothing
ThisWorkbook.Save
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Function AddCodeInForm() As String
AddCodeInForm = _
"Private optArr(1 to " & ThisWorkbook.Worksheets.Count & ") As New clsControl" & vbLf & vbLf & _
"Private Sub UserForm_Initialize()" & vbLf & _
" Dim i As Byte" & vbLf & _
" Dim opt As MSForms.OptionButton" & vbLf & _
" For Each opt In Me.Controls" & vbLf & _
" If TypeName(opt) = " & """OptionButton""" & " Then" & vbLf & _
" i = i + 1" & vbLf & _
" Set optArr(i).OptBttn = opt" & vbLf & _
" End If" & vbLf & _
" Next" & vbLf & _
"End Sub"
End Function
Function AddCodeInClass() As String
AddCodeInClass = _
"Public WithEvents OptBttn As MSForms.OptionButton" & vbLf & vbLf & _
"Private Sub OptBttn_Change()" & vbLf & _
" If OptBttn.Value Then" & vbLf & _
" Sheets(OptBttn.Caption).Select" & vbLf & _
" Unload usfSheetSelect" & vbLf & _
" End If" & vbLf & _
"End Sub"
End Function
