I've been building my shortcut menus via code for a number of years. I find
this to be more flexible and portable than the old menu customization, and
have not tried the new macros in 2007.
All I do is call TextMenu when my application loads, then set the
shortcutmenubar to "MyTextMenu" for the form or control of interest.
Here is a sample of my code:
Public Sub TextMenu(Optional Reset As Boolean = False)
Dim cbr As Object
Dim cbrButton As Object
'If the commandbar exists, and Reset is false, then exit
If CmdBarExists("MyTextMenu") Then
If Reset = False Then
Exit Sub
Else
DeleteCmdBar "MyTextMenu"
End If
End If
On Error GoTo TextMenuError
DoCmd.Hourglass True
Set cbr = CommandBars.Add("MyTextMenu", BarPopup, , True)
With cbr
Set cbrButton = cbr.Controls.Add(ControlButton, , , , True)
With cbrButton
.Caption = "&Copy"
.Tag = "Copy"
.OnAction = "=fnTextCopy()"
End With
Set cbrButton = cbr.Controls.Add(ControlButton, , , , True)
With cbrButton
.Caption = "&Paste"
.Tag = "Paste"
.OnAction = "=fnTextPaste()"
End With
Set cbrButton = cbr.Controls.Add(ControlButton, , , , True)
With cbrButton
.begingroup = True
.Caption = "&Spell check"
.Tag = "Spell check"
.OnAction = "=fnTextSpell()"
End With
Set cbrButton = cbr.Controls.Add(ControlButton, , , , True)
With cbrButton
.begingroup = True
.Caption = "&Find"
.Tag = "Find"
.OnAction = "=fnTextFind()"
End With
End With
DoCmd.Hourglass False
Exit Sub
TextMenuError:
MsgBox Err.Number & vbCrLf & Err.Description, vbInformation + vbOKOnly,
"TextMenu error:"
End Sub
Public Function fnTextCopy()
Dim frm As Form
Dim ctrl As Control
Set frm = Screen.ActiveForm
Do While frm.ActiveControl.ControlType = acSubform
Set frm = frm.ActiveControl.Form
Loop
Set ctrl = frm.ActiveControl
If ctrl.SelLength = 0 Then
ctrl.SelStart = 0
ctrl.SelLength = Len(ctrl.Text)
End If
DoCmd.RunCommand acCmdCopy
End Function
Public Function fnTextPaste()
Dim frm As Form
Dim ctrl As Control
On Error GoTo TextPasteError
Set frm = Screen.ActiveForm
Do While frm.ActiveControl.ControlType = acSubform
Set frm = frm.ActiveControl.Form
Loop
Set ctrl = frm.ActiveControl
DoCmd.RunCommand acCmdPaste
Exit Function
TextPasteError:
If Err.Number = 2046 Then
Resume Next
Else
DisplayError ("Error encountered while attempting to paste text!")
End If
End Function
Public Function fnTextSpell()
Dim frm As Form
Dim ctrl As TextBox
On Error GoTo SpellError
Set frm = Screen.ActiveForm
Do While frm.ActiveControl.ControlType = acSubform
If Application.Version > 11 And Application.Build < 6322 Then
MsgBox "Unable to spell check this item!"
Exit Function
Else
Set frm = frm.ActiveControl.Form
End If
Loop
Set ctrl = frm.ActiveControl
With ctrl
If ctrl.SelLength = 0 Then
ctrl.SelStart = 0
ctrl.SelLength = Len(ctrl.Text)
End If
End With
If ctrl.SelLength > 0 Then DoCmd.RunCommand acCmdSpelling
Exit Function
SpellError:
DisplayError ("Error encountered by spell checker")
End Function
Public Function CmdBarExists(BarName As String) As Boolean
Dim intControls
On Error Resume Next
intControls = CommandBars(BarName).Controls.Count
If Err.Number = 0 Then
CmdBarExists = True
Else
CmdBarExists = False
End If
End Function
Public Sub DeleteCmdBar(BarName As String)
Dim intLoop As Integer
'If an error is generated, it is because the command bar doesn't exist,
ignore it
On Error GoTo DeleteCmdBar_Error
CommandBars(BarName).Delete
Exit Sub
DeleteCmdBar_Error:
Err.Clear
End Sub
--
HTH
Dale
email address is invalid
Please reply to newsgroup only.
