I have this code in a class module
Public WithEvents evtHandler As VBIDE.CommandBarEvents
Private Sub evtHandler_Click(ByVal CommandBarControl As Object, _
handled As Boolean, CancelDefault As Boolean)
On Error Resume Next
Application.Run CommandBarControl.OnAction
handled = True
CancelDefault = True
End Sub
I have this code in a module
Sub CommandBarComboBox_Create()
Dim cmdBar As commandBar: Set cmdBar = Application.VBE.CommandBars("Custom")
Dim arr As Variant: arr = Array("item_1", "item_2", "item_3")
Dim i As Byte
Dim newCtrl As CommandBarControl: Set newCtrl = cmdBar.Controls.Add(msoControlComboBox)
With newCtrl
.caption = "myList"
For i = LBound(arr) To UBound(arr)
.AddItem arr(i), i + 1
Next i
.OnAction = "'processSelection'"
.tag = "myTag"
End With
' Create event handler
Set MenuEvent = New VBE_cmdHandler
Set MenuEvent.evtHandler = Application.VBE.Events.CommandBarEvents(newCtrl)
EventHandlers.Add MenuEvent
End Sub
Sub processSelection()
Dim cmdBar As commandBar: Set cmdBar = Application.VBE.CommandBars("Custom")
Dim userChoice As Long: userChoice = cmdBar.Controls(2).ListIndex
Select Case userChoice
Case 1
Debug.Print "OPTION 1"
Case 2
Debug.Print "OPTION 2"
Case Else
Debug.Print "OPTION 3"
End Select
End Sub
This works just fine but I would like to change it, so when sub processSelection is called, it implicit knows the calling control, so I don't have to specify it.
How can it be done?
Regards
Elio Fernandes
I just found a way to solve my problem, using the tag property of the control.
I replaced the first 2 lines of code of the sub processSelecion with 3 new lines, but without the need to identify with command bar and which control was last used.
With tag property, I can find which control was last used and consequently which ListIndex item was selected by the user.
Sub processSelection()
Dim curTag$: curTag = Application.VBE.CommandBars.ActionControl.tag
Dim myControls As Object: Set myControls = Application.VBE.CommandBars.FindControls(tag:=curTag$)
Dim userChoice As Long: userChoice = myControls.item(1).ListIndex
Select Case userChoice
Case 1
Debug.Print "OPTION 1"
Case 2
Debug.Print "OPTION 2"
Case 3
Debug.Print "OPTION 3"
Case Else
Debug.Print "OTHER"
End Select
End Sub
Related
I am using this code to hide a label based on if it contains % sign only and nothing else.
It is this part of the code it is erroring now when running. Error: "OLEFormat.Object: Invalid Request. Command cannot be applied to a shape range with multiple shapes"
What should be the correct code?
If InStr(1, myRange.OLEFormat.Object.Caption, "%", vbTextCompare) > 0 Then
Sub c_Three_RemovePercent()
For slideNumber = 1 To 11
Set mydocument = ActivePresentation.Slides(slideNumber)
mydocument.Select
Dim myArray() As Variant
Dim myRange As Object
myArray = Array("Lbl_V1", "Lbl_V2", "Lbl_V3", "Lbl_V4", "Lbl_V5")
Set myRange = ActivePresentation.Slides(1).Shapes.Range(myArray)
With mydocument.Shapes.Range(myArray)
If InStr(1, myRange.OLEFormat.Object.Caption, "%", vbTextCompare) > 0 Then
mydocument.Shapes(myRange).Visible = False
Else: mydocument.Shapes(myRange).Visible = True
End If
End With
Next slideNumber
End Sub
All these blindfolded late-bound member calls are easily confusing: you don't get IntelliSense to help you navigate the available members.
You're looking for an OLEObject, so declare one; assign it:
Dim oleLabel As Excel.OLEObject
Set oleLabel = ActivePresentation.Slides(1).Shapes("SomeShapeName").OLEFormat.Object
Now you want the control that's in that OLEObject's Object property, and you want to cast that control to its MSForms.Label interface:
Dim labelControl As MSForms.Label
Set labelControl = oleLabel.Object
Now you have an early-bound MSForms.Label interface to query, and IntelliSense guides you all the way:
If Contains(labelControl.Caption, "%") Then
'...
Else
'...
End If
Where Contains could look something like this:
Public Function Contains(ByVal source As String, ByVal substring As String) As Boolean
Contains = InStr(1, source, substring, vbTextCompare) > 0
End Function
You have an array of label control names you want to iterate - just iterate it:
Dim labelNames As Variant
labelNames = Array("label1", "label2", "label3", ...)
Dim i As Long
For i = LBound(labelNames) To UBound(labelNames)
Set oleLabel = currentSlide.Shapes(labelNames(i)).OLEObject
oleLabel.Visible = Not Contains(labelControl.Caption, "%")
Next
Note how this:
If BooleanExpression Then
Thing = True
Else
Thing = False
End If
Can be rewritten as:
Thing = BooleanExpression
For checking if string contains the vba function INSTR is typically best. Basically in the below example... Starting in the first position, check this text, look for "%", case insensative.
If InStr(1, myRange.OLEFormat.Object.Caption, "%", vbTextCompare) > 0 Then
mydocument.Shapes(myRange).Visible = False
Else: mydocument.Shapes(myRange).Visible = True
End If
In the code I am posting, I am using a check box called "ACDS Test" and whenever it is checked it creates a sheet, then when it becomes unchecked it calls the upper function and deletes the sheet.
I am trying to add a message box that essentially works like a fail safe to ensure they want to delete the page. If they say they do not want to delete the page then I want the checkbox to stay checked.
For some reason I am getting this error message when I try to pass the value to make sure the checkbox stays checked and I cannot figure out why.
The error comes up on the line:
Sub ACDSTest_Click(CorrectValue As Integer)
And the specific error is: "Compile error: Procedure Declaration does not match description of event or procedure having the same name".
Any help is much appreciated! IF any more clarification is needed please feel free to ask!
Sub DeleteWorksheet(NameSheet As String)
Dim Ans As Long
Dim t As String
Dim CorrectValue As Integer
Dim i As Long, k As Long
k = Sheets.Count
Ans = MsgBox("Would you like to take this test off of the form?", vbYesNo)
Select Case Ans
Case vbYes
'Code reads through each page and finds one with corresponding name to string t
'Once it finds the correct page, it deletes it
For i = k To 1 Step -1
t = Sheets(i).Name
If t = NameSheet Then
Sheets(i).Delete
End If
Next i
CorrectValue = 0
Case vbNo
CorrectValue = 1
End Select
End Sub
Sub ACDSTest_Click(CorrectValue As Integer)
Dim NameSheet As String
Dim NameValue As String
NameSheet = "ACDS"
NameValue = "ACDS Test"
If ACDSTest.Value = True Then
CreateWorksheet (NameSheet), (NameValue)
Worksheets("Sheet1").Activate
Else
DeleteWorksheet (NameSheet)
If CorrectValue = 1 Then
ActiveSheet.Shapes("ACDS Test").ControlFormat.Value = 1
End If
End If
End Sub
The issue here is that the CorrectValue variable as you define it in DeleteWorksheet does not exist in the context of the
variable does not exist in context of the ACDSTest_Click subroutine. This is because variables defined within subroutines or functions are local to those functions. To correct this I would convert DeleteWorksheet to a function such as the below.
Further, the event that fires Private Sub ACDSTest_Click() cannot handle passing a value to that function, so changing it to Sub ACDSTest_Click(CorrectValue As Integer) causes an error.
Function DeleteWorksheet(ByVal SheetName As String) As Boolean
On Error GoTo SheetDNE
SheetName = Sheets(SheetName).Name 'Check if sheet exists w/o other objects
On Error GoTo 0
Select Case MsgBox("Would you like to take this test off of the form?", vbYesNo)
Case vbYes
Application.DisplayAlerts = False
Sheets(SheetName).Delete
Application.DisplayAlerts = True
DeleteWorksheet = True
Case Else: DeleteWorksheet = False
End Select
Exit Function 'Exit The Function w/o error
SheetDNE: 'Sheet Does Not Exist
MsgBox "The indicated sheet, " & SheetName & ", does not exist", vbOKOnly
End Function
And
Private Sub ACDSTest_Click()
Dim NameSheet As String
Dim NameValue As String
NameSheet = "ACDS"
NameValue = "ACDS Test"
If ACDSTest.Value = True Then
CreateWorksheet (NameSheet), (NameValue)
Worksheets("Sheet1").Activate
Else
If Not DeleteWorksheet(NameSheet) Then _
ActiveSheet.Shapes("ACDS Test").ControlFormat.Value = 1
End If
End Sub
I got an issue with "casting" variants to defined objects.
At runtime my variant variable is of type "Variant/Object/Listbox", which i then want to set to a ListBox variable to route it as a parameter to another function (GetSelected) that requires a Listbox object.
But I get the error 13: types incompatible on command "Set lst = v".
Any ideas how to get it working?
Code:
Function GetEditableControlsValues(EditableControls As Collection) As Collection
'Gibt die Werte der editierbaren Felder zurück.
Dim v As Variant
Dim coll As New Collection
Dim lst As ListBox
For Each v In EditableControls
If TypeName(v) = "ListBox" Then
Set lst = v 'Fehler 13: Typen unverträglich. v zur Laufzeit: Variant/Object/Listbox.
coll.Add GetCollectionString(GetSelected(lst))
Else
coll.Add v.Value
End If
Next
End Function
This is what I have so far:
Imagine that you have a module with the following code in it:
Option Explicit
Public Sub TestMe()
Dim colInput As New Collection
Dim colResult As Collection
Dim lngCount As Long
Dim ufMyUf As UserForm
Set ufMyUf = UserForm1
Set colInput = GetListBoxObjects(ufMyUf)
For lngCount = 1 To colInput.Count
Debug.Print colInput(lngCount).Name
Next lngCount
End Sub
Function GetListBoxObjects(uf As UserForm) As Collection
Dim colResult As New Collection
Dim objObj As Object
Dim ctrCont As Control
For Each ctrCont In uf.Controls
If LCase(Left(ctrCont.Name, 7)) = "listbox" Then
Set objObj = ctrCont
colResult.Add objObj
End If
Next ctrCont
Set GetListBoxObjects = colResult
End Function
If you run TestMe, you would get a collection of the ListBox objects. Anyhow, I am not sure how do you pass them to the collection function, thus I have decided to iterate over the UserForm and thus to check all of the objects on it.
Cheers!
I had problems with casting controls myself and didn't find a general solution that I could use easy.
Eventually I found the way to do it: store as "Object" makes it easy to convert to whatever type the control actually is.
I tested (and use) it
The sub below shows that it works (here : 1 TextBox; 1 ListBox; 1 ComboBox; 1 CommandButton on a worksheet)
Sub Test_Casting()
Dim lis As MSForms.ListBox
Dim txt As MSForms.TextBox
Dim btn As MSForms.CommandButton
Dim com As MSForms.ComboBox
Dim numObjects As Integer: numObjects = Me.OLEObjects.Count
Dim obj() As Object
ReDim obj(1 To numObjects) As Object
Dim i As Integer: i = 0
Dim cttl As OLEObject
For Each ctrl In Me.OLEObjects
i = i + 1
Set obj(i) = ctrl.Object
Next ctrl
Dim result As String
For i = 1 To numObjects
If TypeOf obj(i) Is MSForms.ListBox Then
Set lis = obj(i): result = lis.Name
ElseIf TypeOf obj(i) Is MSForms.TextBox Then
Set txt = obj(i): result = txt.Name
ElseIf TypeOf obj(i) Is MSForms.CommandButton Then
Set btn = obj(i): result = btn.Name
ElseIf TypeOf obj(i) Is MSForms.ComboBox Then
Set ComboBox = obj(i): result = com.Name
Else
result = ""
End If
If (Not (result = "")) Then Debug.Print TypeName(obj(i)) & " name= " & result
Next i
For i = 1 To numObjects
Set lis = IsListBox(obj(i))
Set txt = IsTextBox(obj(i))
Set btn = IsCommandButton(obj(i))
Set com = IsComboBox(obj(i))
result = ""
If (Not (lis Is Nothing)) Then
result = "ListBox " & lis.Name
ElseIf (Not (txt Is Nothing)) Then
result = "TexttBox " & txt.Name
ElseIf (Not (btn Is Nothing)) Then
result = "CommandButton " & btn.Name
ElseIf (Not (com Is Nothing)) Then
result = "ComboBox " & com.Name
End If
Debug.Print result
Next i
End Sub
Function IsListBox(obj As Object) As MSForms.ListBox
Set IsListBox = IIf(TypeOf obj Is MSForms.ListBox, obj, Nothing)
End Function
Function IsTextBox(obj As Object) As MSForms.TextBox
Set IsTextBox = IIf(TypeOf obj Is MSForms.TextBox, obj, Nothing)
End Function
Function IsComboBox(obj As Object) As MSForms.ComboBox
Set IsComboBox = IIf(TypeOf obj Is MSForms.ComboBox, obj, Nothing)
End Function
Function IsCommandButton(obj As Object) As MSForms.CommandButton
Set IsCommandButton = IIf(TypeOf obj Is MSForms.CommandButton, obj, Nothing)
End Function
One use for it is a class for handling events in one class.
Private WithEvents intEvents As IntBoxEvents
Private WithEvents decEvents As DecBoxEvents
Private genEvents As Object
Private genControl as OLEobject
Public sub Delegate(ctrl As OLEObject)
set genControl = ctrl
' Code for creating intEvents or decEvents
if .... create intevents.... then set genEvents = new IntEvents ' pseudo code
if .... create decevents.... then set genEvents = new DecEvents ' pseudo code
end sub
I hope this helps others that struggle with casting controls
I'm rewriting some code and had a thought, but can't seem to get my syntax right to execute it properly. I want to use a for loop to populate an array of commandbuttons as well as control their visibility. I just need help with my syntax to define which CommandButton number I'm working on in the loop. For instance, CommandButton1, CommandButton2, etc.
Public Sub LoadLots(sName As String, streamLots() As String)
Label1.Caption = sName
For o = 1 To 9
If streamLots(o) <> "" Then
CommandButton& o &.Caption = streamLots(o)
CommandButton& o & .Visable = True
Else
CommandButton& o & .Visable = False
End If
Next
End Sub
Use the Userform.Controls collection to reference the commandbuttons by name.
Public Sub LoadLots(sName As String, streamLots() As String)
Dim btn As MSForms.CommandButton
Label1.Caption = sName
For o = 1 To 9
Set btn = Me.Controls("CommandButton" & o)
If streamLots(o) <> "" Then
btn.Caption = streamLots(o)
btn.Visible = True
Else
btn.Visible = False
End If
Next
End Sub
I have a macro which run function (clear each named range depend ot application.caller.name) if radio button was clicked
Sub Clear_Click()
Dim s, f, arr
s = ActiveSheet.Shapes(Application.Caller).Name
arr = Array("NamedArray1", "NamedArray2", "NamedArray3", "NamedArray4")
Select Case s
Case "Clear7"
For i = LBound(arr) To UBound(arr)
ThisWorkbook.Worksheets("info").Range(arr(i)).value = ""
Next i
Case Else
f = arr(Right(s, 1) - 1)
ThisWorkbook.Worksheets("info").Range(f).value = ""
End Select
End Sub
It works ok.
Now i need to click Clear7 radio button from other function
So if i do
Sub test()
Application.Run ActiveSheet.Shapes("Clear7").OnAction
End Sub
I got error on s = ActiveSheet.Shapes(Application.Caller).Name as there are no Application.Caller i think.
So how to click radio button from other function?
If you're using Application.Caller but you want to run the code without someone needing to click the button then here's how you can do it.
NOTE: since Clear_Click has an argument, it won't show up in the "assign macro" list when attaching it to a button, but you can type its name directly in the box and that will work fine.
Sub Clear_Click(Optional callerName As String = "")
Dim s, f, arr, cn As String, i
Dim sht As Worksheet
cn = IIf(Len(callerName) > 0, callerName, Application.Caller)
'Debug.Print cn
Set sht = ThisWorkbook.Worksheets("info")
arr = Array("NamedArray1", "NamedArray2", "NamedArray3", "NamedArray4")
Select Case cn
Case "Clear7"
For i = LBound(arr) To UBound(arr)
sht.Range(arr(i)).Value = ""
Next i
Case Else
f = arr(Right(s, 1) - 1)
sht.Range(f).Value = ""
End Select
End Sub
Sub test()
ClickIt "Clear7"
End Sub
'run a macro attached to a shape and pass its name as a parameter
Sub ClickIt(sName As String)
Application.Run ActiveSheet.Shapes(sName).OnAction, sName
End Sub