Bonjour Avatar, le Forum
Tiens j'ai ceci en stock de la part du Grand Chef à Trois Plumes, je ne sais pas si on pourrait pas faire plus simple si Ti passe par là, moi je dois filer...
ICI POUR UN CLASSEUR SUR LUI MEME
Option Explicit
Option Private Module
Const MdP = "Zaza"
Declare Function FindWindowA Lib "User32" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function GetForegroundWindow Lib "User32" () As Long
Declare Function SetForegroundWindow Lib "User32" _
(ByVal hWnd As Long) As Long
Sub Deprotege()
Dim XLhWnd As Long, VBEhWnd As Long, CurhWnd As Long
Dim ActWbk As Workbook, Wbk As Workbook
On Error Resume Next
If ThisWorkbook.VBProject.Protection = vbext_pp_none Then Exit Sub
Set ActWbk = ActiveWorkbook
CurhWnd = GetForegroundWindow
XLhWnd = FindWindowA(vbNullString, Application.Caption)
Application.ScreenUpdating = False
With Application.VBE
VBEhWnd = FindWindowA(vbNullString, .MainWindow.Caption)
If CurhWnd = XLhWnd Then SetForegroundWindow VBEhWnd
.CommandBars.FindControl(ID:=2557).Execute
ThisWorkbook.Activate
ThisWorkbook.VBProject.VBComponents(1).Activate
SendKeys "~" & MdP & "~", True
With .ActiveCodePane
If .CodeModule.CountOfLines = 0 Then .Window.Close
End With
End With
SetForegroundWindow CurhWnd
If Not ActWbk Is ThisWorkbook Then ActWbk.Activate
End Sub
Sub Reprotege()
ThisWorkbook.Save
Workbooks.Open ThisWorkbook.FullName
End Sub
'=================================================
[Testé uniquement sous Excel 2000 !!!]
La constante MdP contient le mot de passe du projet.
Attention, la macro "Reprotege" enregistre toutes les modifications
apportées au classeur.
A manipuler avec prudence et en testant bien, c'est toujours presque
aussi cochon et je n'ai peut-être pas pensé à gérer tous les cas de
figure.
Laurent Longre
ET ICI POUR ALLER VERS UN AUTRE CLASSEUR
Bon, eh bien voilà. Comme tu peux le constater, c'est excessivement
cochon.
'=================================================
Private Declare Function FindWindowA Lib "User32" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetForegroundWindow Lib "User32" () As Long
Private Declare Function SetForegroundWindow Lib "User32" _
(ByVal hWnd As Long) As Long
Function Déprotège(Classeur As String, MdP As String) As Boolean
Dim XLhWnd As Long, VBEhWnd As Long, CurhWnd As Long
Dim Wbk As Workbook
On Error Resume Next
Set Wbk = Workbooks(Dir$(Classeur))
On Error GoTo Fin
If Not Wbk Is Nothing Then
If Wbk.FullName <> Classeur Then Exit Function
If Not Wbk.Saved Then Wbk.Save
Else: Application.ScreenUpdating = False
End If
CurhWnd = GetForegroundWindow
XLhWnd = FindWindowA(vbNullString, Application.Caption)
With Application.VBE
VBEhWnd = FindWindowA(vbNullString, .MainWindow.Caption)
If CurhWnd = XLhWnd Then SetForegroundWindow VBEhWnd
.CommandBars.FindControl(ID:=2557).Execute
' NE PAS EFFACER, même si le classeur est déjà ouvert !!!!!!
Workbooks.Open Classeur
If ActiveWorkbook.VBProject.Protection = vbext_pp_locked Then
SendKeys "~" & MdP & "~", True
.ActiveCodePane.Window.Close
End If
End With
SetForegroundWindow CurhWnd
Déprotège = True
Exit Function
Fin:
End Function
Sub Test()
' Déprotection du projet VBA C:\Temp\Test.xls (mot de passe "Zaza"),
' Ajout d'un module standard dans ce projet, puis rétablissement
' de la protection
Const Classeur = "C:\Temp\Test.xls"
If Not Déprotège(Classeur, "Zaza") Then
MsgBox "Erreur"
Else
MsgBox "Projet VBA déprotégé."
With Workbooks(Dir$(Classeur))
.VBProject.VBComponents.Add vbext_ct_StdModule
.Close True
End With
Workbooks.Open Classeur
MsgBox "Projet reprotégé, ajout d'un module standard."
End If
End Sub
'=================================================
Testé sous Excel 2000 SR-2.
Petit inconvénient : si le classeur à "déprotéger" (cad à ouvrir en
entrant le mot de passe) est déjà ouvert au moment ou la procédure
"Déprotège" s'exécute, il sera ré-enregistré si des modifications y ont
été faites par l'utilisateur, avant la déprotection.
Laurent Longre
Ouf !
Voilà des choses excessivement cochonnes (dixit) du Grand Laurent Longre http://longre.free.fr
Bon Appétit
@+Thierry
