'adapté de http://www.rondebruin.nl/win/s6/win001.htmOption Explicit
#If Win64 Then 'windows 64 bits
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Any) As Long
#Else 'windows 32 bits
Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Any) As Long
#End If
Const WM_CLOSE As Long = &H10
Const SW_NORMAL As Long = 1
Sub AddToCellMenu()
Dim ContextMenu As CommandBar
Dim MySubMenu As CommandBarControl
'Delete the controls first to avoid duplicates
Call DeleteFromCellMenu
'Set ContextMenu to the Cell menu
Set ContextMenu = Application.CommandBars("Cell")
'Add one built-in button(Save = 3)to the cell menu
ContextMenu.Controls.Add Type:=msoControlButton, ID:=3, before:=1
'Add one custom button to the Cell menu
With ContextMenu.Controls.Add(Type:=msoControlButton, before:=2)
.OnAction = "'" & ThisWorkbook.Name & "'!" & "Calculatrice"
.FaceId = 50
.Caption = "Calculatrice"
.Tag = "Lancer_calculatrice"
End With
End Sub
Sub DeleteFromCellMenu()
Dim ContextMenu As CommandBar
Dim ctrl As CommandBarControl
'Set ContextMenu to the Cell menu
Set ContextMenu = Application.CommandBars("Cell")
For Each ctrl In ContextMenu.Controls
If ctrl.Tag = "Lancer_calculatrice" Then
ctrl.Delete
End If
Next ctrl
'Delete built-in Save button
On Error Resume Next
ContextMenu.FindControl(ID:=3).Delete
On Error GoTo 0
End Sub
Sub Calculatrice()
Dim wCalc As Long
wCalc = FindWindow("CalcFrame", vbNullString)
If wCalc = 0 Then
Shell "Calc.exe", SW_NORMAL
Else
SetForegroundWindow wCalc
End If
End Sub
Sub Fermer_Calculatrice()
Dim wCalc As Long
wCalc = FindWindow("CalcFrame", vbNullString)
If wCalc <> 0 Then SendMessage wCalc, WM_CLOSE, 0, ByVal 0&
End Sub
