Autoriser l'ouverture que sur un PC spécifique

[Nagrom]

Bonjour à tous,

J'ai entendu parler qu'on pouvait faire un sorte qu'un classeur excel ne s'ouvre que sur un ordinateur précis. Apriori, le numéro de série du disque dur serait inscrit dans le classeur et si ce n'est pas le bon, le fichier ne s'ouvre pas.

Est-il possible de réaliser ce type de protection,

Merci.
Cordialement.

 

[Guest]

Re : Autoriser l'ouverture que sur un PC spécifique

Bonjour Nagrom,

Et que fais tu si un jour tu changes de Disque dur?

A bientôt

 

[ftho]

Re : Autoriser l'ouverture que sur un PC spécifique

Bonjour,

Ci-dessous un bout de code qui te donnera le numéro de série de ton disque "C". Insèle le code dans un module standard et exécute Test_NumDD

Private Declare Function GetVolumeInformation Lib _
"Kernel32.dll" Alias "GetVolumeInformationA" (ByVal _
lpRootPathName As String, ByVal lpVolumeNameBuffer As _
String, ByVal nVolumeNameSize As Integer, _
lpVolumeSerialNumber As Long, _
lpMaximumComponentLength _
As Long, lpFileSystemFlags As Long, ByVal _
lpFileSystemNameBuffer As String, ByVal _
nFileSystemNameSize As Long) As Long

Function NumSerieDD(LettreDD As String) As Long
Dim SerialNum As Long
Dim R As Long
Dim Temp1 As String
Dim Temp2 As String
LettreDD = LettreDD & ":\"
Temp1 = String$(255, Chr$(0))
Temp2 = String$(255, Chr$(0))
R = GetVolumeInformation(LettreDD, Temp1, _
Len(Temp1), SerialNum, 0, 0, Temp2, Len(Temp2))
NumSerieDD = SerialNum
End Function

Sub Test_NumDD()
MsgBox NumSerieDD("C")
End Sub

Tu peux éventuellement combiner le N° du disque dur avec le login de l'utilisateur du pc afin de s'assurer que c'est le bon pc et la bonne personne. Pour le login c'est :
Environ("Username")

 

[Nagrom]

Re : Autoriser l'ouverture que sur un PC spécifique

Bonjour à vous,

Si ce système est possible, il serait mis en place sur 3 PC donc si jamais il devait avoir un changement de disque dur, je pourrai toujours changer les numéros de série via les autres ordinateurs.

Merci pour le code. Dois-je le laisser dans le fichier dont je souhaite restreindre l'accès?

Cordialement.

 

[Nagrom]

Re : Autoriser l'ouverture que sur un PC spécifique

Re,

Peut-on réaliser ce type de protection?

Merci.

 

[JCGL]

Re : Autoriser l'ouverture que sur un PC spécifique

Bonjour à tous,

Un essai à placer dans un module Standard.

Option Explicit

Private Declare Function GetVolumeInformation Lib _
"Kernel32.dll" Alias "GetVolumeInformationA" (ByVal _
lpRootPathName As String, ByVal lpVolumeNameBuffer As _
String, ByVal nVolumeNameSize As Integer, _
lpVolumeSerialNumber As Long, _
lpMaximumComponentLength _
As Long, lpFileSystemFlags As Long, ByVal _
lpFileSystemNameBuffer As String, ByVal _
nFileSystemNameSize As Long) As Long

Function NumSerieDD(LettreDD As String) As Long
Dim SerialNum As Long
Dim R As Long
Dim Temp1 As String
Dim Temp2 As String
LettreDD = LettreDD & ":\"
Temp1 = String$(255, Chr$(0))
Temp2 = String$(255, Chr$(0))
R = GetVolumeInformation(LettreDD, Temp1, _
Len(Temp1), SerialNum, 0, 0, Temp2, Len(Temp2))
NumSerieDD = SerialNum
End Function

Sub Test_NumDD()
If Environ("Username") = "jAutre" And NumSerieDD("C") = "-1610042500" Then ' Adapter les Infos en testant avec Test_Info
MsgBox "Vous êtes autorisé à accéder à ce fichier", , "Sécurité"
Else:  MsgBox "Vous n'avez pas l'autorisation d'accéder à ce fichier", , "Sécurité"
Exit Sub
End If
End Sub

Sub Test_Info()
Range("A1") = Environ("Username")
Range("A2") = NumSerieDD("C")
End Sub

Ceci n'est qu'un Test. Le code pourrait se trouver dans le ThisWorkBook et en Open.
Voir un Application.Quit au lieu d'un Exit Sub (dans la Sub Test_NumDD)

A+

 

[Nagrom]

Re : Autoriser l'ouverture que sur un PC spécifique

Bonjour,

Merci pour le code. Je l'ai placé dans le This WorkBook en ajoutant une ligne Application.quit comme ceci:

Option Explicit

Private Declare Function GetVolumeInformation Lib _
"Kernel32.dll" Alias "GetVolumeInformationA" (ByVal _
lpRootPathName As String, ByVal lpVolumeNameBuffer As _
String, ByVal nVolumeNameSize As Integer, _
lpVolumeSerialNumber As Long, _
lpMaximumComponentLength _
As Long, lpFileSystemFlags As Long, ByVal _
lpFileSystemNameBuffer As String, ByVal _
nFileSystemNameSize As Long) As Long

Function NumSerieDD(LettreDD As String) As Long
Dim SerialNum As Long
Dim R As Long
Dim Temp1 As String
Dim Temp2 As String
LettreDD = LettreDD & ":\"
Temp1 = String$(255, Chr$(0))
Temp2 = String$(255, Chr$(0))
R = GetVolumeInformation(LettreDD, Temp1, _
Len(Temp1), SerialNum, 0, 0, Temp2, Len(Temp2))
NumSerieDD = SerialNum
End Function
Private Sub Workbook_Open()
    
If NumSerieDD("C") = "-n° de série" Then ' Adapter les Infos en testant avec Test_Info
MsgBox "Vous êtes autorisé à accéder à ce fichier", , "Sécurité"
Else:  MsgBox "Vous n'avez pas l'autorisation d'accéder à ce fichier", , "Sécurité"
Application.Quit

Exit Sub
End If
End Sub

Par contre, on peut facilement contourner le système: si, via un nouveau classeur, on met Visual Basic à l'arrêt, on peut accèder au fichier comportant le code sans problème.

Peut-on pallier à ceci?

Merci.
Cordialement.

 

[JCGL]

Re : Autoriser l'ouverture que sur un PC spécifique

Bonjour à tous,

Pour le code tu peux protéger le Projet VBA. Mais le MdP ne devrait pas résister longtemps...

A+

PS : pour une "sécurité renforcée" tu peux aussi vérifier l'UserName par :

Sub Test_NumDD()
If Environ("Username") = "Autre" And NumSerieDD("C") = "-1610042500" Then ' Adapter les Infos en testant avec Test_Info
MsgBox "Vous êtes autorisé à accéder à ce fichier", , "Sécurité"
Else:  MsgBox "Vous n'avez pas l'autorisation d'accéder à ce fichier", , "Sécurité"
ActiveWorkbook.Saved = True
ActiveWorkbook.Close
End If
End Sub

Il est préférable d'utiliser Saved et Close plutôt qu'Application.Quit

 

[Nagrom]

Re : Autoriser l'ouverture que sur un PC spécifique

Bonjour,

Merci pour les conseils.
Le projet VBA est protégé mais comme dit, en passant via un nouveau classeur et en stoppant le Visual Basic, on peut accéder sans problème au classeur et faire n'importe quelles modifications dans les cellules.

Ce n'est pas très pratique mais je pense pas qu'on puisse y remédier.