Looking for a more customizable MsgBox, I read some users that suggested to others with my same problem: build a form "on the fly"! Well. That's what I do.
Unfortenately my code run, my form's shown, but suddently disappear.Only fews 10/secs, maybe 100/secs remains open.No errors.In VBE form exist and if I run it from project browser, all is ok, form remain open till I click on OK (Unload form) or close it from the X.I don't understand why.I got Windows 11 x64, Office 2021 x32. I'm working in my PERSONALS.XLSB so my "custom MsgBox" is enabled in all my others XLSM; I declared a Public Sub for the same reason.Here's my code:
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
And here is 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
.InsertLines .CountOfLines + 1, "Private Sub btnZZZ_Click()"
.InsertLines .CountOfLines + 1, " Unload Me"
.InsertLines .CountOfLines + 1, "End Sub"
Give me the problem.I've already read post like this or this, but nothing to do. Wait for You, more experts than me, thanks in advance.
Related
I'm having issues trying to programmatically add items to a
Form.Designer.Controls.Add("Forms.ListBox.1")
I've tried using the method
Form.Designer.Controls.Add("Forms.ComboBox.1").AddItem "Item"
And while this doesn't return a debug error, the item also doesn't appear in the form.
Here is the full class module, from which I use the method AddList()
https://github.com/thorlindberg/thorlindberg/blob/main/programmatic-userform/UserInterface.bas
And here is the macro that calls it to generate the Form
https://github.com/thorlindberg/thorlindberg/blob/main/programmatic-userform/Example.bas
As I said in my above comment, you cannot add items using FormDesigner in the way you try. But you can write in (the same) code the UserForm_Initialize event, able to add the necessary items:
Sub createUserFormListBoxWithItems()
Dim frm As Object
Set frm = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm) '3
With frm
.Properties("Caption") = "MyTestForm"
.Properties("Width") = 300
.Properties("Height") = 200
.Properties("Name") = "frmLBTest"
End With
With frm.Designer.Controls.Add("Forms.ListBox.1")
.Name = "MyListB"
.top = frm.Properties("Height") - 150
.left = 10: .width = 100: .height = 50
End With
Dim i As Long, myItem As String
frm.CodeModule.InsertLines 2, "Private Sub UserForm_Initialize()" '2 for the case of automatically inserting of Option Explicit
myItem = "MyItem"
For i = 3 To 5
frm.CodeModule.InsertLines i, " Me.Controls(""MyListB"").AddItem """ & myItem & i & """"
Next i
frm.CodeModule.InsertLines i, "End Sub"
VBA.UserForms.Add(frm.Name).Show
End Sub
If you try playing with the code more than once, VBA does not accept the same UserForm name, even if you delete it before running the code. It remains somewhere in Excel as a used name. When I play with such forms creation I am using a function which previously change the form name and Remove it from the project only after that. For instance, the next piece of code will use the list box list property to load items using an array. It will have a line calling the above mentioned function:
Sub createUserFormListBoxWithItems_2()
Dim frm As Object
removeForm "frmLBTest"
Set frm = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm) '3
With frm
.Properties("Caption") = "MyTestForm"
.Properties("Width") = 300
.Properties("Height") = 200
.Properties("Name") = "frmLBTest"
End With
With frm.Designer.Controls.Add("Forms.ListBox.1")
.Name = "MyListB"
.top = frm.Properties("Height") - 150
.left = 10: .width = 100: .height = 50
End With
With frm.CodeModule
.InsertLines 2, "Private arrItems" '2 for the case of automatically inserting of Option Explicit
.InsertLines 3, "Private Sub UserForm_Initialize()"
.InsertLines 4, " arrItems = Split(""Apple,Banana,Clementine"", "","")"
.InsertLines 5, " Me.Controls(""MyListB"").list = arrItems"
.InsertLines 6, "End Sub"
End With
VBA.UserForms.Add(frm.Name).Show
End Sub
Sub removeForm(frmName As String)
Dim i As Long, strName As String
If Not formExists(frmName) Then Exit Sub
strName = "TestName"
tryAgain:
On Error Resume Next
frm.Name = strName
If err.Number = 75 Then 'a previously used name...
err.Clear 'clear the error
strName = strName & i: i = i + 1 'increment the new string
frm.Name = strName: GoTo tryAgain 'test the new name again
End If
On Error GoTo 0
ThisWorkbook.VBProject.VBComponents.Remove frm
End Sub
I am using the WorkBook_NewSheet event to add a worksheet. Here is my event code
...
Private Sub thisWbk_NewSheet(ByVal Sh As Object)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If SkipWBEvent = True Then Exit Sub
If TypeOf Sh Is Worksheet Then
Set oWks = Sh
End If
Dim objEvents As EventsObject
Dim WBEvents As EventsWB
RaiseEvent objSender.GetEvents(objEvents)
Set WBEvents = objEvents.WBEvents
RaiseEvent WBEvents.WBNewSheet(oWks)
Application.ScreenUpdating = True
With New WSModuleCode
.LoadModuleCode oWks
End With
End Sub
...
The code runs as expected and another worksheet is added. The process also performs some formatting and column width changes. When LoadModuleCode is called, the code I need to run a SelectionChange is added to the worksheet module.
...
Public Sub LoadModuleCode(ByRef Wks As Worksheet)
Dim VBComp As VBIDE.VBComponent
Dim SheetMod As CodeModule
With ActiveWbk.VBProject
Set VBComp = .VBComponents(Wks.CodeName)
End With
Set SheetMod = VBComp.CodeModule
With SheetMod
If .CountOfDeclarationLines <= 2 Then
SheetCode SheetMod, Wks
End If
End With
End Sub
Private Sub SheetCode(ByRef SheetMod As CodeModule, ByRef Wks As Worksheet)
Dim ProcString As String
Dim l As Long
Dim EnumSheet As SheetEnum
Const A As String = "SheetModuleCode"
On Error GoTo EH
TryAgain:
EnumSheet = SourceTyper.SheetType(Wks)
Const SChArgs As String = "(ByVal Target As Range)"
Const ConName = "WorkSheet"
Select Case EnumSheet
Case MainSheet, VSELSheet
ProcString = "Private Sub " & ConName & "_SelectionChange" & SChArgs
Case Else
'For expansion?
End Select
With SheetMod
l = .CountOfLines
.InsertLines l + 1, ProcString
.InsertLines l + 2, ""
.InsertLines l + 3, "Dim oWks As Worksheet"
.InsertLines l + 4, "Dim objController As Controller"
.InsertLines l + 5, ""
.InsertLines l + 6, "If SkipWSEvent = True Then Exit Sub"
.InsertLines l + 7, ""
.InsertLines l + 8, "Set oWks = Target.Parent"
.InsertLines l + 9, "Set objController = TheController"
.InsertLines l + 10, ""
.InsertLines l + 11, "If Not objController.ActiveParent Is oWks Then"
.InsertLines l + 12, "objController.InitializeSources oWks"
.InsertLines l + 13, "End If"
.InsertLines l + 14, ""
.InsertLines l + 15, "SkipControlEvent = False"
.InsertLines l + 16, "SkipWSEvent = False"
.InsertLines l + 17, "Application.EnableEvents = True"
.InsertLines l + 18, ""
.InsertLines l + 19, "End Sub"
End With
Exit Sub
EH:
MsgBox Application.VBE.ActiveCodePane.CodeModule.Name & " " & A
MsgBox "Error Line: " & Erl & vbCrLf & vbCrLf & _
"Error: (" & Err.Number & ") " & Err.Description, vbCritical
Application.Wait Now + TimeValue("00:00:01")
GoTo TryAgain
End Sub
...
Immediately after this code is run, the WorkSheet_SelectionChange event header and code is added to the worksheet module. However, at that point, all code execution ceases and all objects, anywhere in the project, no matter when they were made, are all killed. This interrupts the column sizing and final formatting, even though the problem code is run at the very end.
Because the new sheets are added dynamically, I cannot hard-write the code I need in the added sheet module. My workaround may be to run the LoadModuleCode on the next sheet selection event. It will still kill all my objects but once the code is added, the event will remake everything. This will mean an extra sheet click before everything is back to normal. Is there a way to hide my objects from the compiler when it recompiles the module code? Thank You
My Workaround
I found a satisfactory workaround for my specific issue. I moved the With block that adds the WSModuleCode from the Workbook_NewSheet event so that it now runs at the end of the button click event which initiates the new sheet addition. So, the new sheet gets added and this code gets added to the sheet module, which kills all the objects. But, this code allows the next Worksheet_SelectionChange event for the sheet to recreate them.
Is there a way to do global error handling?
Can I put some code in the Workbook code that will catch any errors that occur within all modules?
I could put the same error handler in each module but I'm looking for something more general.
I ask because I have sheet names that are stored as global variables like this Sheets(QuoteName). If there is an error then these global variables are lost. I have a macro that will rename the global variables but I put this within Workbook_BeforeSave.
I want it to go to the global error handler and rename the global variable if I get a Subscript out of range error for Sheets(QuoteName)
As Sid already mentioned in the comment, there is no central error handler.
Best practice is to have a central error handling routine that gets called from the local error handlers. Take a look at the great MZ-Tools: it has the possibility to define a default error handler at the press of a button (Ctrl-E). You can customize this error handler - and it can also contain module and/or sub name!
Additionally, check out this post at Daily Dose of Excel. It is Dick Kusleika's OO version of the error handler proposed in this book (which I can highly recommend).
Here's some code I threw together to handle the problem in access
It puts error checking in all subs, but not functions. subs have to have a parent form (ACCESS), or alternatively, you have to put the form name in manually. subs that are continued over more than one line will be mercilessly whacked.
The two subs have to be at the bottom of a module.
globalerror is your error management routine
CleaVBA_click changes your VBA code, adds line #s to everything
globalerror looks at a boolean global errortracking to see if it logs everything or only errors
There is a table ErrorTracking that has to be created otherwise just comment out from 1990 to 2160
When running, it removes then adds line numbers to everything in the project, so your error message can include a line #
Not sure if it works on anything other than stuff I've coded.
Be sure to run and test on a copy of your VBA, because it literally rewrites every line of code in your project, and if I screwed up, and you didn't back up, then your project is broken.
Public Sub globalerror(Name As String, number As Integer, Description As String, source As String)
1970 Dim db As DAO.Database
1980 Dim rst As DAO.Recordset
1990 If errortracking Or (Err.number <> 0) Then
2000 Set db = CurrentDb
2010 Set rst = db.OpenRecordset("ErrorTracking")
2020 rst.AddNew
2030 rst.Fields("FormModule") = Name
2040 rst.Fields("ErrorNumber") = number
2050 rst.Fields("Description") = Description
2060 rst.Fields("Source") = source
2070 rst.Fields("timestamp") = Now()
2080 rst.Fields("Line") = Erl
2100 rst.Update
2110 rst.Close
2120 db.Close
2130 End If
2140 If Err.number = 0 Then
2150 Exit Sub
2160 End If
2170 MsgBox "ERROR" & vbCrLf & "Location: " & Name & vbCrLf & "Line: " & Erl & vbCrLf & "Number: " & number & vbCrLf & "Description: " & Description & vbCrLf & source & vbCrLf & Now() & vbCrLf & vbCrLf & "custom message"
2180 End Sub
Private Sub CleanVBA_Click()
Dim linekill As Integer
Dim component As Object
Dim index As Integer
Dim str As String
Dim str2a As String
Dim linenumber As Integer
Dim doline As Boolean
Dim skipline As Boolean
Dim selectflag As Boolean
Dim numstring() As String
skipline = False
selectflag = False
tabcounter = 0
For Each component In Application.VBE.ActiveVBProject.VBComponents
linekill = component.CodeModule.CountOfLines
linenumber = 0
For i = 1 To linekill
str = component.CodeModule.Lines(i, 1)
doline = True
If Right(Trim(str), 1) = "_" Then
doline = False
skipline = True
End If
If Len(Trim(str)) = 0 Then
doline = False
End If
If InStr(Trim(str), "'") = 1 Then
doline = False
End If
If selectflag Then
doline = False
End If
If InStr(str, "Select Case") > 0 Then
selectflag = True
End If
If InStr(str, "End Select") > 0 Then
selectflag = False
End If
If InStr(str, "Global ") > 0 Then
doline = False
End If
If InStr(str, "Sub ") > 0 Then
doline = False
End If
If InStr(str, "Option ") > 0 Then
doline = False
End If
If InStr(str, "Function ") > 0 Then
doline = False
End If
If (InStr(str, "Sub ") > 0) Then
If InStr(component.CodeModule.Lines(i + 1, 1), "On Error GoTo error") <> 0 Then
GoTo skipsub
End If
str2a = component.CodeModule.Name
index = InStr(str, "Sub ") ' sub
str = Right(str, Len(str) - index - 3) ' sub
' index = InStr(str, "Function ") ' function
' str = Right(str, Len(str) - index - 8) 'function
index = InStr(str, "(")
str = Left(str, index - 1)
varReturn = SysCmd(acSysCmdSetStatus, "Editing: " & str2a & " : " & str)
DoEvents
If (str = "CleanVBA_Click") Then
MsgBox "skipping self"
GoTo selfie
End If
If str = "globalerror" Then
MsgBox "skipping globalerror"
GoTo skipsub
End If
component.CodeModule.InsertLines i + 1, "On Error GoTo error"
i = i + 1
linekill = linekill + 1
component.CodeModule.InsertLines i + 1, "error:"
i = i + 1
linekill = linekill + 1
component.CodeModule.InsertLines i + 1, "Call globalerror(Me.Form.Name & """ & "-" & str & """, Err.number, Err.description, Err.source)"
i = i + 1
linekill = linekill + 1
component.CodeModule.InsertLines i + 1, " "
i = i + 1
linekill = linekill + 1
If (str = "MashVBA_Click") Then
MsgBox "skipping self"
MsgBox component.CodeModule.Name & " " & str
GoTo selfie
End If
Else
If skipline Then
If doline Then
skipline = False
End If
doline = False
End If
If doline Then
linenumber = linenumber + 10
numstring = Split(Trim(str), " ")
If Len(numstring(0)) >= 2 Then
If IsNumeric(numstring(0)) Then
str = Replace(str, numstring(0), "")
End If
End If
component.CodeModule.ReplaceLine i, linenumber & " " & str
End If
End If
skipsub:
Next i
selfie:
Next
varReturn = SysCmd(acSysCmdSetStatus, " ")
MsgBox "Finished"
End Sub
I am inserting a ActiveX control Label in excel sheet using VBA code. Now after inserting the button, I am trying to insert the click event code but its not working. Below is the code:
Public Function AddButton(strSheetName, counter)
Dim btn As OLEObject
Dim cLeft, cTop, cWidth, cHeight
Dim CodeModule As Object
With Worksheets(strSheetName).Range("J" & (6 + counter))
cLeft = .Left + 1
cTop = .Top + 1
cWidth = .Width - 2
cHeight = .Height - 2
End With
With Worksheets(strSheetName)
Set btn = .OLEObjects.Add(ClassType:="Forms.Label.1", Link:=True, DisplayAsIcon:=True, Left:=cLeft, Top:=cTop, Width:=cWidth, Height:=cHeight)
End With
btn.Object.Caption = "Add New"
btn.Name = Left(strSheetName, 3) & counter
Set CodeModule = ActiveWorkbook.VBProject.VBComponents.VBE.ActiveCodePane.CodeModule
CodeModule.InsertLines CodeModule.CreateEventProc("Click", btn.Name) + 1, vbTab & "MsgBox ""Hello world"""
End Function
Button is getting inserted but click event code is not working. When I click nothing happens. Also this function is getting called in a loop. First time it adds button and then as soon as it tries to add click event code, loop terminates which means there is an error.
Any help?
Thanks in advance.
I believe this is in continuation to your last question.
Is this what you are trying?
Option Explicit
Sub Sample()
Dim i As Long
For i = 1 To 5
AddButton "Sheet1", i
Next i
End Sub
Public Sub AddButton(strSheetName As String, counter As Long)
Dim btn As OLEObject
Dim cLeft, cTop, cWidth, cHeight
With Worksheets(strSheetName).Range("J" & (6 + counter))
cLeft = .Left
cTop = .Top
cWidth = .Width
cHeight = .Height
End With
With Worksheets(strSheetName)
Set btn = .OLEObjects.Add(ClassType:="Forms.Label.1", Link:=True, _
DisplayAsIcon:=False, Left:=cLeft, Top:=cTop, Width:=cWidth, _
Height:=cHeight)
End With
btn.Object.Caption = "Add New"
btn.Name = Left(strSheetName, 3) & counter
With ActiveWorkbook.VBProject.VBComponents( _
ActiveWorkbook.Worksheets(strSheetName).CodeName).CodeModule
.InsertLines Line:=.CreateEventProc("Click", btn.Name) + 1, _
String:=vbCrLf & _
"MsgBox ""Hello world"""
End With
End Sub
FOLLOWUP
yes, Clean the code from a particular sheet of entire Excel project. That's what is the requirement – user1269291 54 secs ago
Option Explicit
Sub Sample()
Dim strSheetName As String
strSheetName = "Sheet1"
With ActiveWorkbook.VBProject.VBComponents( _
ActiveWorkbook.Worksheets(strSheetName).CodeName).CodeModule
.DeleteLines 1, .CountOfLines
End With
End Sub
Reference
I am trying to add code (a subroutine call) to a procedure within Sheet1 by finding the line number of the procedure's statement within sheet1 in VBE then adding the code to the next line over. The following code attempts to achieve this.
' This will search for and modify the appropriate Node#button_Click() subroutine
With ActiveWorkbook.VBProject.VBComponents("Sheet1").CodeModule
ProcLineNum = .ProcStartLine("Node" & NumNodes & "Button" & "_Click", 0)
.InsertLines ProcLineNum + 1, "load_node_form(" & DQUOTE & "Node " & NumNodes & DQUOTE & ")"
End With
The entire subroutine is the following:
Public Sub Node_Button_Duplication()
'
'Com: Copies and pastes Node 1's button to the appropriate column
Dim shp As Shape
Dim code As String
Dim ProcLineNum As Long
Const DQUOTE = """"
' Copy Node 1 button and paste in appropriate location
ActiveSheet.Shapes("CommandButton1").Select
Selection.Copy
Cells(5, 10 + 7 * (NumNodes - 1) - 1).Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 47.25
Selection.ShapeRange.IncrementTop -13.5
Set shp = ActiveSheet.Shapes(Selection.Name)
With shp.OLEFormat.Object
.Object.Caption = "Node" & Str(NumNodes)
.Name = "Node" & NumNodes & "Button"
End With
' This will search for and modify the appropriate Node#button_Click() subroutine
With ActiveWorkbook.VBProject.VBComponents("Sheet1").CodeModule
ProcLineNum = .ProcStartLine("Node" & NumNodes & "Button" & "_Click", 0)
.InsertLines ProcLineNum + 1, "load_node_form(" & DQUOTE & "Node " & NumNodes & DQUOTE & ")"
End With
End Sub
The subroutine will copy and paste a button ("CommandButton1"), rename it, then attempts to assign a subroutine call. The problem in finding the procedure is that once the new button is created, the "CommandButton#_Click() procedure doesn't show up in VBE until I go and select it from the editor, thus causing an error when my code tries to search for that procedure.
Is this what you are trying?
Option Explicit
Public Sub Node_Button_Duplication()
Dim shp As Shape
Dim code As String
Dim ProcLineNum As Long, NumNodes As Long
Const DQUOTE = """"
ActiveSheet.Shapes("CommandButton1").Select
Selection.Copy
Cells(5, 10 + 7 * (NumNodes - 1) - 1).Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 47.25
Selection.ShapeRange.IncrementTop -13.5
Set shp = ActiveSheet.Shapes(Selection.Name)
With shp.OLEFormat.Object
.Object.Caption = "Node" & Str(NumNodes)
.Name = "Node" & NumNodes & "Button"
End With
With ActiveWorkbook.VBProject.VBComponents( _
ActiveWorkbook.Worksheets("Sheet1").CodeName).CodeModule
.InsertLines Line:=.CreateEventProc("Click", "Node" & NumNodes & "Button") + 1, _
String:=vbCrLf & _
"load_node_form(" & DQUOTE & "Node " & NumNodes & DQUOTE & ")"
End With
End Sub