XL 2010 Supprimer les modules d'un projet VBA protegé par mdp

[fattah_5791]

Salut tt le monde,
J'ai realisé un petit applicatif me permettant d'effectuer des taches bien precises, mias je voulais que les modules de CODE VBA s'effacent automatiquement apres une date precise que je dois declarer dans le module ThisWorkbook.

ci joint le code trouvé qlq part sur le net, il marche mais sans protection par mdp du ProjetVBA.
je voulais inserer un mot de passe (exemple: 0000) dans le code ci joint.

le mdp (0000) est celui utilisé pour protege le projet VBA

merci infiniment.

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim Wkb As Workbook, EndJob As Date, VBC As Object

   Set Wkb = ThisWorkbook
   EndJob = DateSerial(2017, 9, 1)  'Choisir la date de fin applicatif
   
If Date >= EndJob Then
          With ActiveWorkbook.VBProject
                       For Each VBC In .VBComponents
                          If VBC.Type = 100 Then
                             With VBC.CodeModule
                                .DeleteLines 1, .CountOfLines
                                   .CodePane.Window.Close
                             End With
                       Else: .VBComponents.Remove VBC
                        End If
                       Next VBC
            End With
                  Application.Quit 'penser à fermer tous les fichiers ouverts avant
                  SendKeys "%O"
Else
Exit Sub
  End If
  Application.DisplayAlerts = False
Wkb.Save
End Sub

 

[eriiic]

Bonjour,

plus simplement tu ne peux pas tester la date pour exécuter ou non le code ?
Si c'est pour protéger ton code tu ne surprendras que ceux qui n'ont pas gardé une copie.
eric

 

[fattah_5791]

Bonjour eriiiic,
l'applicatif est un produit "jetable", une fois une date bien definie dans le code est atteinte les modules doivent cesser de fonctionner (mieux les supprimer). Pareil pour ceux qui ont des copies de l'applicatif.
merci

 

[ChTi160]

Bonjour fattah_5791
Bonjour Le Fil ,Le Forum

sans fichier pas évident voir si tu peux tester et adapter ce qui suit (pas sur d'avoir compris)

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim Wkb As Workbook, EndJob As Date, VBC As Object
  Set Wkb = ThisWorkbook
   EndJob = DateSerial(2017, 9, 1)  'Choisir la date de fin applicatif   
If Date >= EndJob Then
'******************   
  UnprotectVBProject Wkb, "0000" 'Ici
'******************
  With ActiveWorkbook.VBProject   
  For Each VBC In .VBComponents
  If VBC.Type = 100 Then
  With VBC.CodeModule
  .DeleteLines 1, .CountOfLines
  .CodePane.Window.Close
  End With
  Else: .VBComponents.Remove VBC
  End If
  Next VBC
  End With
  Application.Quit 'penser à fermer tous les fichiers ouverts avant
  SendKeys "%O"
Else
Exit Sub
  End If
  Application.DisplayAlerts = False
Wkb.Save
End Sub
Sub UnprotectVBProject(WB As Workbook, ByVal Password As String)
  Dim vbProj As Object
Application.ScreenUpdating = False
  Set vbProj = WB.VBProject
  If vbProj.Protection <> 1 Then Exit Sub 'Voir si utile
  Set Application.VBE.ActiveVBProject = vbProj
  SendKeys Password & "~~"
  Application.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute
Application.ScreenUpdating = True
End Sub

Bonne fin de journée
Amicalement
Jean marie

 

[fattah_5791]

bonjour CHTi160,

Le code genere un msg d'erreur!!!

merci

 

[fattah_5791]

bonjour,
ci joint mon fichier/

 

[Yurperqod]

Bonjour à tous

fattah_5791
Est qu'une macro qui enregistrerait une copie de ton classeur au format xlsx (donc sans macros) serait une solution ?

 

[fattah_5791]

bonjour,

pour Yurperqod, votre proposition serait une solution à condition de raser l'ancien fichier (*.xlsm).

 

[Yurperqod]

L'ancien fichier a pu être sauvegardé avant sur une clé USB.
On sera jamais sur à 100% qu'il existe pas d'ancienne version du fichier à raser.
Et rien n’empêche celui qui a le fichier de l'ouvrir sans activation des macros.

 

[fattah_5791]

bonjour Yurperqod,

mon idée est d'avoir un CODE vba sur l'ancien fichier (.xlsm), une fois une date arrivée et en manipulant l'ancien fichier le code VBA doit faire ceci:
- copier l"ancien fichier (xlsm) sous format (xlsx);
- en mm temps raser l'ancien fichier (xlsm)
et donc qlq soit l'endroit (cle usb, partition, carte memoire,...) l'ancien fichier est supprimé!!!

le Code vba sera inserer soit dans ThisWorkbook, ou proprietes d'une feuille du classeur ou tt simplement à la fin de l'une des macros du fichier xlsm.

(cordialement, je suis un peu gourmand et debutant en vba)

 

[eriiic]

Bonjour,

et donc qlq soit l'endroit (cle usb, partition, carte memoire,...) l'ancien fichier est supprimé!!!

tu vis dans quel univers toi ?

 

[job75]

Bonjour à tous,

Compléter la macro Workbook_Open comme suit :

Private Sub Workbook_Open()
If Date >= DateSerial(2017, 9, 1) Then  'Choisir la date de fin applicatif
  Dim fn$
  Application.DisplayAlerts = False
  fn = Me.FullName
  Me.SaveAs Left(fn, InStrRev(fn, ".") - 1), 51
  Kill fn
  Workbooks.Open Me.FullName
End If
'suite du code
End Sub

A+

 

[fattah_5791]

Bonjour tt le monde,
Merci job75 de ta proposition, encore un msg d'errur s"affiche:

Rqs:
Systeme: Windows 7
Ms Office: office 10

 

[job75]

Bonjour fattah_5791,

Vous n'avez pas dû copier le code correctement.

Téléchargez le fichier joint et ouvrez-le d'abord sans activer les macros pour voir mon code dans ThisWorkbook.

A+

 

[Yurperqod]

Bonjour à tous

Avec Excel 2010, je n'ai pas de message d'erreur.
Si je double-clique dans l'explorateur Windows pour ouvrir le classeur, la transformation en *.xlsx se fait bien.

Si j'ai d'autres classeurs ouverts et que j'ouvre le classeur par Fichier/Ouvrir, le fichier reste en *.xlsm

J'ai bien activé les macros.

Ajout EDITION
En fait, ca fait pareil sur un classeur quand on l'ouvre par Fichier/Ouvrir
la macro WorkBook_Open se lance pas

j'ai testé sur un classeur vierge avec cette macro
Private Sub Workbook_Open()
MsgBox Me.FullName
End Sub

Quand on ouvre par un double-clic la macro se lance sinon non.