I have an excel sheet that makes a custom toolbar. Within this toolbar, I have several buttons that use faceIDs, which are no problem. I have a few buttons where I wanted to use custom icons. When I use the custom icons, sometimes the PasteFace works, sometimes it does not, and I get an error. I added an On Error Resume next statement, to see what was happening. Sometimes both buttons paste ok, sometimes just one button, sometimes neither button. I can find no pattern to it working or not working.
My toolbar consists of approximately 24 buttons, and one drop down box. Eleven of the buttons use a custom icon, the remainder use a FaceID. Some buttons are toggled to display or not display based on user needs. The example below shows 2 buttons that will toggle to turn a meal penalty on or off. I only picked these 2 buttons because these are first buttons to use a custom icon.
Sub Make_PayBar()
Dim PayBar As CommandBar
Dim NewButton As CommandBarButton
'Delete existing PayBar toolbar if it exists
Call Kill_PayBar
ThisWorkbook.Activate
On Error Resume Next
'Create New PayBar
Set PayBar = Application.CommandBars.Add(Name:="Payroll Bar", Temporary:=True)
PayBar.Visible = True
PayBar.Position = msoBarTop
... Missing Code, More buttons ...
'Meal Penalty Off Button
Set NewButton = PayBar.Controls.Add(Type:=msoControlButton, Parameter:="Meal_Off")
NewButton.Caption = "Meal Penalty Off"
NewButton.OnAction = "ToggleMeal"
'NewButton.FaceId = 1254 'Backup if pasteface fails
Sheets("Pics").Shapes("Meal_Off").Copy
NewButton.PasteFace
'Meal Penalty On Button
Set NewButton = PayBar.Controls.Add(Type:=msoControlButton, Parameter:="Meal_On")
NewButton.Caption = "Meal Penalty On"
NewButton.OnAction = "ToggleMeal"
'NewButton.FaceId = 1253 'Backup if pasteface fails
Sheets("Pics").Shapes("Meal_On").Copy
NewButton.PasteFace
NewButton.Visible = False
... Missing Code, More buttons ...
End sub
If the Resume Next is not used, the error may occurs on either of the two pasteface statements.
Is there something in my code making PastFace unreliable?
If PasteFace is inherently unreliable, is there a way to check for a successful paste, and repeat if it wasn't?
Is there a better way to do this?
Worksheets have hidden collections that hold pictures and ActiveX controls. The VBA also has a hidden Picture type. Pictures have a CopyPicture method that is more consistent then `Shape.Copy.
Press F2 to open the Object Browser, right click and choose Show Hidden Members
Function picMeal_Off() As Picture: Set picMeal_Off = ThisWorkbook.Worksheets("Pics").Pictures("Meal_Off"): End Function
Function picMeal_on() As Picture: Set picMeal_on = ThisWorkbook.Worksheets("Pics").Pictures("Meal_on"): End Function
Sub Make_PayBar()
Dim PayBar As CommandBar
Dim NewButton As CommandBarButton
Set PayBar = Application.CommandBars.Add(Name:="Payroll Bar", Temporary:=True)
PayBar.Visible = True
PayBar.Position = msoBarTop
Set NewButton = PayBar.Controls.Add(Type:=msoControlButton, Parameter:="Meal_Off")
NewButton.Caption = "Meal Penalty Off"
NewButton.OnAction = "ToggleMeal"
picMeal_Off.CopyPicture
NewButton.PasteFace
End Sub
I created functions to refer to the Pictures by using this macro:
Sub PrintPitureDefs(ws As Worksheet)
Const BaseCode As String = "Function picCodeName() As Picture:Set picCodeName = ThisWorkbook.Worksheets(""WorksheetName"").Pictures(""PictureName""):End Function"
Dim Code As String
Dim Img As Picture
For Each Img In ws.Pictures
Code = Replace(BaseCode, "WorksheetName", ws.Name)
Code = Replace(Code, "PictureName", Img.Name)
Code = Replace(Code, "CodeName", Replace(Img.Name, " ", "_"))
Debug.Print Code
Next
End Sub
Related
I'm trying to get this presumably very cool bit of code that presumably works out of the box on Windows to work on a Mac. I think I'm 99% there, but the Mac is unhappy with the way it's adding menus to the UI. The original code that the Mac doesn't like is this:
Public Sub createMenu()
Dim rootMenu As CommandBarPopup
'Add the top-level menu to the ribbon Add-ins section
Set rootMenu = Application.CommandBars(1).Controls.Add(Type:=msoControlPopup, _
Before:=10, _
Temporary:=True)
rootMenu.caption = MENU_TITLE
which throws a type mismatch error on the Set line. After a fair bit of fiddling to try and figure out what's happening, I've gotten to this:
Dim rootMenuBar As CommandBar
Dim rootMenu As Object
'Add the top-level menu to the ribbon Add-ins section
'Set rootMenu = Application.CommandBars(1).Controls.Add(Type:=msoControlPopup, _
'Before:=10, _
'Temporary:=True)
Application.ScreenUpdating = False
deleteMenu
Set rootMenuBar = CommandBars.Add _
(name:=MENU_TITLE, position:=msoBarBottom, Temporary:=True)
Set rootMenu = rootMenuBar.Controls.Add(msoControlPopup)
With rootMenu
.BeginGroup = True
.caption = MENU_TITLE
.Tag = MENU_TITLE
End With
which almost works, but the problem is, rootMenu is a CommandBarControl object, not a CommandBarPopup object, which is what the rest of the code expects. The MS Docs for CommandBarPopup claim that you can use the FindControl method to return a CommandBarPopup, so I tried this:
With rootMenuBar
.Controls.Add (msoControlPopup)
End With
Set rootMenu = rootMenuBar.FindControl(Type:=msoControlPopup)
But no dice: it's still returning a CommandBarControl object. Any idea how I can get it to make a CommandBarPopup object?
NB: I guess The Right Way to do this is to redo the UI using the Fluent ribbon stuff, but ... that's a much larger project than I'm looking to take on right now.
I have a UserForm which lets the user input a count of product defects into a textbox. This is done as part of monthly reporting, so I have option buttons to select the Month (12 options). There are also option buttons for selecting Product Type. The code basically evaluates what options are selected and copies the textbox values (defect counts) into specific cells in another spreadsheet (for reporting purposes). Not all TextBoxes are required to have values entered by the User.
You can check out a screenshot of the UserForm https://imgur.com/a/6QefjCp.
As you can see from the code, I'm using a bunch of IF statements to perform the decision making - I would like to reduce the length of this code, but I don't know where to start.
I have never really used VBA prior to this, so haven't really attempted a solution. In its current state, the code works flawlessly. Just looking to reduce and clean-up.
Private Sub OKButton_Click() 'This is the button the user clicks to finalize
'the data entry
'Calling the Product type modules
Call Product1Module
Call Product2Module
Call Product3Module
End Sub
Sub Product1Module() 'All product modules will look almost exactly like this
'except the cell ranges will be different
If UserForm.Product1Button.Value = True Then 'Checking for Product1 Option button
If UserForm.JANButton.Value = True Then
'Record value to textbox if JAN is selected
Sheets("Sheet1").Range("B1107").Value = UserForm.TextBox1.Value
Sheets("Sheet1").Range("B1115").Value = UserForm.TextBox2.Value
Sheets("Sheet1").Range("B1108").Value = UserForm.TextBox3.Value
Sheets("Sheet1").Range("B1116").Value = UserForm.TextBox4.Value
Sheets("Sheet1").Range("B1109").Value = UserForm.TextBox5.Value
Sheets("Sheet1").Range("B1117").Value = UserForm.TextBox6.Value
Sheets("Sheet1").Range("B1111").Value = UserForm.TextBox7.Value
ElseIf UserForm.FEBButton.Value = True Then
Sheets("Sheet1").Range("C1107").Value = UserForm.TextBox1.Value
Sheets("Sheet1").Range("C1115").Value = UserForm.TextBox2.Value
Sheets("Sheet1").Range("C1108").Value = UserForm.TextBox3.Value
Sheets("Sheet1").Range("C1116").Value = UserForm.TextBox4.Value
Sheets("Sheet1").Range("C1109").Value = UserForm.TextBox5.Value
Sheets("Sheet1").Range("C1117").Value = UserForm.TextBox6.Value
Sheets("Sheet1").Range("C1111").Value = UserForm.TextBox7.Value
...
End If
End If
End Sub
Give each of your option buttons a Tag property value - e.g. make JANButton.Tag be "B", then make FeBButton.Tag be "C", etc.
Then you can do this:
Dim targetColumn As String
Select Case True
Case UserForm.JANButton
targetColumn = UserForm.JANButton.Tag
Case UserForm.FEBButton
targetColumn = UserForm.FEBButton.Tag
'...
End Select
With Worksheets("Sheet1") '<~ which workbook is that in? whatever is active?
.Range(targetColumn & "1107").Value = UserForm.TextBox1.Value
.Range(targetColumn & "1115").Value = UserForm.TextBox2.Value
'...
End With
I'm setting up an Excel worksheet where I need to dynamically generate Active-X buttons and set up a different action for each one.
I get
run time error 459 "Object or class does not support the class of events"
when I launch it.
I've seen similar questions but the solutions have been given for userforms.
My current solution.
I have a custom class module WoExp_FSelect_Btn:
Public WithEvents btn As OLEObject
Public id As Integer
Dim iCount As Long
' Action to handle button click
Private Sub btn_Click()
'*** just for debug: show msgbox with id
MsgBox ("ID: " & id) 'Debug
End Sub
A collection is created with global scope to fit this kind of objects:
Public WoExp_DFileSel_Buttons As New Collection
Then I dynamically create the buttons running the following function inside a loop, i being the loop iteration:
Private Sub WoExp_AddFileSel_Btn(i As Integer)
Dim cmdbtn As OLEObject
Dim FselBtnWithEvents As WoExp_FSelect_Btn
Set cmdbtn = Worksheets("Word Report Gen").OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
Link:=False, DisplayAsIcon:=False, Left:=50, Top:=80, Width:=75, _
Height:=30)
cmdbtn.Left = Worksheets("Word Report Gen").Cells(13 + i, 3).Left
cmdbtn.Top = Worksheets("Word Report Gen").Cells(13 + i, 3).Top
cmdbtn.Name = "WoExpDFileSel_Btn_" + CStr(i)
Set FselBtnWithEvents = New WoExp_FSelect_Btn
Set FselBtnWithEvents.btn = cmdbtn
FselBtnWithEvents.id = i
WoExp_DFileSel_Buttons.Add FselBtnWithEvents
End Sub
All buttons are properly shown if I comment the Set FselBtnWithEvents.btn = cmdbtn line, so I think that the problem is that OLEobject class and WithEvents don't go along.
As the error states, the OLEObject object does not support the Click event. If you go to your class module, select btn from the Object dropdown menu, and then click on the Procedure dropdown menu, you'll see that it only supports GotFocus and LostFocus.
However, when I replaced the Click event with either GotFocus or LostFocus, the same error occurred. So maybe there's some sort of bug.
I have created a tool using Excel to gather inputs from a user and use it to do some processing of data. I have created a UI on a worksheet with a bunch of ActiveX controls (TextBox, ListBox, ComboBox).
Part of the ActiveX controls are dynamic - they are added at run time based on "metadata" that the tool admin creates on a second worksheet. Metadata contains the field name, type of ActiveX control, position of the control, ListRange to populate values, Multi-Text/Multi-Select flag, etc.
I am able to successfully add the ActiveX controls to the UI worksheet. However, now I want to add functionality for ActiveX TextBox controls to show a default text, when the control gets focus - default text gets removed, when the control loses focus - if user has entered any data it remains otherwise the default text shows up again.
Public Sub df_segment_GotFocus()
Dim wb As Workbook
Set wb = ThisWorkbook
Set form_sheet = Worksheets(Sheet1.Name)
If form_sheet.OLEObjects("df_segment") Is Nothing Then
Else
'When user begins to type, remove the help text and remove Italics
Dim seg_val As String
seg_val = form_sheet.OLEObjects("df_segment").Object.Value
If seg_val = "e.g. Desktop-Mac,Desktop-Win,Mobile-OSX" Then
form_sheet.OLEObjects("df_segment").Object.Font.Italic = False
form_sheet.OLEObjects("df_segment").Object.Value = ""
Else
form_sheet.OLEObjects("df_segment").Object.Value = seg_val
End If
End If
End Sub
Public Sub df_segment_LostFocus()
Dim wb As Workbook
Set wb = ThisWorkbook
Set form_sheet = Worksheets(Sheet1.Name)
If form_sheet.OLEObjects("df_segment") Is Nothing Then
Else
'Incase user doesn't enter any values, show the help text again
Dim seg_val As String
seg_val = form_sheet.OLEObjects("df_segment").Object.Value
If seg_val = "" Then
form_sheet.OLEObjects("df_segment").Object.Font.Italic = True
form_sheet.OLEObjects("df_segment").Object.Value = "e.g. Desktop-Mac,Desktop-Win,Mobile-OSX"
Else
form_sheet.OLEObjects("df_segment").Object.Value = seg_val
End If
End If
End Sub
In the sample code above, you can see that I am using the exact name of the control to setup the GotFocus and LostFocus event handlers. However, since my UI is metadata driven, the controls will be added/removed dynamically and I wouldn't know the name of the controls to explicitly add the event handlers.
I looked up the forums and implemented this:
a.) Implemented a Class Module
Public WithEvents df_TextBox As MSForms.TextBox
Public df_TextBox_Name As String
Private Sub df_TextBox_Change()
Dim wb As Workbook
Set wb = ThisWorkbook
Set form_sheet = Worksheets(Sheet1.Name)
Set metadata_sheet = Worksheets(Sheet2.Name)
Dim obj_name As String
obj_name = df_TextBox_Name
obj_val = form_sheet.OLEObjects(obj_name).Object.Value
MsgBox "Change in TextBox" & obj_val
End Sub
b.) Created objects for the Class where I instantiate the control objects
ElseIf d_Type = "TextBox" Then
df_obj.Object.Value = d_def_val
df_obj.Object.Font.Italic = True
If d_Multi = 1 Then
df_obj.Object.MultiLine = True
End If
'--------------------------------------------------------------
'part where we add the custom events for GotFocus and LostFocus
'--------------------------------------------------------------
ReDim Preserve TextBox_Event_Array(1 To i)
Set TextBox_Event_Array(i).df_TextBox = df_obj.Object
TextBox_Event_Array(i).df_TextBox_Name = df_obj.Name
Problem Statements
1.) When I create the class module, I don't see the GotFocus and LostFocus events available. Only Change, KeyDown/Press/Up, MouseDown/Move/Up
2.) I created a Change event handler just to test the Class Module but I do not see it getting triggered.
Any suggestions on how can I fix the problem or any alternate solutions?
I'm trying to make my own drill-through action for PivotTable by means of VBA.
The action will be called from context menu of a PivotTable from Additional Actions.
I want to put my button under Additional Actions control of PivotTable Context Menu command bar.
The point is that by default Additional Actions already contains (No Actions Defined) item.
So, I want to remove this (No Actions Defined) after adding my button, but nothing works.
I cannot even change any property of (No Actions Defined) control, like Caption, Visible, etc.
What might be the reason, and what is the workaround?
Here is my code so far (you can put it under Workbook_SheetBeforeRightClick, for example, and then test with any Pivot Table in that workbook):
Dim PCell As PivotCell
Dim PComBar As CommandBar
Dim PControl As CommandBarControl
Dim DControl As CommandBarControl
Dim BControl As CommandBarControl
Dim IsFromPivotTable As Boolean
IsFromPivotTable = False
On Error GoTo NotFromPivot
Set PCell = Target.PivotCell
IsFromPivotTable = True
NotFromPivot:
On Error GoTo 0
If IsFromPivotTable Then
Set PComBar = Application.CommandBars("PivotTable Context Menu")
Set PControl = PComBar.Controls("Additional Actions")
On Error Resume Next
With PControl
Call .Controls("My Drillthrough Action").Delete
.Enabled = True
End With
On Error GoTo 0
Set DControl = PControl.Controls.Add(Type:=msoControlButton, Temporary:=True, Before:=1)
With DControl
.Style = msoButtonIconAndCaption
.Caption = "My Drillthrough Action"
.FaceId = 786
End With
On Error Resume Next
Set BControl = PControl.Controls("(No Actions Defined)")
With BControl 'This does not work and throws error if do not suppress with On Error
.Enabled = True
.Visible = False
.Caption = "Hello there"
End With
On Error GoTo 0
End If
So, the last section With BControl ... End With does not work at all, and throws an error "Automation Error".
I can successfully edit Additional Actions itself, like enable it, but I would like to get rid of (No Actions Defined) control, or replace it with my own.
Note, that Call .Controls("(No Actions Defined)").Delete does not work either.
How can I do that?
I tried to google the problem, but no luck...
I suspect you can't add to that menu. You could, however, add to the context menu itself:
Sub test()
Dim PCell As PivotCell
Dim PComBar As CommandBar
Dim DControl As CommandBarControl
Dim target As Excel.Range
Set target = ActiveCell
On Error Resume Next
Set PCell = ActiveCell.PivotCell
On Error GoTo 0
If Not PCell Is Nothing Then
Set PComBar = Application.CommandBars("PivotTable Context Menu")
Set DControl = PComBar.Controls.Add(Type:=msoControlButton, Temporary:=True, Before:=1)
With DControl
.Style = msoButtonIconAndCaption
.Caption = "My Drillthrough Action"
.FaceId = 786
End With
End If
End Sub