|
|
Anyone can tell me how I can append the right click menu in excel sheets through VBA? Thanks!
|
|
|
|
Option Explicit
Sub auto_open()
'-- MsgBox "Version" & Application.Version & _
' " <-- should be for version 9 h:\...\personal.xls"
'Workbooks.Open Filename:="H:\Excel2K\menumakr.xls"
'ActiveWindow.Visible = False
If Application.TransitionNavigKeys Then
MsgBox "Found Transition navigation keys, please turn off"
'Application.TransitionNavigKeys = False
End If
' Double click on Clippy or his one of his friends. (Excel 2000)
' Unselect everything in sight, and especially "Use the Office Assistant"
'
'It has been removed from Office 2002
' http://www.officeclippy.com
Assistant.On = False 'Turn off the bloody Office Assistant doesn't work in Win98SE
'Application.Calculation = xlManual
'---- do not include following code in your personal.xls Auto_Open
'-- Run-time error '1004'.
'-- Method 'Calculation' of object '_Application' failed
'If Application.Calculation <> -4105 Then
' '-4105 automatic, -4135 manual, 2 semi-automatic
' MsgBox Application.Calculation & " " & _
' ActiveWorkbook.FullName
' Application.Calculation = xlAutomatic
' MsgBox Application.Calculation
'End If
'The following line is used to turn off prompting in AutoSave Addin in XL2000
'Result if addin is turned off: Run-time error '9'; subscript out of range
' Workbooks("autosave.xla").Excel4IntlMacroSheets("Loc Table").Range("ud01b.Prompt").Value = False
'Jim Rech 1999-09-16, MS has an XL2000 fix for not saving AutoSave settings
' http://support.microsoft.com/support/kb/articles/Q231/1/17.ASP
'download: http://support.microsoft.com/download/support/mslfiles/ASUpdate.exe
'Chip Pearson via Drew Paterson -- 2001-04-13 misc
'--http://groups.google.com/groups?threadm=uiqh89AxAHA.1620%40tkmsftngp05
Application.CommandBars("Cell").Reset 'was not in 2001-04-13 posting
With Application.CommandBars("Cell").Controls
With .Add
.Caption = "C&opy Formula" 'Copy Formula / Paste Formula
.OnAction = ThisWorkbook.Name & "!CopyFormula" 'in ChipPearson_RClick
.Tag = "Formulas" 'cControlTag
.BeginGroup = True
End With
With .Add
.Caption = "P&aste Formula"
.OnAction = ThisWorkbook.Name & "!PasteFormula" 'in ChipPearson_RClick
.Tag = "Formulas2" 'cControlTag
End With
With .Add 'adding AutoSum for David Loh 2004-03-20 worksheet.functions
.Caption = "A&utoSum"
.OnAction = ThisWorkbook.Name & "!Simulate_autosum" 'see macro below
.Tag = "Auto Sum via RtClick"
'--need to include the button icon
End With
With .Add 'Adding Clear_Constants
.Caption = "Clear Constants (leave formulas)"
.OnAction = ThisWorkbook.Name & "!Clear_Constants" 'DMcRitchie_RClick
.Tag = "Clear_Constants"
End With
With .Add 'Adding EndTotal
.Caption = "Create SUB&TOTAL at end of column"
.OnAction = ThisWorkbook.Name & "!endtotal_sub" 'DMcRitchie_RClick
.Tag = "EndGetFormula"
End With
With .Add 'Adding GetFormula David McRitchie
.Caption = "GetFormula"
.OnAction = ThisWorkbook.Name & "!GetFormula_sub" 'DMcRitchie_RClick
.Tag = "GetFormula"
End With
End With
'-- there are separate commandbar controls for Row and Column
Application.CommandBars("Row").Reset
With Application.CommandBars("Row").Controls
With .Add 'Adding Clear_Constants
.Caption = "Clear Constants in Selected Rows (leave formulas)"
.OnAction = ThisWorkbook.Name & "!Clear_Constants" 'DMcRitchie_RClick
.Tag = "Clear_Constants in Rows"
End With
End With
Application.CommandBars("Column").Reset
With Application.CommandBars("Column").Controls
With .Add 'Adding Clear_Constants
.Caption = "Clear Constants in Selected Columns(leave formulas)"
.OnAction = ThisWorkbook.Name & "!Clear_Constants" 'DMcRitchie_RClick
.Tag = "Clear_Constants in Columns"
End With
End With
'instead of Auto_Open use Workbook_Open in the ThisWorkbook
' when you need to fire off a macro when opening with code.
End Sub
Sub Simulate_AutoSum() 'David Loh 2004-03-20
CommandBars.FindControl(, 226).Execute
End Sub
In a separate module which have named "DMcRitchie_RClick" I have the following code:
Option Explicit
'see comments below
Sub GetFormula_sub()
If ActiveCell.Column = 1 Then
ActiveCell.Formula = "=personal.xls!GetFormula(" & _
ActiveCell.Offset(-1, 0).Address(0, 0) & ")"
MsgBox "couldn't use cell to left so setting to use from cell above"
Else
ActiveCell.Formula = "=personal.xls!GetFormula(" & _
ActiveCell.Offset(0, -1).Address(0, 0) & ")"
End If
End Sub
Sub EndTotal_sub()
Dim end_data As Long 'dmcritchie RClick 2005-05-28
Range(ActiveCell.Address, _
Cells(Rows.Count, ActiveCell.Column).End(xlUp).Address).Select
end_data = ActiveSheet.Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row
ActiveSheet.Cells(end_data + 1, ActiveCell.Column).Formula = _
"=SUBTOTAL(9," & ActiveSheet.Cells(2, ActiveCell.Column).Address(1, 0) _
& ":OFFSET(" & ActiveSheet.Cells(end_data + 1, _
ActiveCell.Column).Address(0, 0) & ",-1,0))"
End Sub
Sub Clear_Constants() 'D.McRitchie RClick 2005-11-19 (also see insrtrow.htm)
'-- provide for in rightclick cell, row, and column commandbars
Dim rng As Range 'prevent expansion of a single cell selection
Set rng = Intersect(Selection, Selection.SpecialCells(xlConstants))
If rng Is Nothing Then
MsgBox "No constants in selection area(s) -- no removal"
Else
rng.ClearContents
End If
End Sub
'change to personal.xls if that is what you use
'see also ChipPearson_Module for Chip Pearson's RClick menus
'these are setup in module1 in an Auto_Open
'Documentation in: http://www.mvps.org/dmcritchie/excel/rightclick.htm
In a separate module which have named "ChipPearson_RClick" I have the following code:
Option Explicit
Sub CopyFormula()
'Chip Pearson, microsoft.public.excel.worksheet.functions, 2000/05/02
'http://groups.google.com/groups?hl=en&newwindow=1&th=4831aec5cbe19367&rnum=1
'http://groups.google.com/groups?as_umsgid=OWeRetUjBHA.2212@tkmsftngp05
Dim x As New DataObject
x.SetText ActiveCell.Formula
x.PutInClipboard
End Sub
Sub PasteFormula()
On Error Resume Next
Dim x As New DataObject
x.GetFromClipboard
ActiveCell.Formula = x.GetText
End Sub
also see MS KB 159619 - XL97: Sample Macros for Customizing Menus and Submenus
also see Bob Phillips, programming, 2004-05-09
also see Gord Dibben 2002-03-26 to copy a range of formulas without change. (actual author unknown)
__________________
flash banner|flash menu
|
|
|
|
|
|
|
|
Archive Import (Keith) 
Elain
