My first post here, but have been successfully sourcing solutions and ideas from this website for a while now. So thanks for the collection of solutions and ideas.
Basically, I have a spread sheet application requiring the first column, Column A, to be filled with "Active X" buttons in every cell, looping through for a given quantity. I have posted one such working solution below which makes use of "form type buttons" and a Modules. This exemplifies what I consider my most favored example with working buttons. Once operational the column of buttons will correspond to relative data on the same row, and when clicked will open corresponding folders, and userforms in later developments.
The second post uses the Range function, but obviously doesn't incorporate any buttons to interactive with. However, a mouse click over this Range will obviously activate any code from within the Worksheet_Selection Change procedure...Sorry just stating the obvious!
What I have been trying to achieve is a version of code employing "activeX" Command Buttons, but after having studied some great tutorials and poured over a range of programing concepts, I still fail miserably to employ OLEObjects.
How to add a button programmatically in VBA next to some sheet cell data?
Sheet 1 Procedure:
Sub ColumnA_Buttons()
Dim buttons As Button
Dim rng As Range
Dim LineQty As Variant
Application.ScreenUpdating = False
ActiveSheet.buttons.Delete
LineQty = 5
For i = 1 To LineQty
Set rng = ActiveSheet.Range(Cells(i, 1), Cells(i, 1))
Set buttons = ActiveSheet.buttons.Add(rng.Left, rng.Top, rng.Width, rng.Height)
With buttons
.OnAction = "Buttons"
.Caption = "Line " & i
.Name = "Line " & i
End With
Next i
Application.ScreenUpdating = True
End Sub
Public Click_Button As Variant ' Make Variable Public for Userform1
'
Form Button Module:
Sub Line_Buttons()
Click_Button = Application.Caller
MsgBox Click_Button & " was Clicked"
UserForm1.Show 'Launch custom userform
End Sub
And the next option to be considered is a range detection
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' e.g., range(A1:E1) is clicked
If Not Application.Intersect(Target, Range("B2:B12")) Is Nothing Then
MsgBox "You clicked " & Target.Address
End If
End Sub
Ok. I'm posting some code that I've been working on based on this post here: Multiple active X checkboxes... . It seems I've now come to the same stand still they did as descibed in their last post :
"Yes it is individual checkboxes. You can emulate control arrays in
VBA so that each checkbox uses the same click event code, but that is
probably overkill IMO. "
And if I read Jason's post above, this is what he's questioning regarding the event code.
Any assistance welcomed in completing this code, as I have Not yet seen a working example which interlocks it to a single event, as per the form button module above.
Sub Macro1()
Dim objCmdBtn As Object
Dim i As Integer
Dim Rnge As Range
Set ColumnRange = Range("A:A") ' Set width & height of column A
ColumnRange.ColumnWidth = 5: ColumnRange.RowHeight = 15.75
'Delete previous objCmdBtn
For Each objCmdBtn In ActiveSheet.OLEObjects
If TypeName(objCmdBtn.Object) = "CommandButton" Then objCmdBtn.Delete
Next objCmdBtn 'TypeName Function returns the data-type about a variable - TypeName(varname is objCmdBtn)
With ActiveSheet
For i = 1 To 25
Set Rnge = ActiveSheet.Range(Cells(i + 1, 1), Cells(i + 1, 1))
Set objCmdBtn = Sheets("Sheet1").OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
Link:=False, _
DisplayAsIcon:=False, _
Left:=Rnge.Left, _
Top:=Rnge.Top, _
Width:=Rnge.Width, _
Height:=Rnge.Height)
With objCmdBtn
'set a String value as object's name
'.Name = "CommandButton1"
With .Object
.Caption = i
With .Font
.Name = "Arial"
.Bold = True
.Size = 7
.Italic = False
.Underline = False
End With
End With
End With
Next
End With
End Sub
Here is an example of ActiveX buttons being created and coded to run. It may take some small tweaks, but will get the job done.
Sub CreateButton()
Dim Obj As Object
Dim Code As String
Dim cellLeft As Single
Dim cellTop As Single
Dim cellwidth As Single
Dim cellheight As Single
Dim LineQty as Integer
Sheets("Sheet1").Select
LineQty = 5
For i = 1 To LineQty
Set rng = ActiveSheet.Range(Cells(i, 1), Cells(i, 1))
cellLeft = rng.Left
cellTop = rng.Top
cellwidth = rng.Width
cellheight = rng.Height
'create button
Set Obj = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", Link:=False, DisplayAsIcon:=False, Left:=cellLeft, Top:=cellTop, Width:=cellWidth, Height:=cellHeight)
Obj.Name = "TestButton"
'button text
ActiveSheet.OLEObjects(1).Object.Caption = "Test Button"
'macro text to be added possibly by array?
Code = "Private Sub TestButton_Click()" & vbCrLf
Code = Code & "Call Tester" & vbCrLf
Code = Code & "End Sub"
'add macro at the end of the sheet module
With ActiveWorkbook.VBProject.VBComponents(ActiveSheet.Name).CodeModule
.insertlines
.CountOfLines + 1, Code
End With
Next i
End Sub
Sub Tester()
MsgBox "You have clicked on the test button"
End Sub
Note In order for this to not error on me, I had to go to the trust center and to trust center settings and macro settings and check the box "Trust Access to the VBA Project Object Model"
Related
I have created a UserForm in VBA Excel that has a ListBox with the ListStyleOption selected. The MultiSelectMulti option is activated.
Whenever I close the UserForm or Workbook and then reopen, all the previous selections are gone. Is there a way to retain selections made in listbox?
Thanks.
Yes, it's possible, but you have to save the listbox items and their selected state in the workbook or some data support such as a file or database. When showing your form, you'll just read back the saved items and selected states.
Assuming you can save the list's content in the workbook, you can use something like the following:
Public Sub SaveList(ByVal plstListBox As MSForms.ListBox, ByVal prngSavePoint As Excel.Range)
On Error GoTo errHandler
Dim lRow As Long
Dim bScreenUpdating As Boolean
Dim bEnableEvents As Boolean
bScreenUpdating = Application.ScreenUpdating
bEnableEvents = Application.EnableEvents
Application.ScreenUpdating = False
Application.EnableEvents = False
prngSavePoint.CurrentRegion.Clear
If plstListBox.ListCount > 1 Then
For lRow = 0 To plstListBox.ListCount - 1
prngSavePoint.Cells(lRow + 1, 1).Value = plstListBox.Selected(lRow)
prngSavePoint.Cells(lRow + 1, 2).Value = plstListBox.List(lRow)
Next
End If
Cleanup:
On Error Resume Next
Application.EnableEvents = bEnableEvents
Application.ScreenUpdating = bScreenUpdating
Exit Sub
errHandler:
MsgBox Err.Description, vbExclamation + vbOKOnly, "Error"
Resume 'Cleanup
End Sub
Public Sub LoadList(ByVal plstListBox As MSForms.ListBox, ByVal prngSavePoint As Excel.Range)
Dim lRow As Long
Dim vntSavedList As Variant
plstListBox.Clear
If Not IsEmpty(prngSavePoint.Cells(1, 1).Value) Then
vntSavedList = prngSavePoint.CurrentRegion.Value
For lRow = 1 To UBound(vntSavedList, 1)
plstListBox.AddItem vntSavedList(lRow, 2)
plstListBox.Selected(lRow - 1) = vntSavedList(lRow, 1)
Next
End If
End Sub
To save (e.g. you could have a Save List button on your form), pass a reference to your listbox, and a reference to the top left cell of a free zone somewhere in your workbook. Beware that the code will write from this point down, on 2 columns, and overwrite everything that may be in its path. You must also be sure that this cell is isolated, i.e. not immediately adjacent to other content in any direction.
Example: SaveList ListBox1, Sheet1.Cells(1, 1)
You could have a Load List button on your form. To load back your list: LoadList ListBox1, Sheet1.Cells(1, 1)
The important listbox properties used in this answer are Selected and List, which give the selected state and label of any item in the list. These are zero-based indexed properties.
The AddComment syntax works on first selected sheet in workbook, but for the next one gives me this error: Error 1004 "Application-defined or Object-defined error". I do not know why crashes if multiple sheets were selected and works only for the first selected one. Does anyone have some idea?
If selectedSheet.Cells(7, columnIndex).value <> 100 Then
selectedSheet.Cells(7, columnIndex).Interior.ColorIndex = 3
If standardReportFilePath <> "" Then 'not using the Standard Report Evalution algorithm
If VerifyStandardReportFile(selectedSheet.Name, selectedSheet.Cells(1, columnIndex).value, wbk, amplitude, missingCrashes) = True Then
selectedSheet.Cells(1, columnIndex).Interior.ColorIndex = 36 ' color the crash cell with yellow
Set rng = selectedSheet.Cells(1, columnIndex)
If rng.Comment Is Nothing Then
**rng.AddComment "In Standard Report this crash starts to deploy from " & CStr(amplitude) & " amplitude"**
Else
rng.Comment.Text "In Standard Report this crash starts to deploy from " & CStr(amplitude) & " amplitude"
End If
End If
End If
End If
End If
An alternate set of code that shows the problem. (Run this with three blank worksheets in a new workbook.):
Sub test()
Dim ws As Worksheet
Dim Rng As Range
'Running code with a single sheet selected
Worksheets("Sheet1").Select
'Code that shows issue - this will work
Set ws = Worksheets("Sheet2")
Set Rng = ws.Cells(1, 1)
If Rng.Comment Is Nothing Then
Rng.AddComment "xxx"
End If
'Get rid of comment again
Rng.Comment.Delete
'Running code with multiple sheets selected
Worksheets(Array("Sheet1", "Sheet2", "Sheet3")).Select
'Code that shows issue - will crash on the "AddComment"
Set ws = Worksheets("Sheet2")
Set Rng = ws.Cells(1, 1)
If Rng.Comment Is Nothing Then
Rng.AddComment "xxx"
End If
End Sub
I found a workaround, but still don't know why this problem even happens. For some reason error occurs when you have more then one worksheet selected. The solution is... To select one sheet before adding comments with someSheet.Select. At the end of macro you can try to select all previously selected sheets again if needed.
What I do understand - thanks to Yoweks comment - is:
You are looping through all the selected sheets, check something, set comments (giving you the problems, because it does'nt work with more than one selected sheet) and want the previosly selected sheets to be selected afterwards.
You can save the previosly selected sheet in a variable, select one of them, run your code and then select all previosly selected sheets again. PLease try the following code:
Sub Comments()
Dim WsArr As Sheets, WS As Worksheet, ColIdx As Long
ColIdx = 7
Set WsArr = ActiveWorkbook.Windows(1).SelectedSheets
WsArr(1).Select
For Each WS In WsArr
'*** your logic
Set Rng = WS.Cells(1, ColIdx)
If Rng.Comment Is Nothing Then
Rng.AddComment "In Standard Report this crash starts to deploy from " & CStr(amplitude) & " amplitude"
Else
Rng.Comment.Text "Changed T"
End If
Next WS
WsArr.Select
End Sub
From the Excel documentation
You can add notes to individual cells by using comments
You can see in the 'Review' tab within Excel that, when you select multiple sheets, you cannot create a comment. I assume this is to do with Excel's internals determining which cell should have a comment assigned to it.
Here is a function which you can call to assign a comment to a given cell, even if you have multiple sheets selected.
This sub also removes the need to test if a comment already exists, simply pass a new comment to a cell which already has one.
Sub UpdateComment(Rng As Range, Cmnt As String)
Application.ScreenUpdating = False
' Get currently selected sheets
Dim mySheets As Sheets: Set mySheets = ThisWorkbook.Windows(1).SelectedSheets
' Set current selection to just one sheet: this is where error is avoided
ThisWorkbook.Sheets(1).Select
' Set Comment, new if doesn't exist or changed if it does
If Rng.Comment Is Nothing Then
Rng.AddComment Cmnt
Else
Rng.Comment.Text Cmnt
End If
' Tidy up: re-select sheets & enable screen updating
mySheets.Select
Application.ScreenUpdating = True
End Sub
Use it like so in your code:
' ... your previous code
Set rng = selectedSheet.Cells(1, columnIndex)
UpdateComment rng, "In standard report this crash starts to deploy from ..."
To loop over all selected sheets
Dim sh As Worksheet
For Each sh In ThisWorkbook.Windows(1).SelectedSheets
Set rng = sh.Cells(1, columnIndex)
UpdateComment rng, "In standard report this crash starts to deploy from ..."
Next sh
I had the same problem while trying to get a comments function to work so instead of trying to figure it out per scenario, I decided to do a general one; call as needed.
Sub General_Functions_Comments(InCell As Range, TxtComment As String, Optional IsMergedAnalyzed As Boolean)
Dim IsComment As Comment
Dim RangeFixedMerged As Range
If InCell.MergeCells = False Or IsMergedAnalyzed = True Then ' 3. If InCell.MergeCells = False
With InCell
Set IsComment = .Comment
If IsComment Is Nothing Then ' 1. If Iscomment Is Nothing
.AddComment.Text Text:=TxtComment
.Comment.Shape.TextFrame.AutoSize = True
.Comment.Visible = False
Else ' 1. If Iscomment Is Nothing
If InStr(.Comment.Text, TxtComment) Then ' 2. If InStr(.Comment.Text, TxtComment)
Else ' 2. If InStr(.Comment.Text, TxtComment)
.Comment.Text .Comment.Text & Chr(10) & TxtComment
.Comment.Shape.TextFrame.AutoSize = True
.Comment.Visible = False
End If ' 2. If InStr(.Comment.Text, TxtComment)
End If ' 1. If Iscomment Is Nothing
End With
Else ' 3. If InCell.MergeCells = False
Set RangeFixedMerged = InCell.Cells(1, 1)
Call General_Functions_Comments(RangeFixedMerged, TxtComment, True)
Set RangeFixedMerged = Nothing
End If ' 3. If InCell.MergeCells = False
End Sub
In your code
If standardReportFilePath <> "" Then 'not using the Standard Report Evalution algorithm
If VerifyStandardReportFile(selectedSheet.Name, selectedSheet.Cells(1, columnIndex).Value, wbk, amplitude, missingCrashes) = True Then
selectedSheet.Cells(1, columnIndex).Interior.ColorIndex = 36 ' color the crash cell with yellow
Set Rng = selectedSheet.Cells(1, columnIndex)
If Rng.Comment Is Nothing Then
Call General_Functions_Comments(Rng, "In Standard Report this crash starts to deploy from " & CStr(amplitude) & " amplitude", True)
Else: Call General_Functions_Comments(Rng, "In Standard Report this crash starts to deploy from " & CStr(amplitude) & " amplitude", True)
End If
End If
End If
End If
End If
*Aside question, why to set an if, else statement if both will do the same?
I remember generally similar case (I could not do something from code), trying hard to solve it and finally I found that...
Note that if you have multiple sheets selected, "New comment" button on the ribbon is inactive, so you just can't do it from code if you cannot do it manually.
Why? - don't ask me. I see a nice workaround above, which seems to be the only way to achieve what you need.
Employee Login System using vba userform.
I can capture Employee name and login time and put it in a sheet. However, an employee who is currently login can still login in the system. I want to stop it from happening.
Here's the screenshot of my form.
[]
Code:
Dim CM As Boolean
Private Sub cmdLogin_Click()
With Worksheets("May_1st").Range("A65536").End(xlUp)
.Offset(1, 0) = UserForm1.txtName.Value
.Offset(1, 1) = UserForm1.txtEmpID.Value
.Offset(1, 2) = UserForm1.txtTime.Value
End With
'Unload Me 'Optional: Close Userform1
txtName.Value = ""
txtEmpID.Value = ""
txtEmpID.SetFocus
End Sub
Private Sub cmdLogOut_Click()
'Worksheets("May_1st").Range("D65536").End(xlUp).Offset(1) = Format(Now, "hh:mm:ss")
'Unload Me 'Optional: Close Userform On Where Logout Button Is
Dim myLog As Worksheet
Dim myLogSheet As Range
Set myLog = Sheets("May_1st")
Set myLogSheet = myLog.Range("B:B").Find(txtEmpID.Value, , , xlWhole)
If Not myLogSheet Is Nothing Then
myLogSheet.Offset(0, 2) = Format(Now, "hh:mm:ss")
Else
txtName.Value = "XXX"
End If
txtName.Value = ""
txtEmpID.Value = ""
txtEmpID.SetFocus
End Sub
Private Sub txtEmpID_Change()
Dim mySheet As Worksheet
Dim myRange As Range
Set mySheet = Sheets("Emp_ID")
Set myRange = mySheet.Range("B:B").Find(txtEmpID.Value, , , xlWhole)
If Not myRange Is Nothing Then
txtName.Value = myRange.Offset(0, -1)
Else
txtName.Value = "Match not found"
End If
End Sub
Private Sub UserForm_activate()
'Do
'If CM = True Then Exit Sub
'txtTime = Format(Now, "hh:mm:ss")
'DoEvents
'Loop
Do While CM = False
UserForm1.txtTime = Format(Now, "hh:mm:ss")
DoEvents
Loop
'txtEmpID.SetFocus
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
CM = True
End Sub
There are many ways of solving this issue but they would depend on understanding how and when the Login form is displayed. I would go about solving this issue weighing these options:
Create and maintain a flag for users who are logged in
This way you can grey out the Login button. A code will run when cursor focus goes out of Emp_ID. Though this might be computationally heavy, it is a matter of just a code implementation.
Create another form for Login and Logout function
You could prompt to ask user details in the current form and with a click to next button open the next form, you could validate if user should login or logout and make the appropriate option to the user
You can store the logon details to either of
a hidden sheet
range name
Registry (SaveSettings)
the UserForm tag
separate txt file etc
Then retrieve the details as part of your code.
Suggest you pick what most suits you.
What I am trying to do is to create a program that adds combo boxes with some options. These options should then, depending on the option selected, change some values in some cells that I specify in code.
This is how I make the combo lists:
Private Sub Workbook_Open()
With Worksheets("Sheet1").Columns("E")
.ColumnWidth = 25
End With
For i = 1 To 6
Set curCombo = Sheet1.Shapes.AddFormControl(xlDropDown, Left:=Cells(i, 5).Left, Top:=Cells(i, 5).Top, Width:=100, Height:=15)
With curCombo
.ControlFormat.DropDownLines = 3
.ControlFormat.AddItem "Completed", 1
.ControlFormat.AddItem "In Progress", 2
.ControlFormat.AddItem "To be done", 3
.Name = "myCombo" & CStr(i)
.OnAction = "myCombo_Change"
End With
Next i
End Sub
I want each of the dropdown values trigger the event myCombo_Change and then simply change the cell "D" For example, combo box 3 is located at E3 and I want the "To be done" to clear the cell D3 and the completed to simply store the date (and time) to the cell D3. This should be done for all combo boxes in the E Column.
Private Sub myCombo_Change(index As Integer)
Me.Range("D" & CStr(index)) = Me.myCombo.Value
End Sub
This is the code I started thinking about, but I have no idea how to call the event with an integer as the index parameter NOR how to access the cell using said index.
The effect I want is something along the lines of this:
Use Application.Caller to get the name of the control that called the myCombo_Change event.
Sub myCombo_Change()
Dim curCombo As Shape
Set curCombo = ActiveSheet.Shapes(Application.Caller)
curCombo.TopLeftCell.Offset(0, -1) = Now
End Sub
Assign the myCombo_Change to all existing DropDown:
Sub AssignMacroToAllListBoxes()
Dim sh As Shape
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
For Each sh In ws.Shapes
If TypeName(sh.OLEFormat.Object) = "DropDown" Then
sh.OLEFormat.Object.OnAction = "myCombo_Change"
End If
Next
Next
End Sub
Delete all DropDowns on Sheet1
Sub DeleteAllDropDownsOnSheet()
For Each sh In Sheet1.Shapes
If TypeName(sh.OLEFormat.Object) = "DropDown" Then
sh.Delete
End If
Next
End Sub
I am using Excel 2003 with VBA, I am dynamically creating check box controls on a sheet and want to link the VBA controls to a class so that when a user clicks on a checkbox an event is fired so I can do something.
From what I've read it would seem that creating a user class is the solution, but having tried this I can't get it to work.
My user class looks like this:
Option Explicit
Public WithEvents cbBox As MSForms.checkbox
Private Sub cbBox_Change()
MsgBox "_CHANGE"
End Sub
Private Sub cbBox_Click()
MsgBox "_CLICK"
End Sub
My code to create the checkboxes:
For Each varExisting In objColumns
'Insert the field name
objColumnHeadings.Cells(lngRow, 1).Value = varExisting
'Insert a checkbox to allow selection of the column
Set objCell = objColumnHeadings.Cells(lngRow, 2)
Dim objCBclass As clsCheckbox
Set objCBclass = New clsCheckbox
Set objCBclass.cbBox = ActiveSheet.OLEObjects.Add( _
ClassType:="Forms.CheckBox.1" _
, Left:=300 _
, Top:=(objCell.Top + 2) _
, Height:=10 _
, Width:=9.6).Object
objCBclass.cbBox.Name = "chkbx" & lngRow
objCBclass.cbBox.Caption = ""
objCBclass.cbBox.BackColor = &H808080
objCBclass.cbBox.BackStyle = 0
objCBclass.cbBox.ForeColor = &H808080
objCheckboxes.Add objCBclass
lngRow = lngRow + 1
Next
The checkboxes are visible in the sheet, but when I click on them, no message box is displayed so the link to the class doesn't seem to be working.
Why?
Edit...If after adding the checkboxes I go into the VB IDE and select one of the created checkboxes from the list of controls, then select Click from the Procedure drop down list, it will insert the code for a call back which if I add a message box to this, works when I click on the same checkbox...so how can I achieve this in code? I've tried recording a macro to do this, nothing was recorded.
Edit by S.Platten, jump to the bottom for how this helped me fix the problem...
Due to some weird reason, VBA doesn't hook up the events for Sheet's ActiveX control in the same execution cycle in which they were added. So, we need to come out of the cycle which added the controls and then invoke the event adding proc in next cycle. Application.OnTime helps here.
Its seems a bit of overkill but it works :)
Option Explicit
Dim collChk As Collection
Dim timerTime
Sub master()
'/ Add the CheckBoxes First
Call addControls
'<< Due to some weird reason, VBA doesn't hook up the events for Sheet's ActiveX control in the same
'execution cycle in which they were added. So, we need to come out of the cycle which added the controls
'and then invoke the event adding proc in next cycle. >>
'/ Start Timer. Timer will call the sub to add the events
Call StartTimer
End Sub
Sub addControls()
Dim ctrlChkBox As MSForms.CheckBox
Dim objCell As Range
Dim i As Long
'Intialize the collection to hold the classes
Set collChk = New Collection
'/ Here Controls are added. No Events, yet.
For i = 1 To 10
Set objCell = Sheet1.Cells(i, 1)
Set ctrlChkBox = Sheet1.OLEObjects.Add( _
ClassType:="Forms.CheckBox.1" _
, Left:=1 _
, Top:=(objCell.Top + 2) _
, Height:=objCell.Height _
, Width:=100).Object
ctrlChkBox.Name = "chkbx" & objCell.Row
Next
End Sub
Sub addEvents()
Dim ctrlChkBox As MSForms.CheckBox
Dim objCBclass As clsCheckBox
Dim x As Object
'Intialize the collection to hold the classes
Set collChk = New Collection
'/ Here we assign the event handler
For Each x In Sheet1.OLEObjects
If x.OLEType = 2 Then
Set ctrlChkBox = x.Object
Set objCBclass = New clsCheckBox
Set objCBclass.cbBox = ctrlChkBox
collChk.Add objCBclass
Debug.Print x.Name
End If
Next
'/ Kill the timer
Call StopTimer
End Sub
Sub StartTimer()
timerTime = Now + TimeSerial(0, 0, 1)
Application.OnTime EarliestTime:=timerTime, Procedure:="addEvents", _
Schedule:=True
End Sub
Sub StopTimer()
On Error Resume Next
Application.OnTime EarliestTime:=timerTime, Procedure:="addEvents", _
Schedule:=False
End Sub
Class Module: clsCheckBox
Option Explicit
Public WithEvents cbBox As MSForms.CheckBox
Private Sub cbBox_Change()
MsgBox "_CHANGE"
End Sub
Private Sub cbBox_Click()
MsgBox "_CLICK"
End Sub
Edit continued...
The class (clsCheckbox):
Option Explicit
Public WithEvents cbBox As MSForms.checkbox
Private Sub cbBox_Click()
MsgBox "_CLICK"
End Sub
Module1
Public objCheckboxes As Collection
Public tmrTimer
Public Sub addEvents()
Dim objCheckbox As clsCheckbox
Dim objMSCheckbox As Object
Dim objControl As Object
Set objCheckboxes = New Collection
For Each objControl In Sheet1.OLEObjects
If objControl.OLEType = 2 _
And objControl.progID = "Forms.CheckBox.1" Then
Set objMSCheckbox = objControl.Object
Set objCheckbox = New clsCheckbox
Set objCheckbox.cbBox = objMSCheckbox
objCheckboxes.Add objCheckbox
End If
Next
Call stopTimer
End Sub
Public Sub startTimer()
tmrTimer = Now + TimeSerial(0, 0, 1)
Application.OnTime EarliestTime:=tmrTimer _
, Procedure:="addEvents" _
, Schedule:=True
End Sub
Public Sub stopTimer()
On Error Resume Next
Application.OnTime EarliestTime:=tmrTimer _
, Procedure:="addEvents" _
, Schedule:=False
End Sub
The code in the sheet that adds the controls:
Dim objControl As MSForms.checkbox
For Each varExisting In objColumns
'Insert the field name
objColumnHeadings.Cells(lngRow, 1).Value = varExisting
'Insert a checkbox to allow selection of the column
Set objCell = objColumnHeadings.Cells(lngRow, 2)
Set objControl = ActiveSheet.OLEObjects.Add( _
ClassType:="Forms.CheckBox.1" _
, Left:=300 _
, Top:=(objCell.Top + 2) _
, Height:=10 _
, Width:=9.6).Object
objControl.Name = "chkbx" & lngRow
objControl.Caption = ""
objControl.BackColor = &H808080
objControl.BackStyle = 0
objControl.ForeColor = &H808080
lngRow = lngRow + 1
Next
This isn't the entire project, but enough to demonstrate the workings.
You are currently using ActiveX controls. Yet, ActiveX controls are bound to specific naming conventions. For example: if you insert an ActiveX button onto a sheet and name it btnMyButton then the sub must be named btnMyButton_Click. The same applies to checkboxes. If you insert a new checkbox with the name CheckBox2 then the sub's name must be CheckBox2_Click. In short, there cannot be a sub with the name cbBox_Change associated to any ActiveX checkbox.
So, what you really need (with ActiveX controls) is a way to change the VBA code on a sheet. But thus far I have never come across any such code (VBA code to change VBA code on a sheet).
A much easier route would be if you'd be willing to use form controls instead.
The following sub will create a (form control) checkbox and assign the macro tmpSO to it. The sub tmpSO (unlike subs for ActiveX controls) does not need to reside on the sheet but can be in any module.
Sub Insert_CheckBox()
Dim chk As CheckBox
Set chk = ActiveSheet.CheckBoxes.Add(390.75, 216, 72, 72)
chk.OnAction = "tmpSO"
End Sub
Since a from control is calling the sub tmpSO you can use Application.Caller in that sub and thereby know which checkbox has been calling this sub.
Sub tmpSO()
Debug.Print Application.Caller
End Sub
This will return the name of the CheckBox. So, you can use this one sub for all of your checkboxes any dynamically handle them based on their names (possibly using a Case Select).
Here is another example for tmpSO:
Sub tmpSO()
With ThisWorkbook.Worksheets(1).CheckBoxes(Application.Caller)
MsgBox "The checkbox " & Application.Caller & Chr(10) & _
"is currently " & IIf(.Value = 1, "", "not") & " checked."
End With
End Sub