Appliquer une macro à plusieurs classeurs d'un dossier

[dj dim]

Bonjour le Forum,

Je souhaite appliquer une macro interdisant l'impression et le copier/coller à tous les classeurs d'un même dossier.

Je sui parti d'une macro proposée par Roland_M

La macro interdire copier/coller fonctionne correctement mais je bloque sur l'interdiction de l'impression du fait de la nécessité d'ecrire la macro dans 'this Workbook'.

Merci par avance pour votre aide

Voici le code :

Public Chemin, Fich As String, ReponseMsgBox As Variant

'                                           .
'routine d'appel depuis le bouton sur feuille
'                                           .
Public Sub SelectionnerRepertoire()
Chemin = FLoadNomDuREP: Chemin = Trim(Chemin): If Chemin = "" Then Exit Sub
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
DoEvents
'demande de confirmation
M$ = "Traiter tous les Fichiers xls du répertoire suivant :" & vbLf & Chemin & vbLf & vbLf & "Veuillez confirmer ?"
ReponseMsgBox = MsgBox(M$, vbQuestion + vbYesNo, "Traitement des fichiers")
If ReponseMsgBox = vbYes Then
   BoucleDeTraitement ' appel la routine de traitement des fichiers
   MsgBox "Traitement terminé !", vbInformation
Else
   MsgBox "Traitement abandonné !", vbExclamation
End If
End Sub

' , &H1&)=avec bouton "créer un nouveau dossier" ... , $H201&)=sans le bouton
'objShell.BrowseForFolder(&H0&, "Sélectionnez un dossier", &H201&, RepDefaut)
Private Function FLoadNomDuREP() As String
Dim objShell As Object, objFolder As Object, REP As String
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Sélectionnez un dossier", &H201&)
If Not objFolder Is Nothing Then
   REP = objFolder.Items.Item.Path
   If Right(REP, 1) <> "\" Then REP = REP & "\"
End If
FLoadNomDuREP = REP
Set objShell = Nothing: Set objFolder = Nothing
End Function

'                                                                               .
'                                                                               .

Private Sub BoucleDeTraitement() ' la boucle de traitement des fichiers
Application.ScreenUpdating = False
ChDir Chemin
Fich = Dir(Chemin & "*.xls")
Do While Fich <> ""
  Workbooks.Open Chemin & Fich
  InterdireCopierCouper
  ActiveWorkbook.Close True
  Fich = Dir
With Workbooks.Open Chemin & Fich.VBProject.VBComponents("This Workbook").CodeModule
.AddFromString VBA
Workbook_BeforePrint
ActiveWorkbook.Close True
End With
Loop
Application.ScreenUpdating = True
End Sub

Sub InterdireCopierCouper()
On Error Resume Next
With Application
'disables shortcut keys
.OnKey "^c", ""
.OnKey "^v", ""
.OnKey "^x", ""
'Disables Copy
.CommandBars("Edit").FindControl(ID:=19).Enabled = False
.CommandBars("Edit").FindControl(ID:=848).Enabled = False
.CommandBars("Cell").FindControl(ID:=19).Enabled = False
.CommandBars("Column").FindControl(ID:=19).Enabled = False
.CommandBars("Row").FindControl(ID:=19).Enabled = False
.CommandBars("Button").FindControl(ID:=19).Enabled = False
.CommandBars("Formula Bar").FindControl(ID:=19).Enabled = False
.CommandBars("Worksheet Menu Bar").FindControl(ID:=19).Enabled = False
.CommandBars("Standard").FindControl(ID:=19).Enabl ed = False
.CommandBars("Button").FindControl(ID:=848).Enable d = False
.CommandBars("Formula Bar").FindControl(ID:=848).Enabled = False
.CommandBars("Worksheet Menu Bar").FindControl(ID:=848).Enabled = False
.CommandBars("Standard").FindControl(ID:=848).Enab led = False
.CommandBars("Ply").FindControl(ID:=848).Enabled = False
'Disables Cut
.CommandBars("Edit").FindControl(ID:=21).Enabled = False
.CommandBars("Cell").FindControl(ID:=21).Enabled = False
.CommandBars("Column").FindControl(ID:=21).Enabled = False
.CommandBars("Row").FindControl(ID:=21).Enabled = False
.CommandBars("Button").FindControl(ID:=21).Enabled = False
.CommandBars("Formula Bar").FindControl(ID:=21).Enabled = False
.CommandBars("Worksheet Menu Bar").FindControl(ID:=21).Enabled = False
.CommandBars("Standard").FindControl(ID:=21).Enabl ed = False
End With
End Sub

Private Sub Workbook_BeforePrint(Cancel As Boolean)
Cancel = True
MsgBox "Vous n'avez pas la possibilité d'imprimer ce document"
End Sub

 

[dj dim]

Re : Appliquer une macro à plusieurs classeurs d'un dossier

Hello,

Personne pour m'aider ???

Quel est le code pour ecrire dans le module 'This Workbook' d'un classeur à partir d'une macro exterieure ???

Je bloque, aidez moi svp !!!

 

[dj dim]

Re : Appliquer une macro à plusieurs classeurs d'un dossier

Up !!

Aidez moi svp!

Est-ce possible de copier une macro inscrite dans "thisworkbook" dans plusieurs classeurs situés dans un même dossier.

Cordialement