'### Mot de passe à adapter ###
Const PASSWORD As String = "TOTO"
'##############################
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, _
ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Const VK_RETURN = &HD
Const KEYEVENTF_KEYUP = &H2
Sub MiseAjour()
Dim Classeur As Variant
Dim WB As Workbook
Dim VBProj As Object
Dim OL As OLEObject
Dim CB As Object 'MSForms.CommandButton
Dim A$
'--- Ouverture du classeur cible ---
Classeur = Application.GetOpenFilename("Classeurs Excel,*.xls")
If Classeur = False Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
Set WB = Workbooks.Open(Filename:=Classeur)
Set VBProj = WB.VBProject
'--- Déprotège momentanément le VBE du classeur cible ---
If VBProj.Protection = 1 Then
Set Application.VBE.ActiveVBProject = VBProj
SendKeys PASSWORD & "~~"
Application.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute
End If
'--- (pseudo message) lignes de code nécessaires pour ne pas être bloqué ---
keybd_event VK_RETURN, 0, 0, 0
keybd_event VK_RETURN, 0, KEYEVENTF_KEYUP, 0
MsgBox "La mise à jour s'est correctement effectuée"
' ######## TRAITEMENT ########
'--- Construction d'un commandbutton ---
Set OL = WB.Sheets(1).OLEObjects.Add(ClassType:="Forms.CommandButton.1", Link:=False _
, DisplayAsIcon:=False, Left:=60, Top:=100, Width:=100, Height:=40)
Set CB = OL.Object
OL.Name = "MonCommandButton"
CB.BackColor = vbBlue
CB.Caption = "TEST"
With CB.Font
.Size = 20
.Bold = True
.Italic = True
End With
'--- Code du commandbutton ---
A$ = vbCrLf & "Private Sub MonCommandButton_Click()"
A$ = A$ & vbCrLf & "MsgBox " & Chr(34) & "TEST OK" & Chr(34) & ", , " & Chr(34) & "Pour INFO" & Chr(34)
A$ = A$ & vbCrLf & "End Sub" & vbCrLf
With WB.VBProject.VBComponents("Feuil1").CodeModule
.InsertLines .CountOfLines + 2, A$
End With
' ######## SAUVEGARDE ET FERMETURE ########
Application.DisplayAlerts = False
WB.SaveAs (WB.Path & "/" & "SAUV" & WB.Name)
WB.Close SaveChanges:=False
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
ThisWorkbook.Close SaveChanges:=False
End Sub