Empecher la copie d'un classeur

kyasteph

XLDnaute Occasionnel
Bonjour,

Je viens de créer un programme de gestion sur excel mais je passe des heures sur heures à chercher mais en vain:
Voici ma préoccupation ; c'est que je veux qu'à l'ouverture de mon programme l'utilisateur soit amené à activer les macros sans quoi que seulement la page "Blocage" soit visible et toutes les autres soient invisibles;Et si les macros sont activées ,que mon classeur s'ouvre toujours sur la page "Acceuil".
j'ai essayé les solutions proposées à partir du net et j'ai obtenu ce code mais ça ne fonctionne pas:
1)A la fermerture du classeur,un message d'erreur s'affiche: "Erreur définie par l'application ou par l'objet "
2)A l'ouverture du classeur:
-une autre erreur:"Erreur d'exécution'9' l'indice n'appartient pas à la sélection"
-que les macros soient activées ou pas la page "Blocage" reste invisible
Et toutes les autres feuilles restent toujours visibles.
-En plus une des feuilles ("Plan_comptable_liste") que j'avais masquée devient visible et n'est donc plus masquée.

Voici le code en question:

Code:
'Déclaration à mettre dans un Module
 
Private Declare Function GetVolumeInformation Lib "kernel32.dll" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, ByRef lpVolumeSerialNumber As Long, ByRef lpMaximumComponentLength As Long, ByRef lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
 
 
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Not flag Then Cancel = True
End Sub
 
'Fin des Déclarations
 
Private Sub Workbook_Open()
 
 
Application.Caption = "Nom Produit"
    ActiveWindow.DisplayHorizontalScrollBar = False
    ActiveWindow.DisplayVerticalScrollBar = False
 
 
 
    Dim r&, PathName$, DrvVolumeName$, DrvSerialNo$
 
 
 
'Disque à checker
 
 
 
    PathName$ = "c:\"
 
 
 
    rgbGetVolumeInformationRDI PathName$, DrvVolumeName$, DrvSerialNo$
 
 
 
    'Afficher le résultat dans des msgbox
 
    If DrvSerialNo$ = "N° DD" Then
    MsgBox "                                      Bienvenu(e) dans votre programme de gestion                                                                                                                                                                                                             "
    Dim FeuilleActive As String
    FeuilleActive = ActiveSheet.Name
    Application.ScreenUpdating = False
    Sheets("Accueil").Activate
    ThisWorkbook.Save
    Sheets(FeuilleActive).Activate
    Application.ScreenUpdating = True
 
    ThisWorkbook.Saved = True
    Else
    Application.Run "SupprimeFeuille"
 
End If
End Sub
Private Sub rgbGetVolumeInformationRDI(PathName$, DrvVolumeName$, DrvSerialNo$)
 
    Dim r As Long
 
    Dim pos As Integer
 
    Dim HiWord As Long
 
    Dim HiHexStr As String
 
    Dim LoWord As Long
 
    Dim LoHexStr As String
 
    Dim VolumeSN As Long
 
    Dim MaxFNLen As Long
 
    Dim UnusedStr As String
 
    Dim UnusedVal1 As Long
 
    Dim UnusedVal2 As Long
 
 
 
    DrvVolumeName$ = Space$(14)
 
    UnusedStr$ = Space$(32)
 
 
 
    r& = GetVolumeInformation(PathName$, DrvVolumeName$, Len(DrvVolumeName$), VolumeSN&, UnusedVal1&, UnusedVal2&, UnusedStr$, Len(UnusedStr$))
 
 
 
    If r& = 0 Then Exit Sub
 
 
 
    'determine le label
 
 
 
    pos% = InStr(DrvVolumeName$, Chr$(0))
 
    If pos% Then DrvVolumeName$ = Left$(DrvVolumeName$, pos% - 1)
 
    If Len(Trim$(DrvVolumeName$)) = 0 Then DrvVolumeName$ = "(pas de label)"
 
 
 
    'determine l'id du disque
 
 
 
    HiWord& = GetHiWord(VolumeSN&) And &HFFFF&
 
    LoWord& = GetLoWord(VolumeSN&) And &HFFFF&
 
 
 
    HiHexStr$ = Format$(Hex(HiWord&), "0000")
 
    LoHexStr$ = Format$(Hex(LoWord&), "0000")
 
 
 
    DrvSerialNo$ = HiHexStr$ & "-" & LoHexStr$
 
End Sub
 
Function GetHiWord(dw As Long) As Integer
 
    If dw& And &H80000000 Then
 
        GetHiWord% = (dw& \ 65535) - 1
 
    Else: GetHiWord% = dw& \ 65535
 
    End If
 
End Function
 
Function GetLoWord(dw As Long) As Integer
 
    If dw& And &H8000& Then
 
        GetLoWord% = &H8000 Or (dw& And &H7FFF&)
 
    Else: GetLoWord% = dw& And &HFFFF&
 
    End If
 
End Function
 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  If SaveAsUI = True Then Cancel = True
  Dim FeuilleActive As String, Feuille As Worksheet
 
    FeuilleActive = ActiveSheet.Name
    Application.ScreenUpdating = False
    Sheets("Blocage").Visible = True
    Sheets("Blocage").Activate
    For Each Feuille In ThisWorkbook.Sheets
        If Feuille.Name <> "Blocage" Then Feuille.Visible = False
    Next Feuille
    ThisWorkbook.Save
    For Each Feuille In ThisWorkbook.Sheets
        Feuille.Visible = True
    Next Feuille
    Sheets(FeuilleActive).Activate
    Sheets("Blocage").Visible = False
    Application.ScreenUpdating = True
 
    ThisWorkbook.Saved = True
End Sub
Je précise que j'ai un bouton qui me permet de quitter le classeur et voici la macro qui lui est lié

Code:
'Callback for Quitter onAction
 
 
 
 
' Déclaration à mettre dans un Module
 
Private Declare Function GetVolumeInformation Lib "kernel32.dll" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, ByRef lpVolumeSerialNumber As Long, ByRef lpMaximumComponentLength As Long, ByRef lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
 
 
 
'Fin des Déclarations
 
Sub Exit1(control As IRibbonControl)
 
flag = True
 
    Dim r&, PathName$, DrvVolumeName$, DrvSerialNo$
 
 
 
'Disque à checker
 
 
 
    PathName$ = "c:\"
 
 
 
    rgbGetVolumeInformationRDI PathName$, DrvVolumeName$, DrvSerialNo$
 
 
 
    'Afficher le résultat dans des msgbox
 
    If DrvSerialNo$ = "C6DB-4342" Then
    If MsgBox("Voulez vous vraiment quitter Gescofis?", vbYesNo + vbQuestion, "PCE Devxl & Consulting") = vbNo Then
Exit Sub
End If
 
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.DisplayAlerts = True
 
    Else
 
    MsgBox ("   A défaut de licence acquise , votre programme de gestion ne fonctionnera plus !"), vbYesNo = 1, "Nom Produit"
    Application.Run "SupprimeFeuille"
    Application.DisplayAlerts = False
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
End If
End Sub
Private Sub rgbGetVolumeInformationRDI(PathName$, DrvVolumeName$, DrvSerialNo$)
 
    Dim r As Long
 
    Dim pos As Integer
 
    Dim HiWord As Long
 
    Dim HiHexStr As String
 
    Dim LoWord As Long
 
    Dim LoHexStr As String
 
    Dim VolumeSN As Long
 
    Dim MaxFNLen As Long
 
    Dim UnusedStr As String
 
    Dim UnusedVal1 As Long
 
    Dim UnusedVal2 As Long
 
 
 
    DrvVolumeName$ = Space$(14)
 
    UnusedStr$ = Space$(32)
 
 
 
    r& = GetVolumeInformation(PathName$, DrvVolumeName$, Len(DrvVolumeName$), VolumeSN&, UnusedVal1&, UnusedVal2&, UnusedStr$, Len(UnusedStr$))
 
 
 
    If r& = 0 Then Exit Sub
 
 
 
    'determine le label
 
 
 
    pos% = InStr(DrvVolumeName$, Chr$(0))
 
    If pos% Then DrvVolumeName$ = Left$(DrvVolumeName$, pos% - 1)
 
    If Len(Trim$(DrvVolumeName$)) = 0 Then DrvVolumeName$ = "(pas de label)"
 
 
 
    'determine l'id du disque
 
 
 
    HiWord& = GetHiWord(VolumeSN&) And &HFFFF&
 
    LoWord& = GetLoWord(VolumeSN&) And &HFFFF&
 
 
 
    HiHexStr$ = Format$(Hex(HiWord&), "0000")
 
    LoHexStr$ = Format$(Hex(LoWord&), "0000")
 
 
 
    DrvSerialNo$ = HiHexStr$ & "-" & LoHexStr$
 
End Sub
 
Function GetHiWord(dw As Long) As Integer
 
    If dw& And &H80000000 Then
 
        GetHiWord% = (dw& \ 65535) - 1
 
    Else: GetHiWord% = dw& \ 65535
 
    End If
 
End Function
 
Function GetLoWord(dw As Long) As Integer
 
    If dw& And &H8000& Then
 
        GetLoWord% = &H8000 Or (dw& And &H7FFF&)
 
    Else: GetLoWord% = dw& And &HFFFF&
 
    End If
 
End Function
Les gars soyez indulgents car je suis débutant, Entre temps j'ai aussi cherché sur le net et à travers ce forum ;j'ai eu des codes intéressants mais ils ne fonctionnent pas avec mon code(ou du moins je n'arrive pas à les integrer à mon code);c'est pourqoui je me tourne vers vous vous etes mon seul espoir .
Si quelqu'un pouvait se pencher sur mon cas;merci d'avance
 

Misange

XLDnaute Barbatruc
Re : Empecher la copie d'un classeur

Bonjour

je n'ai pas regardé ton code qui me parait incroyablement long et compliqué pour faire ça.
Ceci, à mettre dans le ThisWorkbook est suffisant

Code:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i As Integer
  Sheets("blocage").Visible = True
 Application.ScreenUpdating = False
 For i = Sheets.Count To 2 Step -1
     Sheets(i).Visible = xlVeryHidden
 Next i

 End Sub
 
 Private Sub Workbook_Open()
 Application.ScreenUpdating = False
   For Each sh In Sheets
     sh.Visible = True
   Next sh

 Sheets("blocage").Visible = xlVeryHidden
 Sheets("accueil").Activate
 End Sub

Mais attention, ceci n'empêche ne rien la copie du classeur comme annoncé dans ton titre.
Par ailleurs il est illusoire avec excel de vouloir protéger un classeur contre quelqu'un de réellement déterminer à cracker le contenu. Il existe de nombreux couteaux suisses pour déplomber un classeur excel.

Merci d'indiquer dans ton profil et dans ton messagela version d'excel que tu utilises. C'est toujours préférable pour les répondeurs qui peuvent ainsi proposer une solution adaptée.
 

Pièces jointes

  • ouverture_macros.xlsm
    15.4 KB · Affichages: 33

Discussions similaires

Réponses
28
Affichages
924

Statistiques des forums

Discussions
311 730
Messages
2 081 978
Membres
101 854
dernier inscrit
micmag26