VBA ComboBox Change Event not triggered - excel

I have this issue with the ComboBox Event Handler.
I managed to create (and fill with items) the Comboboxes I wanted, the code seems to work fine. But after the program has run, if I try to pick one general item inside one of the comboboxes, it seems like the _Change Method is not called --> I cannot handle change events.
Here is my class module (class name: "DB_ComboBox")
Option Explicit
Public WithEvents DB_ComboBoxEvents As MSForms.ComboBox
Private DB_ComboBox_Line As Integer
Private Sub DB_ComboBoxEvents_Change()
MsgBox ("Line : " & DB_ComboBox_Line)
'Here I want handle The comboboxes changes
'But this routine is not called!
End Sub
Sub Box(CBox As MSForms.ComboBox)
Set DB_ComboBoxEvents = CBox
End Sub
Public Property Let Line(value As Integer)
DB_ComboBox_Line = value
End Property
Public Property Get Line() As Integer
Line = DB_ComboBox_Line
End Property
And here is my "Main module", in which I create the comboboxes and pass them to a Collection of "DB_ComboBox"
Sub CreateComboBox(IncCBoxes)
Dim curCombo As MSForms.ComboBox
Dim rng As Range
Dim tot_items As Integer
Dim incAddItem As Integer
Dim incAddItemBis As Integer
Dim itemBaseArray() As String
Dim TEMP_ComboBoxInst As New DB_ComboBox
Set rng = ActiveSheet.Range("J" & IncCBoxes)
Set curCombo = ActiveSheet.OLEObjects.Add(ClassType:="Forms.ComboBox.1", Link:=False, DisplayAsIcon:=False, Left:=rng.Left, Top:=rng.Top, Width:=rng.Width, Height:=rng.Height).Object
'Add the items
itemBaseArray = Split(Foglio7.Cells(IncCBoxes, DBColFileComboIndexErrori), ";")
For incAddItem = 0 To UBound(itemBaseArray)
Dim itemLastArray() As String
itemLastArray = Split(itemBaseArray(incAddItem), ",")
For incAddItemBis = 0 To UBound(itemLastArray)
curCombo.AddItem (itemLastArray(incAddItemBis))
Next
Next
TEMP_ComboBoxInst.Box curCombo
TEMP_ComboBoxInst.Line = IncCBoxes
customBoxColl.Add TEMP_ComboBoxInst
End Sub
Can anyone please tell me what I'm missing?
Thank you very much

This looks like a timing-issue:
Running this code in another open file will work. In same file it does not.
Seperate the adding to your class from the adding of the OLEControl i.e.:
use Application.ontime now
see code below:
Private customBoxColl As New Collection
Sub CreateComboBox(IncCBoxes As Long)
Dim curCombo As MSForms.ComboBox
Dim rng As Range
Dim tot_items As Integer
Dim incAddItem As Integer
Dim incAddItemBis As Integer
Dim itemBaseArray() As String
Dim itemLastArray() As String
Set rng = ActiveSheet.Range("J" & IncCBoxes)
With ActiveSheet.OLEObjects.Add(ClassType:="Forms.ComboBox.1", Link:=False, DisplayAsIcon:=False, Left:=rng.Left, Top:=rng.Top, Width:=rng.Width, Height:=rng.Height)
Set curCombo = .Object
End With
'Add the items
itemBaseArray = Split(Foglio7.Cells(IncCBoxes, DBColFileComboIndexErrori), ";")
For incAddItem = 0 To UBound(itemBaseArray)
itemLastArray = Split(itemBaseArray(incAddItem), ",")
For incAddItemBis = 0 To UBound(itemLastArray)
curCombo.AddItem (itemLastArray(incAddItemBis))
Next
Next
Application.OnTime Now, "'CallToClass """ & curCombo.Name & """,""" & IncCBoxes & "'"
End Sub
Sub CalltoClass(ctl As String, myline As Long)
Dim TEMP_ComboBoxInst As New DB_ComboBox
TEMP_ComboBoxInst.Box ActiveSheet.OLEObjects(ctl).Object
TEMP_ComboBoxInst.line = myline
customBoxColl.Add TEMP_ComboBoxInst
End Sub

I know this doesn't apply to your specific problem, but I'll just post this here for any others who may have this problem. In my case, the events stopped firing because I had just copied my database into a new Github repo.
On reopening Access, the events weren't firing while they had been fine the day before, which completely stumped me, especially since none of the SO answers seemed to address my issue. Basically, Access blocks macros and code, and requires it to be reenabled by clicking OK on the little yellow warning at the top of the screen.

Related

Excel VBA - Range(Find().Adress).Row

I have googled and struggled with this for hours now.
I have a Control workbook, that pulls data from a varied amount of other workbooks (the Control workbook also creates the other workbooks and saves the names and dir of said workbooks so that they can be called later)
This piece of code is the problem.
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Declare_Sheets
Dim SearchresultROW
Dim Searchresult As String
Dim complexrow As Integer
Dim CurrSheet As Worksheet
Dim Stype As String
Dim startROW As Integer
Dim endROW As Integer, SearchCOL As Integer, OffROW As Integer
Dim PDATArange As Range, CDATArange As Range
Dim Dateyear, Datemonth, datetest As String
Stype = WSRD.Range("B11")
'Find complex to work with
complexrow = WSSS.Range("F7")
WSSS.Activate
SearchresultROW = Range(Cells(7, 15), Cells(complexrow, 15).Find(Callsheet).Address).Row
Searchresult = WSSS.Cells(SearchresultROW, 15).Offset(0, 1)
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
The below code is the problem extract
complexrow = WSSS.Range("F7")
WSSS.Activate
SearchresultROW = Range(Cells(7, 15), Cells(complexrow, 15).Find(Callsheet).Address).Row
Searchresult = WSSS.Cells(SearchresultROW, 15).Offset(0, 1)
1st problem
I cant get the find() to work without activating worksheet - WSSS
Declare_Sheets gets run at the start which declares WSSS, this works everywhere else in my code, but not with this find().
2nd problem
The code below compiles and finishes, BUT - It does not return the correct data.
This code calls starts the macro
Cancel = True
Dim Calsheet As String
If Target.Column <> 1 Then Exit Sub
Calsheet = Target.Value
Call Call_Readings(Calsheet)
End Sub
There are currently 2 possibilities
I double click on Casper Tcomp 4.
Callsheet = "Casper Tcomp 4" - Which is correct (target of the double click)
Complexrow = "9" - Which is correct (this will increment as new sheets are added)
SearchresultROW = "7" - This is wrong, it should be 8
I have tried adding LookAt:=xlWhole and LookIn:-xlValues, doesnt change a thing
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Declare_Sheets
Dim SearchresultROW
Dim Searchresult As String
Dim complexrow As Integer
Dim CurrSheet As Worksheet
Dim Stype As String
Dim FindResult As Range
Dim startROW As Integer
Dim endROW As Integer, SearchCOL As Integer, OffROW As Integer
Dim PDATArange As Range, CDATArange As Range
Dim Dateyear, Datemonth, datetest As String
Stype = WSRD.Range("B11")
'Find complex to work with
complexrow = WSSS.Range("F7")
On Error Resume Next 'next line will error if nothing is found
Set FindResult = WSSS.Range(WSSS.Cells(7, 15), WSSS.Cells(complexrow, 15)).Find(What:=Callsheet, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, MatchByte:=False)
On Error GoTo 0 'always re-activate error reporting!
If Not FindResult Is Nothing Then 'check if find was successful
SearchresultROW = FindResult.Row
Searchresult = WSSS.Cells(SearchresultROW, 15).Offset(0, 1)
Else 'if nothing was found show message
MsgBox "NO WB FOUND.", vbCritical
End If
This solved the problem, thanks for the assistance Pᴇʜ
Your code without .Activate would look something like below. Note that every Range, Cells, Rows or Columns object needs to be referenced with the correct Workbook/Worksheet:
complexrow = WSSS.Range("F7")
'try to find something
Dim FindResult As Range
On Error Resume Next 'next line will error if nothing is found
Set FindResult = WSSS.Cells(complexrow, 15).Find(What:=Callsheet, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, MatchByte:=False)
On Error GoTo 0 'always re-activate error reporting!
If Not FindResult Is Nothing Then 'check if find was successful
SearchresultROW = WSSS.Range(WSSS.Cells(7, 15), FindResult).Row
Searchresult = WSSS.Cells(SearchresultROW, 15).Offset(0, 1)
Else 'if nothing was found show message
MsgBox "nothing found.", vbCritical
End If
Note that if using the Range.Find method you need to check if something was found before you can use the result of Find. Otherwise it will throw an error. Also note that the documentation of Find says that …
The settings for LookIn, LookAt, SearchOrder, and MatchByte are saved each time you use this method.
So if you don't define them each time using Find it will use whatever was used last by either VBA or the user interface. Since you have no control about what was used last by the user interface I highly recomment to define them everytime using Find or you will get random results.
Also note that Callsheet is not defined in your code yet, so check that.

VBA: Chart.export produces corrupt image - until scrolled over or chart.activate

I have a form that manipulates a chart and then exports it, like so:
Workbooks(sWB).Sheets("Output").Unprotect sPW
Workbooks(sWB).Sheets("Output").ChartObjects(1).Chart.Export strDocName
However, occasionally this doesn't work properly anymore and a corrupt image is exported each time. Going to the sheet with the chart and scrolling over it (without clicking) solves the issue for a while. For now I fixed it like this:
Workbooks(sWB).Sheets("Output").Unprotect sPW
Workbooks(sWB).Sheets("Output").ChartObjects(1).Activate 'chart sometimes falls asleep somehow, maybe this will fix
Workbooks(sWB).Sheets("Output").ChartObjects(1).Chart.Export strDocName
This seems to have solved the issue which I dubbed "sleeping charts" for now.
However, I would like to understand how this works, and to fix it without using "Activate" as that can impact the user experience of my users (who use multiple Excel sheets along this VBA-excel form).
Anyone who understands what happens here?
Full function code chain
Private Sub C171CmdLe1Dr1Graph_Click()
Call ShowGraph(1, 1, True)
End Sub
Private Sub ShowGraph(ByVal intLeNr As Integer, ByVal intDrNr As Integer, ByVal Show As Boolean) 'Delete
Dim strDocName As String
Dim strLeNr As String
Dim oChart As Frm_DCT_ShowGraph
Call dle(intLeNr - 1).DrawChart(intLeNr, intDrNr)
'export the chart
strDocName = strMyDocsPath & "\DRT_Chart" & Right(strLeNr, 1) & ".gif"
Workbooks(sWB).Sheets("Output").Unprotect sPW
Workbooks(sWB).Sheets("Output").ChartObjects(1).Activate 'chart sometimes falls asleep somehow, maybe this will fix
Workbooks(sWB).Sheets("Output").ChartObjects(1).Chart.Export strDocName
If Show Then
'create new chart, load it and show it
Set oChart = New Frm_DCT_ShowGraph
oChart.DocName = strDocName
oChart.Show vbModeless
End If
Workbooks(sWB).Sheets("Output").Protect sPW
DoEvents
End Sub
Public Sub DrawChart(ByVal intLeNr As Integer, ByVal intDrNr As Integer)
Dim lngN As Long
Dim sngPlotArr() As Single
Dim strIRange As String
Dim strURange As String
...
'create plot data
Call cDriver(intDrNr - 1).Plot(sngPlotArr)
'unlock worksheet
Workbooks(sWB).Sheets("Output").Unprotect sPW
'clear range first
Workbooks(sWB).Sheets("Output").Range(strIRange).Clear
Workbooks(sWB).Sheets("Output").Range(strURange).Clear
'fill in data
For lngN = 0 To UBound(sngPlotArr, 1)
Workbooks(sWB).Sheets("Output").Range(strIRange).Columns(lngN + 1).Value2 = sngPlotArr(lngN, 0)
Workbooks(sWB).Sheets("Output").Range(strURange).Columns(lngN + 1).Value2 = sngPlotArr(lngN, 1)
'give OS some time
If lngN Mod 100 = 0 Then
DoEvents
End If
Next
...
'relock
Workbooks(sWB).Sheets("Output").Protect sPW
End Sub

Select variable object with counter

Background:
I have a collection of objects (for this example Listbox objects) in a userform using standardized names, I would like to rename them dynamically using a counter cycle.
Problem:
I have not figured a way if what I am asking is even possible, however, I would like to confirm it.
Solution approach:
Nothing so far, like I said (refer to the image above) I need a way to set the values of the objects within the for cycle, something like this:
For CounterItems = 1 To 18 'Hours in Template
ListBox_Time(CounterItems).Value="Dummy" & CounterItems
Next CounterHours
However, I am clueless on how to do so (or if it is achievable).
Question:
Is there any way to use a counter to cast a variable/object?
No, you can't edit the name while the userform is in use, you'll get error 382
What you'd like to do is this
Option Explicit
Sub test()
Dim myForm As UserForm
Set myForm = UserForm1
Dim myCtrl As Control
Dim i As Long
Dim myCount As Long
myCount = 1
For Each myCtrl In myForm.Controls
If TypeName(myCtrl) = "ListBox" Then
myCtrl.Name = "Dummy" & myCount 'error
myCount = myCount + 1
End If
Next
End Sub
But you'll error when you try to write to the name property. You can print the names or set other properties, but this isn't something you can do as far as I know.
For use with ListBox controls on a UserForm
If you want to change only certain ListBox controls by number:
Public Sub ListBoxNameChange()
Dim ctrl As Control
Dim ctrlName As String, ctrlNum As Integer
For Each ctrl In Me.Controls
If TypeName(ctrl) = "ListBox" Then
ctrlName = ctrl.Name
ctrlNum = CInt(Replace(ctrlName, "ListBox_Time", ""))
If ctrlNum > 0 And ctrlNum < 19 Then
ctrl.AddItem "Dummy" & ctrlNum, 0
End If
End If
Next ctrl
End Sub
If you want to change ALL ListBox controls:
Public Sub ListBoxNameChange2()
Dim ctrl As Control
Dim ctrlName As String
For Each ctrl In Me.Controls
If TypeName(ctrl) = "ListBox" Then _
ctrl.AddItem "Dummy" & Replace(ctrl.Name, "ListBox_Time", ""), 0
Next ctrl
End Sub
I treat them like Shapes and test their pre-defined Names:
Sub ShapeRenamer()
Dim s As Shape
For Each s In ActiveSheet.Shapes
If s.Name = "List Box 6" Then s.Name = "Sixth"
Next s
End Sub
Before:
and after:
You would update this to examine the Shapes in your userform.
You could also do this with an indexing counter.

Use VBA to assign all checkboxes to class module

I'm having a problem assigning VBA generated ActiveX checkboxes to a class module. When a user clicks a button, the goal of what I am trying to achieve is: 1st - delete all the checkboxes on the excel sheet; 2nd - auto generate a bunch of checkboxes; 3rd - assign a class module to these new checkboxes so when the user subsequently clicks one of them, the class module runs.
I've borrowed heavily from previous posts Make vba code work for all boxes
The problem I've having is that the 3rd routine (to assign a class module to the new checkboxes) doesn't work when run subsequently to the first 2 routines. It runs fine if run standalone after the checkboxes have been created. From the best I can tell, it appears VBA isn't "releasing" the checkboxes after they have been created to allow the class module to be assigned.
The below code is the simplified code that demonstrates this problem. In this code, I use a button on "Sheet1" to run Sub RunMyCheckBoxes(). When button 1 is clicked, the class module did not get assigned to the newly generated checkboxes. I use button 2 on "Sheet1" to run Sub RunAfter(). If button 2 is clicked after button 1 has been clicked, the checkboxes will be assigned to the class module. I can't figure out why the class module won't be assigned if just the first button is clicked. Help please.
Module1:
Public mcolEvents As Collection
Sub RunMyCheckboxes()
Dim i As Double
Call DeleteAllCheckboxesOnSheet("Sheet1")
For i = 1 To 10
Call InsertCheckBoxes("Sheet1", i, 1, "CB" & i & "1")
Call InsertCheckBoxes("Sheet1", i, 2, "CB" & i & "2")
Next
Call SetCBAction("Sheet1")
End Sub
Sub DeleteAllCheckboxesOnSheet(SheetName As String)
Dim obj As OLEObject
For Each obj In Sheets(SheetName).OLEObjects
If TypeOf obj.Object Is MSForms.CheckBox Then
obj.Delete
End If
Next
End Sub
Sub InsertCheckBoxes(SheetName As String, CellRow As Double, CellColumn As Double, CBName As String)
Dim CellLeft As Double
Dim CellWidth As Double
Dim CellTop As Double
Dim CellHeight As Double
Dim CellHCenter As Double
Dim CellVCenter As Double
CellLeft = Sheets(SheetName).Cells(CellRow, CellColumn).Left
CellWidth = Sheets(SheetName).Cells(CellRow, CellColumn).Width
CellTop = Sheets(SheetName).Cells(CellRow, CellColumn).Top
CellHeight = Sheets(SheetName).Cells(CellRow, CellColumn).Height
CellHCenter = CellLeft + CellWidth / 2
CellVCenter = CellTop + CellHeight / 2
With Sheets(SheetName).OLEObjects.Add(classtype:="Forms.CheckBox.1", Link:=False, DisplayAsIcon:=False, Left:=CellHCenter - 8, Top:=CellVCenter - 8, Width:=16, Height:=16)
.Name = CBName
.Object.Caption = ""
.Object.BackStyle = 0
.ShapeRange.Fill.Transparency = 1#
End With
End Sub
Sub SetCBAction(SheetName)
Dim cCBEvents As clsActiveXEvents
Dim o As OLEObject
Set mcolEvents = New Collection
For Each o In Sheets(SheetName).OLEObjects
If TypeName(o.Object) = "CheckBox" Then
Set cCBEvents = New clsActiveXEvents
Set cCBEvents.mCheckBoxes = o.Object
mcolEvents.Add cCBEvents
End If
Next
End Sub
Sub RunAfter()
Call SetCBAction("Sheet1")
End Sub
Class Module (clsActiveXEvents):
Option Explicit
Public WithEvents mCheckBoxes As MSForms.CheckBox
Private Sub mCheckBoxes_click()
MsgBox "test"
End Sub
UPDATE:
On further research, there is a solution posted in the bottom answer here:
Creating events for checkbox at runtime Excel VBA
Apparently you need to force Excel VBA to run on time now:
Application.OnTime Now ""
Edited lines of code that works to resolve this issue:
Sub RunMyCheckboxes()
Dim i As Double
Call DeleteAllCheckboxesOnSheet("Sheet1")
For i = 1 To 10
Call InsertCheckBoxes("Sheet1", i, 1, "CB" & i & "1")
Call InsertCheckBoxes("Sheet1", i, 2, "CB" & i & "2")
Next
Application.OnTime Now, "SetCBAction" '''This is the line that changed
End Sub
And, with this new formatting:
Sub SetCBAction() ''''no longer passing sheet name with new format
Dim cCBEvents As clsActiveXEvents
Dim o As OLEObject
Set mcolEvents = New Collection
For Each o In Sheets("Sheet1").OLEObjects '''''No longer passing sheet name with new format
If TypeName(o.Object) = "CheckBox" Then
Set cCBEvents = New clsActiveXEvents
Set cCBEvents.mCheckBoxes = o.Object
mcolEvents.Add cCBEvents
End If
Next
End Sub
If OLE objects suit your needs then I'm glad you've found a solution.
Are you aware, though, that Excel's Checkbox object could make this task considerably simpler ... and faster? Its simplicity lies in the fact that you can easily iterate the Checkboxes collection and that you can access its .OnAction property. It is also easy to identify the 'sender' by exploiting the Evaluate function. It has some formatting functions if you need to tailor its appearance.
If you're after something quick and easy then the sample below will give you an idea of how your entire task could be codified:
Public Sub RunMe()
Const BOX_SIZE As Integer = 16
Dim ws As Worksheet
Dim cell As Range
Dim cbox As CheckBox
Dim i As Integer, j As Integer
Dim boxLeft As Double, boxTop As Double
Set ws = ThisWorkbook.Worksheets("Sheet1")
'Delete checkboxes
For Each cbox In ws.CheckBoxes
cbox.Delete
Next
'Add checkboxes
For i = 1 To 10
For j = 1 To 2
Set cell = ws.Cells(i, j)
With cell
boxLeft = .Width / 2 - BOX_SIZE / 2 + .Left
boxTop = .Height / 2 - BOX_SIZE / 2 + .Top
End With
Set cbox = ws.CheckBoxes.Add(boxLeft, boxTop, BOX_SIZE, BOX_SIZE)
With cbox
.Name = "CB" & i & j
.Caption = ""
.OnAction = "CheckBox_Clicked"
End With
Next
Next
End Sub
Sub CheckBox_Clicked()
Dim sender As CheckBox
Set sender = Evaluate(Application.Caller)
MsgBox sender.Name & " now " & IIf(sender.Value = 1, "Checked", "Unchecked")
End Sub

Detect the renaming or deletion of worksheets

Is there a way to detect when a user
renames, or
deletes a worksheet?
I want to run some code if one of these events happens.
what I have tried
My tool uses a lot of event handlers so one thing I thought of was looping through all the sheetnames during each Worksheet_Change, but I don't think that is the best approach.
This approach goes under the ThisWorkbook module.
Public shArray1 As Variant
Public shArray2 As Variant
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
Dim lngCnt As Long
Dim strMsg As String
Dim strSht
Dim vErr
Dim strOut As String
'get all sheet names efficiently in a 1D array
ActiveWorkbook.Names.Add "shtNames", "=RIGHT(GET.WORKBOOK(1),LEN(GET.WORKBOOK(1))-FIND(""]"",GET.WORKBOOK(1)))"
shArray2 = Application.Transpose([INDEX(shtNames,)])
strSht = Application.Transpose(Application.Index(shArray2, , 1))
'exit here if first time code is run
If IsEmpty(shArray1) Then
shArray1 = shArray2
Exit Sub
End If
`check each sheet name still exists as is
For lngCnt = 1 To UBound(shArray1)
vErr = Application.Match(shArray1(lngCnt, 1), strSht, 0)
If IsError(vErr) Then
strOut = strOut & shArray1(lngCnt, 1) & vbNewLine
vErr = Empty
End If
Next
shArray1 = Application.Transpose([INDEX(shtNames,)])
If Len(strOut) > 0 Then MsgBox strOut, vbCritical, "These sheets are gone or renamed"
End Sub

Resources