Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 . |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Drop dwn menu. Formula to count selection frm menu in anoth cell? | Excel Worksheet Functions | |||
Excel -My paste menu is not the norm. The menu is different. | Setting up and Configuration of Excel | |||
filter dropdown menu so 2nd drop menu is customized | Excel Worksheet Functions | |||
Create Dropdown menu without using the Validation on the Data Menu | Excel Worksheet Functions | |||
Menu items added with menu item editor in older versions | Excel Discussion (Misc queries) |