VB right click copy/paste in multipage - excel

Let me preface my question with the fact that I am self taught, so please provide as much detail as possible and bear with me if I need you to explain differently or multiple times.
I created a notation/email generating tool for my team using Microsoft Visual Basic 7.0. The only complaint that I received on it was that many of them are not used to hot keys so they depend on using the mouse but right click didn't work. I was able to find code that creates a pop-up for copy and paste when they use right click, and it works great on the few textboxes that are on the main form itself, however it does not work on the majority of the textboxes as they are in a Multipage.
Does anyone know how to alter the below code to work for textboxes on a Multipage? Also, before it is suggested, I did toy with the idea of moving everything out of the Multipage, however that format is the easiest as there are multiple stages and types of notes/emails that they would need to send at any time, so having tabs available for them to simply click is the most user friendly that I was able to create and that they all agreed on.
Thank you all so much in advance!
Code in the form:
Dim cBar As clsBar
Private Sub UserForm_Initialize()
On Error GoTo Whoa
Application.EnableEvents = False
Set cBar = New clsBar
cBar.Initialize Me
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
Code in a Class Module:
Option Explicit
'Popup objects
Private cmdBar As CommandBar
Private WithEvents cmdCopyButton As CommandBarButton
Private WithEvents cmdPasteButton As CommandBarButton
'Useform to use
Private fmUserform As Object
'Control array of textbox
Private colControls As Collection
'Textbox Control
Private WithEvents tbControl As MSForms.TextBox
'Adds all the textbox in the userform to use the popup bar
Sub Initialize(ByVal UF As Object)
Dim Ctl As MSForms.Control
Dim cBar As clsBar
For Each Ctl In UF.Controls
If TypeName(Ctl) = "TextBox" Then
'Check if we have initialized the control array
If colControls Is Nothing Then
Set colControls = New Collection
Set fmUserform = UF
'Create the popup
CreateBar
End If
'Create a new instance of this class for each textbox
Set cBar = New clsBar
cBar.AssignControl Ctl, cmdBar
'Add it to the control array
colControls.Add cBar
End If
Next Ctl
End Sub
Private Sub Class_Terminate()
'Delete the commandbar when the class is destroyed
On Error Resume Next
cmdBar.Delete
End Sub
'Click event of the copy button
Private Sub cmdCopyButton_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
fmUserform.ActiveControl.Copy
CancelDefault = True
End Sub
'Click event of the paste button
Private Sub cmdPasteButton_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
fmUserform.ActiveControl.Paste
CancelDefault = True
End Sub
'Right click event of each textbox
Private Sub tbControl_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 2 And Shift = 0 Then
'Display the popup
cmdBar.ShowPopup
End If
End Sub
Private Sub CreateBar()
Set cmdBar = Application.CommandBars.Add(, msoBarPopup, False, True)
'We’ll use the builtin Copy and Paste controls
Set cmdCopyButton = cmdBar.Controls.Add(ID:=19)
Set cmdPasteButton = cmdBar.Controls.Add(ID:=22)
End Sub
'Assigns the Textbox and the CommandBar to this instance of the class
Sub AssignControl(TB As MSForms.TextBox, Bar As CommandBar)
Set tbControl = TB
Set cmdBar = Bar
End Sub

Get ActiveControl name on a Multipage control
It's necessary to know the multipage's selected Page via a helper function (ActiveControlName) using SelectedItem property and getting the control (its name) from there. Change your button click events as follows:
Relevant button click events in class module clsBar
'Click event of the copy button
Private Sub cmdCopyButton_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
Dim sACN As String
sACN = ActiveControlName(fmUserform) ' find control's name
' Debug.Print sACN & ".Copy"
fmUserform.Controls(sACN).Copy ' << instead of fmUserform.ActiveControl.Copy
CancelDefault = True
End Sub
'Click event of the paste button
Private Sub cmdPasteButton_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
Dim sACN As String
sACN = ActiveControlName(fmUserform)
' Debug.Print sACN & ".Paste"
fmUserform.Controls(sACN).Paste ' << instead of fmUserform.ActiveControl.Paste
CancelDefault = True
End Sub
Helper function called by above click events
Function ActiveControlName(form As UserForm) As String
'cf Site: https://stackoverflow.com/questions/47745663/get-activecontrol-inside-multipage
'Purpose: get ActiveControl
Dim MyMultiPage As MSForms.MultiPage, myPage As MSForms.Page
If form.ActiveControl Is Nothing Then
' do nothing
ElseIf TypeName(form.ActiveControl) = "MultiPage" Then
Set MyMultiPage = form.ActiveControl
Set myPage = MyMultiPage.SelectedItem
ActiveControlName = myPage.ActiveControl.Name
Else
ActiveControlName = form.ActiveControl.Name
End If
End Function
Side note
Suggest to check for the length of selected text strings in case of empty strings to prevent from unwanted results.

Related

Reading/returning variable values to/from custom classes to/from username - VBA Excel

I have a custom created class btnClass based on CommandButton class.
Public WithEvents ButtonEvent As MsForms.CommandButton
Private Sub ButtonEvent_Click()
End sub
I have a UserForm1 that have one ListBox, one Label, and hundreds of dynamically created CommandButtons. I assigned btnClass to Buttons. When clicked on buttons, I want the Click event has the following result:
If number of buttons selected (selQty) less than the Label.Caption (totalQty), and this button hasn't been selected before, add value to listBox and change BackColor.
if this button selected previously, change color and decrease number of buttons selected (selQty) by 1.
I tried creating Public variables, but cannot get the result I want. Is this doable?
P.S. when the UserForm1 is activated, it means no button selected; as I click button I change the color of the button and accept it as selected.
Seems like you want to do something like this
clsButtonClick:
Option Explicit
Public WithEvents ButtonEvent As MSForms.CommandButton
Private Sub ButtonEvent_Click()
'pass the button to the procedure in the userform
ButtonEvent.Parent.HandleClick ButtonEvent
End Sub
Userform code:
Option Explicit
Const CLR_SEL As Long = vbRed 'selected color
Const CLR_NOT_SEL As Long = vbGreen 'unselected color
Dim btnCol As Collection
Dim maxQty As Long 'max number selectable
Dim currQty As Long 'number currently selected
'perform some setup
Private Sub UserForm_Activate()
Const NUM_BUTTONS As Long = 10
Dim i As Long, btn As MSForms.CommandButton
Dim o As clsButtonClick
currQty = 0 'number selected
maxQty = 5 'max selectable
Set btnCol = New Collection
'add some buttons
For i = 1 To NUM_BUTTONS
Set btn = Me.Controls.Add("Forms.CommandButton.1", "btn" & i, True)
btn.BackColor = CLR_NOT_SEL
btn.Height = 18
btn.Left = 20
btn.Top = 20 * i
btn.Caption = "Button " & i
Set o = New clsButtonClick
Set o.ButtonEvent = btn
btnCol.Add o
Next i
End Sub
'handle a button click event (button is passed in)
Sub HandleClick(btn As MSForms.CommandButton)
If btn.BackColor = CLR_SEL Then
btn.BackColor = CLR_NOT_SEL
currQty = currQty - 1
Else
If currQty = maxQty Then
MsgBox "no more selections available"
Else
btn.BackColor = CLR_SEL
currQty = currQty + 1
End If
End If
End Sub
Here's something to get you started.
Create a wrapper class which wraps each button and handles its click event. Then when the form loads, loop through the controls and wrap the buttons.
A module level collection is required to hold the references of wrapped buttons (wrapper classes).
The ButtonWrapper class:
Option Explicit
Private WithEvents objButton As MsForms.CommandButton
'Wrap button
Public Function WrapCommandButton(btn As MsForms.CommandButton) As ButtonWrapper
Set objButton = btn
Set WrapCommandButton = Me
End Function
'Button's event handler
Private Sub objButton_Click()
MsgBox objButton.Caption & " was clicked."
End Sub
'Clean up
Private Sub Class_Terminate()
Set objButton = Nothing
End Sub
The code behind the Form:
Option Explicit
Private m_handlers As Collection
'Initialize
Private Sub UserForm_Initialize()
Set m_handlers = New Collection
Dim ctl As Control
For Each ctl In Me.Controls
If TypeName(ctl) = "CommandButton" Then
With New ButtonWrapper
m_handlers.Add .WrapCommandButton(ctl)
End With
End If
Next ctl
End Sub
'Clean up
Private Sub UserForm_Terminate()
Set m_handlers = Nothing
End Sub
Hope this helps.

Excel VBA Userform.Name as Variable to next Modul in case of Button Click

i really need some help, im new to VBA programming and just learn all by myself.
Thx for all Help.
What is my problem ?
I have more than 1 Userforms in my Tool and every Userform contains alot of Buttons some Buttons the same on other Userforms and some different.
if i click a button in a Userform, the class cant give my userform.name as a variable to the next module.
in the Code "Class" sUserform is alltime "nothing"
My Code
Userform
Option Explicit
Private myBtn As clsCMD
Private Sub UserForm_Activate()
modUI.ufGETICON Me
End Sub
Private Sub UserForm_Initialize()
modMSG.ufINFO
modAUTOOPEN.Workbook_Open Me
Dim ctrl As Control
For Each ctrl In frmMain.Controls
If TypeOf ctrl Is MSForms.CommandButton Then
Set myBtn = New clsCMD
Set myBtn.Button = ctrl
End If
Next
End Sub
Class
Option Explicit
Public WithEvents Button As MSForms.CommandButton
Private Sub Class_Initialize()
Static collButton As New Collection
collButton.Add Me
End Sub
Private Sub Button_Click()
Dim sButton As String
sButton = Button.Name
CMDTEST *sUserform*, Button
End Sub
Private Sub CMDTEST(*sUserform As Object*, sButton As Object)
If sButton.Name = "cmd_Admin" Then
modCMD.cmd_Admin
End If
If sButton.Name = "cmd_OItem" Then
modCMD.cmd_OItem sUserform
End If
End Sub
Modul
Option Explicit
Public sUserform As Object
Public Sub cmd_Admin()
Dim sAnswer As String
sAnswer = InputBox("Passwort f?r den Zugang zum Adminbereich eingeben:", "Zugang Adminbereich")
If sAnswer = sPASS Then
Unload frmMain
frmMain.Hide
ElseIf sAnswer = "" Then
Exit Sub
Else
MsgBox "Inkorrektes Passwort eingegeben", vbInformation + vbOKOnly, "Passwortabfrage negativ"
End If
Application.Visible = True
End Sub
Public Sub cmd_OItem(sUseform As Object)
sUserform.Hide
frmOnIt.Show
End Sub
It's difficult to give you a precise answer without seeing how you want to apply this code across your Userforms.
If, for example, you're running the loops on each Userform, then couldn't you just add a Userform property to your class and pass in the appropriate Userform?
For Each ctrl In frmMain.Controls
If TypeOf ctrl Is MSForms.CommandButton Then
Set myBtn = New clsCMD
With myBtn
Set .Owner = frmMain
Set .Button = ctrl
End With
End If
Next
Otherwise, I guess you'd just have to run up the control ladder until you find a Userform:
Private Function GetUserFormName(ctrl As Object) As String
Do
Set ctrl = ctrl.Parent
Loop Until TypeOf ctrl.Parent Is MSForms.UserForm And Not TypeOf ctrl.Parent Is MSForms.Frame
GetUserFormName = ctrl.Parent.Name
End Function
So your routine would contain code something like:
Private Sub CMDTEST(sButton As Object)
Dim n As String
n = GetUserFormName(sButton)
End Sub
I solved the problem now and I'd like to hear your feedback if it's a good way or not. Maybe there are some improvements to do?
You have to know this project is huge and i have more than 20 Userforms and over all Userforms more than 300 buttons.
Most of these buttons are like a Menu (laststep, nextstep, finish, cancel, OItem, Test, and some more). These are all doing the same every time,
and then i have some special buttons they are only 1-5 times on all userforms but these buttons should also doing the same on their Userforms (like refresh, change picture from Item, change something else etc.)
I tested this code on a VBA Project on 3 Userforms
Code starting everytime from modAUTOOPEN, Auto_Open
Userforms are:
ALL Userforms have the same code at this time for this test.
frmMain (starting site)
frmOnIt
frmTeM
.
Option Explicit
Private myBtn As clsCMD
Private myBtnColl As Collection
Private Sub UserForm_Activate()
modUI.ufGETICON Me
End Sub
Private Sub UserForm_Initialize()
modMSG.ufINFO
modAUTOOPEN.Workbook_Open Me
Dim ctrl As Control
Set myBtnColl = New Collection
For Each ctrl In Me.Controls
If TypeOf ctrl Is MSForms.CommandButton Then
Set myBtn = New clsCMD
Set myBtn.UserForm = Me
Set myBtn.button = ctrl
myBtnColl.Add myBtn
End If
Next
End Sub
Modules are:
modARCHIV
(not relevant, just old material - maybe its useful in the future)
modAUTOOPEN
(standard stuff)
.
Option Explicit
Public sUSER As String
Public Const sPASS As String = "12345"
Public Sub Workbook_Open(sUSerform As Object)
modUI.ufPOSITION1 sUSerform
End Sub
Public Sub Auto_Open()
' User basierend auf Exceluser ausw?hlen
sUSER = Application.Username
modData.defDEFAULTS
modData.defWORKSHEETS
Load frmMain
frmMain.Show
End Sub
modCHECKS
(not relevant atm, checking which users are using the tool etc.)
modCMD
(where I program all my CMDs for every UF)
.
Option Explicit
Public Sub cmd_Admin()
Dim sAnswer As String
sAnswer = InputBox("Passwort f?r den Zugang zum Adminbereich eingeben:", "Zugang Adminbereich")
If sAnswer = sPASS Then
Unload frmMain
frmMain.Hide
ElseIf sAnswer = "" Then
Exit Sub
Else
MsgBox "Inkorrektes Passwort eingegeben", vbInformation + vbOKOnly, "Passwortabfrage negativ"
End If
Application.Visible = True
End Sub
Public Sub cmd_OItem(sUfName As Object)
Application.ScreenUpdating = False
sUfName.Hide
frmOnIt.Show
End Sub
Public Sub cmd_Test(sUfName As Object)
Application.ScreenUpdating = False
sUfName.Hide
frmTeM.Show
End Sub
modDATA
(standard stuff)
modFUNC
(not relevant atm, for new functions)
modLOAD
(not relevant atm, load all datas to specific UF)
modMSG
(programming and updating all infoboxes on alle UF)
modSAVE
(not relevant atm, save all data from UF to WS or in new WB)
modUI
(checking how many screens and where to open, adding minimize button and windowstaskbar button, etc.)
ClassModules are:
clsCMD (should the connection betweend buttons on UF and modCMD)
.
Option Explicit
Public WithEvents button As MSForms.CommandButton
Private c_Userform As Object
Public Property Set UserForm(ByVal UfName As Object)
Set c_Userform = UfName
End Property
Private Sub Button_click()
CMDTEST UfName, button
End Sub
Public Sub CMDTEST(UfName As Object, button As Object)
Dim sButton As String
Dim sUfName As String
sButton = button.Name
sUfName = c_Userform.Name
If button.Name = "cmd_Admin" Then
modCMD.cmd_Admin
End If
If button.Name = "cmd_OItem" Then
modCMD.cmd_OItem c_Userform
End If
If button.Name = "cmd_Test" Then
modCMD.cmd_Test c_Userform
End If
'If Button.Name = "cmd_Auftragstool" Then
' modCMD.cmd_Auftragstool c_Userform
'End If
'If Button.Name = "cmd_Beenden" Then
' modCMD.cmd_Beenden c_Userform
'End If
End Sub

VBA Userform works when run directly but not when run through sub

I have a UserForm that prompts the user to both to select a file (Application.FileDialog(.soFileDialogOpen)) and to click a couple of options (various checkboxes). Both of these are required, so I want the OK button to only be enabled if a file has been selected and at least one checkbox has been clicked. I have a sub (CheckAndEnable) that runs both after a file is selected and after any checkbox is clicked (I am using a class to handle this).
Here is a very simplified version of the userform code. The userform has a button called buttonOK, a button that selects a file buttonSelectFile, and a variable number of checkboxes.
Option Explicit
Dim colChkboxes As Collection
Dim intchoice As Integer, AtLeastOneChecked As Boolean, strPath As String
Private Sub buttonOK_Click()
Hide
End Sub
Private Sub buttonSelectFile_Click()
Dim intchoice As Integer
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
intchoice = Application.FileDialog(msoFileDialogOpen).Show
If intchoice <> 0 Then
strPath = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
labelPath.Caption = strPath
End If
CheckAndEnable
End Sub
Public Sub CheckAndEnable()
Dim ctrl As Control
' checks all checkboxes to determine if at least one is checked
AtLeastOneChecked = False
For Each ctrl In Me.Controls
If TypeName(ctrl) = "CheckBox" Then
If ctrl.Value = True Then
AtLeastOneChecked = True
Exit For
End If
End If
Next ctrl
' enable the OK button if file selected and at least one checkbox clicked
If (AtLeastOneChecked = True) And (Not IsEmpty(strPath)) And (strPath <> "") Then
buttonOK.Enabled = True
Else
buttonOK.Enabled = False
End If
End Sub
Private Sub UserForm_Initialize()
buttonOK.Enabled = False
' declare vars
Dim ctrl As Control
Dim obj As clsCheckBox
Set colChkboxes = New Collection
' set each checkbox to CheckBox Class that handles if checkbox is
clicked.
For Each ctrl In Me.Controls
If TypeName(ctrl) = "CheckBox" Then
Set obj = New clsCheckBox
obj.AssignClicks ctrl
colChkboxes.Add obj
End If
Next ctrl
End Sub
I also have a Class Module clsCheckBox with the following code, which calls CheckAndEnable whenever a checkbox is clicked.
Private WithEvents chkbox As MSForms.CheckBox
Public Sub AssignClicks(ctrl As Control)
Set chkbox = ctrl
End Sub
Private Sub chkbox_Change()
Call MyUserform.CheckAndEnable
End Sub
When I run the UserForm directly, everything works beautifully. The problem is that when I call the userform in a module (this userform is part of a series of userforms in a larger script), the CheckAndEnable script runs when checkboxes are clicked but doesn't enable the OK button as it is supposed to. I have researched this extensively but haven't been able to find anything. Any help would be appreciated!
When you call MyUserform.CheckAndEnable in the chkbox_Change() sub of clsCheckBox, it runs the CheckAndEnable script for the default instance of the UserForm. Since the module showing the userform was creating a non-default instance of the form, the CheckAndEnable script was failing because it had no knowledge of what checkboxes/variables/etc had been changed in the non-default version.
Thanks to Mathieu Guindon for the solution. See UserForm1.Show for more details.

Excel VBA Userform Context Menu Class Code

Creating a contextual menu within an Excel User form that applies to Images...
I am trying to write a piece of VBA code to allow me to use a contextual menu generated from right clicking an Image on an Excel User form.
Andy Pope kindly gave the world a great bit of code to add a simple context menu that applies to textboxes within an Excel User form, but not Userform.Images.
http://www.andypope.info/vba/uf_contextualmenu.htm
I have edited his code ever so slightly to prevent the contextual usage of Locked = True textboxes.
'Copyright ©2007-2014 Andy Pope
Option Explicit
Private Const mEDIT_CONTEXTMENU_NAME = "ajpiEditContextMenu"
Private Const mCUT_TAG = "CUT"
Private Const mCOPY_TAG = "COPY"
Private Const mPASTE_TAG = "PASTE"
Private m_cbrContextMenu As CommandBar
Private WithEvents m_txtTBox As MSForms.TextBox
Private WithEvents m_cbtCut As CommandBarButton
Private WithEvents m_cbtCopy As CommandBarButton
Private WithEvents m_cbtPaste As CommandBarButton
Private m_objDataObject As DataObject
Private m_objParent As Object
Private Function m_CreateEditContextMenu() As CommandBar
'
' Build Context menu controls.
'
Dim cbrTemp As CommandBar
Const CUT_MENUID = 21
Const COPY_MENUID = 19
Const PASTE_MENUID = 22
Set cbrTemp = Application.CommandBars.Add(mEDIT_CONTEXTMENU_NAME, Position:=msoBarPopup)
With cbrTemp
With .Controls.Add(msoControlButton)
.Caption = "Cu&t"
.FaceId = CUT_MENUID
.Tag = mCUT_TAG
End With
With .Controls.Add(msoControlButton)
.Caption = "&Copy"
.FaceId = COPY_MENUID
.Tag = mCOPY_TAG
End With
With .Controls.Add(msoControlButton)
.Caption = "&Paste"
.FaceId = PASTE_MENUID
.Tag = mPASTE_TAG
End With
End With
Set m_CreateEditContextMenu = cbrTemp
End Function
Private Sub m_DestroyEditContextMenu()
On Error Resume Next
Application.CommandBars(mEDIT_CONTEXTMENU_NAME).Delete
Exit Sub
End Sub
Private Function m_GetEditContextMenu() As CommandBar
On Error Resume Next
Set m_GetEditContextMenu = Application.CommandBars(mEDIT_CONTEXTMENU_NAME)
If m_GetEditContextMenu Is Nothing Then
Set m_GetEditContextMenu = m_CreateEditContextMenu
End If
Exit Function
End Function
Private Function m_ActiveTextbox() As Boolean
'
' Make sure this instance is connected to active control
' May need to drill down through container controls to
' reach ActiveControl object
'
Dim objCtl As Object
Set objCtl = m_objParent.ActiveControl
Do While UCase(TypeName(objCtl)) <> "TEXTBOX"
If UCase(TypeName(objCtl)) = "MULTIPAGE" Then
Set objCtl = objCtl.Pages(objCtl.Value).ActiveControl
Else
Set objCtl = objCtl.ActiveControl
End If
Loop
m_ActiveTextbox = (StrComp(objCtl.Name, m_txtTBox.Name, vbTextCompare) = 0)
ErrActivetextbox:
Exit Function
End Function
Public Property Set Parent(RHS As Object)
Set m_objParent = RHS
End Property
Private Sub m_UseMenu()
Dim lngIndex As Long
For lngIndex = 1 To m_cbrContextMenu.Controls.Count
Select Case m_cbrContextMenu.Controls(lngIndex).Tag
Case mCUT_TAG
Set m_cbtCut = m_cbrContextMenu.Controls(lngIndex)
Case mCOPY_TAG
Set m_cbtCopy = m_cbrContextMenu.Controls(lngIndex)
Case mPASTE_TAG
Set m_cbtPaste = m_cbrContextMenu.Controls(lngIndex)
End Select
Next
End Sub
Public Property Set TBox(RHS As MSForms.TextBox)
Set m_txtTBox = RHS
End Property
Private Sub Class_Initialize()
Set m_objDataObject = New DataObject
Set m_cbrContextMenu = m_GetEditContextMenu
If Not m_cbrContextMenu Is Nothing Then
m_UseMenu
End If
End Sub
Private Sub Class_Terminate()
Set m_objDataObject = Nothing
m_DestroyEditContextMenu
End Sub
Private Sub m_cbtCopy_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
' check active textbox is this instance of CTextBox_ContextMenu
If m_ActiveTextbox() Then
With m_objDataObject
.Clear
.SetText m_txtTBox.SelText
.PutInClipboard
End With
End If
End Sub
Private Sub m_cbtCut_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
If m_txtTBox.Locked = True Then
Exit Sub
End If
' check active textbox is this instance of CTextBox_ContextMenu
If m_ActiveTextbox() Then
With m_objDataObject
.Clear
.SetText m_txtTBox.SelText
.PutInClipboard
m_txtTBox.SelText = vbNullString
End With
End If
End Sub
Private Sub m_cbtPaste_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
If m_txtTBox.Locked = True Then
Exit Sub
End If
' check active textbox is this instance of CTextBox_ContextMenu
On Error GoTo ErrPaste
If m_ActiveTextbox() Then
With m_objDataObject
.GetFromClipboard
m_txtTBox.SelText = .GetText
End With
End If
ErrPaste:
Exit Sub
End Sub
Private Sub m_txtTBox_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
If Button = 2 Then
' right click
m_cbrContextMenu.ShowPopup
End If
End Sub
What can I add to this code for the same context menu to apply with Images?
Something along the lines of...
Adding Private WithEvents m_imgImage As MSForms.Image
Private m_cbrContextMenu As CommandBar
Private WithEvents m_txtTBox As MSForms.TextBox
Private WithEvents m_imgImage As MSForms.Image
Private WithEvents m_cbtCut As CommandBarButton
Private WithEvents m_cbtCopy As CommandBarButton
Private WithEvents m_cbtPaste As CommandBarButton
Private m_objDataObject As DataObject
Private m_objParent As Object
Private Function m_CreateEditContextMenu() As CommandBar
Declaring a New Private Function
Private Function m_ActiveImage() As Boolean
'
' Make sure this instance is connected to active control
' May need to drill down through container controls to
' reach ActiveControl object
'
Dim objCtl As Object
Set objCtl = m_objParent.ActiveControl
Do While UCase(TypeName(objCtl)) <> "IMAGE"
If UCase(TypeName(objCtl)) = "MULTIPAGE" Then
Set objCtl = objCtl.Pages(objCtl.Value).ActiveControl
Else
Set objCtl = objCtl.ActiveControl
End If
Loop
m_ActiveImage = (StrComp(objCtl.Name, m_imgImage.Name, vbTextCompare) = 0)
ErrActiveimage:
Exit Function
End Function
I would need to declare a new Public Property Set
Public Property Set Img(RHS As MSForms.Image)
Set m_imgImage = RHS
End Property
Each context menu option would need altering to include the possibility of a user right clicking on an image...
Private Sub m_cbtCopy_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
' check active image is this instance of CTextBox_ContextMenu
If m_ActiveTextbox() Then
With m_objDataObject
.Clear
.SetText m_txtTBox.SelText
.PutInClipboard
End With
End If
' check active image is this instance of CImage_ContextMenu
If m_ActiveImage() Then
With m_objDataObject
.Clear
'What would be the image alternative for this next line of code?
'.SetText m_imgImage.SelText
.PutInClipboard
End With
End If
End Sub
*You will note that I am only using the Copy feature of the context menu as Cutting and Pasteing from within an User form will not be required (or stable for that matter!).
And finally I would need to recreate the trigger...
Private Sub m_imgImage_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
If Button = 2 Then
' right click
m_cbrContextMenu.ShowPopup
End If
End Sub
It seems like an awful lot of unnecessary work, there must be an easier way.
Any help or advice is much appreciated, and once again thank you for your time.
Mr J.
If I have understood your question right, you just want to respond to all image click in one sub. This is how I do it. First create a class called ImageClickResponder (for this example) and add the following:
Option Explicit
Private Type Properties
Obj As Object
Procedure As String
CallType As VbCallType
End Type
Private this As Properties
Private WithEvents img As MSForms.Image
Public Sub Initialize(ByRef imgRef As MSForms.Image, ByRef Obj As Object, ByVal procedureName As String, ByVal CallType As VbCallType)
Set img = imgRef
With this
Set .Obj = Obj
.Procedure = procedureName
.CallType = CallType
Debug.Print imgRef.Name
End With
End Sub
Private Sub img_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
VBA.CallByName this.Obj, this.Procedure, this.CallType, Button, Shift, X, Y
End Sub
Then in your user form put this:
Option Explicit
Private micrs() As ImageClickResponder
Private Sub UserForm_Initialize()
micrs = LoadImageClickResponders(Me)
End Sub
Public Sub AllImgs_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Debug.Print "Your context menu code here"
End Sub
Private Function LoadImageClickResponders(ByRef frm As MSForms.UserForm) As ImageClickResponder()
Dim rtnVal() As ImageClickResponder
Dim ctrl As MSForms.Control
Dim i As Long
For Each ctrl In frm.Controls
If TypeOf ctrl Is MSForms.Image Then
ReDim Preserve rtnVal(i) As ImageClickResponder
Set rtnVal(i) = New ImageClickResponder
rtnVal(i).Initialize ctrl, Me, "AllImgs_MouseDown", VbMethod
i = i + 1
End If
Next
LoadImageClickResponders = rtnVal
End Function

show custom toolbar only with certain xls-file

i have a macro (Makro1) that is assigned to a button in a custom toolbar (Custom1) with caption "Schutzstatus". i want the toolbar only to be loaded with this very xls-file.
can someone help me out with the code?
i managed to customize the tooltip:
Application.CommandBars("Custom1").Controls(1).TooltipText = "Abfrage des Schutzstatus der Arten im Zwischenspeicher"
but i fail in creating the whole thing by vba..
thanks in advance,
kay
You don't actually need to (re)create the whole toolbar on loading your XLS, but you need to display/hide it during certain navigations
1 create the toolbar
2 attach it to your XLS (view / toolbars / customize .... / attach)
3 create event procedures to show/hide your toolbar; unless you want to have a specific behaviour for different sheets, the following should be enough to care for all navigation:
Private Sub Workbook_Activate()
' show toolbar
Application.CommandBars("CoolBar").Visible = True
Application.CommandBars("CoolBar").Controls(1).TooltipText = "C'mon squeeze me"
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
' drop toolbar
Application.CommandBars("CoolBar").Delete
End Sub
Private Sub Workbook_Deactivate()
' see if we have a toolbar (it might have been already deleted by "Workbook_BeforeClose"
' if yes - hide it
Dim Idx As Integer
For Idx = 1 To Application.CommandBars.Count
If Application.CommandBars(Idx).Name = "CoolBar" Then
Application.CommandBars("CoolBar").Visible = False
End If
Next Idx
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
' display toolbar
Application.CommandBars("CoolBar").Visible = True
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
Application.CommandBars("CoolBar").Visible = False
End Sub
Place all in the "ThisWorkbook" object - so they fire on all sheets.
4 After saving the toolbar with the XLS and testing, close the XLS - the toolbar will be still present in your application object - and delete the toolbar from there. Don't panic, it's coming back when you re-open your XLS file.
Hope this helps
Tschüss MikeD
Actually the answer was close but didn't work for me. That .Delete does delete the command bar completely as confirmed by Kay in his last comment. You basically had to recreate but bar and button again when the workbook is opened. Below is the improved code:
Private Sub Workbook_Activate()
' show toolbar
Dim SortBar As CommandBar
Dim BarControl As CommandBarControl
Set SortBar = FindCommandBar("SortBar")
If SortBar Is Nothing Then
Set SortBar = Application.CommandBars.Add("SortBar")
Set BarControl = SortBar.Controls.Add
BarControl.OnAction = "Your_Macro_Name"
BarControl.Caption = "Text for your button"
BarControl.Style = msoButtonCaption
End If
SortBar.Visible = True
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
' drop toolbar
Application.CommandBars("SortBar").Delete
End Sub
Private Sub Workbook_Deactivate()
' see if we have a toolbar (it might have been already deleted by "Workbook_BeforeClose"
' if yes - hide it
Dim SortBar As CommandBar
Set SortBar = FindCommandBar("SortBar")
If Not SortBar Is Nothing Then
SortBar.Visible = False
End If
End Sub
Private Function FindCommandBar(Name As String) As CommandBar
Dim Idx As Integer
For Idx = 1 To Application.CommandBars.Count
Set FindCommandBar = Application.CommandBars(Idx)
If FindCommandBar.Name = Name Then
Exit Function
End If
Next Idx
Set FindCommandBar = Nothing
End Function
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
' display toolbar
Application.CommandBars("SortBar").Visible = True
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
Application.CommandBars("SortBar").Visible = False
End Sub

Resources