pop up menu
 

I want to raise a custom pop up menu when I right click in
a user form text box . I have the code that tells me which
mouse button was pressed when in the TB so all I need is
the code for the pop up.
I have tried the following from the VBA help files......

Set copyAndPasteMenu = CommandBars.Add( _
Name:="Custom", Position:=msoBarPopup, _
Temporary:=True)
Set copy = copyAndPasteMenu.Controls.Add
With copy
.FaceId = CommandBars("Standard").Controls("Copy").Id
.Caption = "Copy the selection"
End With
Set paste = copyAndPasteMenu.Controls.Add
With paste
.FaceId = CommandBars("Standard").Controls("Paste").Id
.Caption = "Paste from the Clipboard"
End With
copyAndPasteMenu.ShowPopup 200, 200

.......which works fine and would do what I want, but it
only ever runs once. If I try running it a second time I
get an error associated with first line of code. If I
close the application and Excel then restart all, it works
again, but just the once.
I notice it has no provision to delete the named
command bars it might have previously created . Could this
be the problem??
Any help from those wiser than I would be greatly
appreciated.
Don Bowyer

pop up menu
 

Hi don bowyer;
Try this (The copy is possible between controls and the active sheet and
controls).
In the UserForm module:
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function EnableWindow Lib "user32" (ByVal hWnd As Long _
, ByVal fEnable As Long) As Long
Private xOffset As Single, yOffset As Single

Private Sub TextBox1_MouseDown(ByVal Button As Integer _
, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 2 Then Call PopUpMenuConfig(X, Y)
End Sub

Private Sub TextBox2_MouseDown(ByVal Button As Integer _
, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 2 Then Call PopUpMenuConfig(X, Y)
End Sub

Private Sub UserForm_Initialize()
EnableWindow FindWindow(vbNullString, Application.Caption), 1
xOffset = (Me.Width - Me.InsideWidth) / 2
yOffset = Me.Height - Me.InsideHeight - xOffset
Call PopUpMenuCreate
End Sub

Private Sub PopUpMenuDelete(ByVal PopUpMenuName As String)
On Error Resume Next
CommandBars(PopUpMenuName).Delete
End Sub

Private Sub PopUpMenuCreate()
Call PopUpMenuDelete("PopUpCb")
Dim cb As CommandBar
Set cb = CommandBars.Add("PopUpCb", msoBarPopup, False, True)
Call AddItemInMenu(cb, "&Cut", 21, "'PopUpMenuItem""" & "1""'")
Call AddItemInMenu(cb, "Co&py", 110, "'PopUpMenuItem""" & "2""'")
Call AddItemInMenu(cb, "P&aste", 111, "'PopUpMenuItem""" & "3""'")
Call AddItemInMenu(cb, "&Select", 223, "'PopUpMenuItem""" & "4""'", True)
Call AddItemInMenu(cb, "&Delete", 47, "'PopUpMenuItem""" & "5""'")
Set cb = Nothing
End Sub

Private Sub AddItemInMenu(cbControl As Object, cbCaption As String _
, cbFaceId As Integer, cbOnAction As String, Optional NewGroup As Boolean = False)
With cbControl.Controls.Add(msoControlButton, 1, , , True)
.BeginGroup = NewGroup
.Caption = cbCaption
.Style = msoButtonIconAndCaption
.FaceId = cbFaceId
.OnAction = ThisWorkbook.Name & "!" & cbOnAction & ""
End With
End Sub

Private Function xPos(X As Single) As Single
xPos = (Me.Left + xOffset + Me.ActiveControl.Left + X) * 4 / 3 ' Points -
Pixels
End Function

Private Function yPos(Y As Single) As Single
yPos = (Me.Top + yOffset + Me.ActiveControl.Top + Y) * 4 / 3 ' Points -
Pixels
End Function

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Call PopUpMenuDelete("PopUpCb")
ThisWorkbook.Sheets(1).Buttons(1).Visible = True
End Sub

Private Sub PopUpMenuConfig(ByVal X As Single, ByVal Y As Single)
' The MouseDown event is carried out 2 times on right click ???
Static Click As Integer: Click = Click + 1
If Not Click Mod 2 = 0 Then Exit Sub
Dim cEnable As Boolean: cEnable = Me.ActiveControl.SelLength 0
With Application.CommandBars("PopupCb")
.Controls(1).Enabled = cEnable
.Controls(2).Enabled = cEnable
.Controls(4).Enabled = Len(Me.ActiveControl.Text) 0 And Not cEnable
.Controls(5).Enabled = cEnable
End With
Dim objData As DataObject, DataText As String
Set objData = New DataObject
objData.GetFromClipboard
' Error if the clipboard contents are not text !
On Error Resume Next
DataText = objData.GetText
Application.CommandBars("PopUpCb").Controls(3).Ena bled = (Err.Number = 0)
Err.Clear: Set objData = Nothing
Application.CommandBars("PopUpCb").ShowPopup xPos(X), yPos(Y)
End Sub

In a standard module:
Option Explicit

Sub CutAndPaste()
Load UserForm1
#If VBA6 Then
UserForm1.Show False
#Else
UserForm1.Show
#End If
End Sub

Sub PopUpMenuItem(Clicked As String)
With UserForm1.ActiveControl
Select Case Clicked
Case "1": .Cut
Case "2": .Copy
Case "3": .Paste
Case "4": .SelStart = 0: .SelLength = Len(.Text)
Case "5": .SelText = ""
End Select
End With
End Sub

MP

"don bowyer" a écrit dans le message de
...
I want to raise a custom pop up menu when I right click in
a user form text box . I have the code that tells me which
mouse button was pressed when in the TB so all I need is
the code for the pop up.
I have tried the following from the VBA help files......

Set copyAndPasteMenu = CommandBars.Add( _
Name:="Custom", Position:=msoBarPopup, _
Temporary:=True)
Set copy = copyAndPasteMenu.Controls.Add
With copy
.FaceId = CommandBars("Standard").Controls("Copy").Id
.Caption = "Copy the selection"
End With
Set paste = copyAndPasteMenu.Controls.Add
With paste
.FaceId = CommandBars("Standard").Controls("Paste").Id
.Caption = "Paste from the Clipboard"
End With
copyAndPasteMenu.ShowPopup 200, 200

......which works fine and would do what I want, but it
only ever runs once. If I try running it a second time I
get an error associated with first line of code. If I
close the application and Excel then restart all, it works
again, but just the once.
I notice it has no provision to delete the named
command bars it might have previously created . Could this
be the problem??
Any help from those wiser than I would be greatly
appreciated.
Don Bowyer

pop up menu
 

Hi Michel
Just tried it and it works perfectly.
Merci et au revoir
Don Bowyer

-----Original Message-----
Hi don bowyer;
Try this (The copy is possible between controls and the
active sheet and
controls).
In the UserForm module:
Option Explicit
Private Declare Function FindWindow Lib "user32"
Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As
String) As Long
Private Declare Function EnableWindow Lib "user32" (ByVal
hWnd As Long _
, ByVal fEnable As Long) As Long
Private xOffset As Single, yOffset As Single

Private Sub TextBox1_MouseDown(ByVal Button As Integer _
, ByVal Shift As Integer, ByVal X As Single, ByVal Y As
Single)
If Button = 2 Then Call PopUpMenuConfig(X, Y)
End Sub

Private Sub TextBox2_MouseDown(ByVal Button As Integer _
, ByVal Shift As Integer, ByVal X As Single, ByVal Y As
Single)
If Button = 2 Then Call PopUpMenuConfig(X, Y)
End Sub

Private Sub UserForm_Initialize()
EnableWindow FindWindow(vbNullString,
Application.Caption), 1
xOffset = (Me.Width - Me.InsideWidth) / 2
yOffset = Me.Height - Me.InsideHeight - xOffset
Call PopUpMenuCreate
End Sub

Private Sub PopUpMenuDelete(ByVal PopUpMenuName As String)
On Error Resume Next
CommandBars(PopUpMenuName).Delete
End Sub

Private Sub PopUpMenuCreate()
Call PopUpMenuDelete("PopUpCb")
Dim cb As CommandBar
Set cb = CommandBars.Add("PopUpCb", msoBarPopup, False,
True)
Call AddItemInMenu(cb, "&Cut", 21, "'PopUpMenuItem"""
& "1""'")
Call AddItemInMenu(cb, "Co&py", 110, "'PopUpMenuItem"""
& "2""'")
Call AddItemInMenu(cb, "P&aste",
111, "'PopUpMenuItem""" & "3""'")
Call AddItemInMenu(cb, "&Select",
223, "'PopUpMenuItem""" & "4""'", True)
Call AddItemInMenu(cb, "&Delete",
47, "'PopUpMenuItem""" & "5""'")
Set cb = Nothing
End Sub

Private Sub AddItemInMenu(cbControl As Object, cbCaption
As String _
, cbFaceId As Integer, cbOnAction As String, Optional
NewGroup As Boolean = False)
With cbControl.Controls.Add(msoControlButton, 1, , ,
True)
.BeginGroup = NewGroup
.Caption = cbCaption
.Style = msoButtonIconAndCaption
.FaceId = cbFaceId
.OnAction = ThisWorkbook.Name & "!" & cbOnAction & ""
End With
End Sub

Private Function xPos(X As Single) As Single
xPos = (Me.Left + xOffset + Me.ActiveControl.Left + X)
* 4 / 3 ' Points -
Pixels
End Function

Private Function yPos(Y As Single) As Single
yPos = (Me.Top + yOffset + Me.ActiveControl.Top + Y) *
4 / 3 ' Points -
Pixels
End Function

Private Sub UserForm_QueryClose(Cancel As Integer,
CloseMode As Integer)
Call PopUpMenuDelete("PopUpCb")
ThisWorkbook.Sheets(1).Buttons(1).Visible = True
End Sub

Private Sub PopUpMenuConfig(ByVal X As Single, ByVal Y As
Single)
' The MouseDown event is carried out 2 times on right
click ???
Static Click As Integer: Click = Click + 1
If Not Click Mod 2 = 0 Then Exit Sub
Dim cEnable As Boolean: cEnable =
Me.ActiveControl.SelLength 0
With Application.CommandBars("PopupCb")
.Controls(1).Enabled = cEnable
.Controls(2).Enabled = cEnable
.Controls(4).Enabled = Len(Me.ActiveControl.Text) 0
And Not cEnable
.Controls(5).Enabled = cEnable
End With
Dim objData As DataObject, DataText As String
Set objData = New DataObject
objData.GetFromClipboard
' Error if the clipboard contents are not text !
On Error Resume Next
DataText = objData.GetText
Application.CommandBars("PopUpCb").Controls(3).Ena bled
= (Err.Number = 0)
Err.Clear: Set objData = Nothing
Application.CommandBars("PopUpCb").ShowPopup xPos(X),
yPos(Y)
End Sub

In a standard module:
Option Explicit

Sub CutAndPaste()
Load UserForm1
#If VBA6 Then
UserForm1.Show False
#Else
UserForm1.Show
#End If
End Sub

Sub PopUpMenuItem(Clicked As String)
With UserForm1.ActiveControl
Select Case Clicked
Case "1": .Cut
Case "2": .Copy
Case "3": .Paste
Case "4": .SelStart = 0: .SelLength = Len(.Text)
Case "5": .SelText = ""
End Select
End With
End Sub

MP

"don bowyer" a écrit dans le
message de
...
I want to raise a custom pop up menu when I right click
in
a user form text box . I have the code that tells me
which
mouse button was pressed when in the TB so all I need is
the code for the pop up.
I have tried the following from the VBA help files......

Set copyAndPasteMenu = CommandBars.Add( _
Name:="Custom", Position:=msoBarPopup, _
Temporary:=True)
Set copy = copyAndPasteMenu.Controls.Add
With copy
.FaceId = CommandBars("Standard").Controls
("Copy").Id
.Caption = "Copy the selection"
End With
Set paste = copyAndPasteMenu.Controls.Add
With paste
.FaceId = CommandBars("Standard").Controls
("Paste").Id
.Caption = "Paste from the Clipboard"
End With
copyAndPasteMenu.ShowPopup 200, 200

......which works fine and would do what I want, but it
only ever runs once. If I try running it a second time I
get an error associated with first line of code. If I
close the application and Excel then restart all, it
works
again, but just the once.
I notice it has no provision to delete the named
command bars it might have previously created . Could
this
be the problem??
Any help from those wiser than I would be greatly
appreciated.
Don Bowyer


.