XL 2010 Incompatibilité VBA Windows 7 - 32 bits > Windows 10 - 64 bits

[Orson83]

Bonjour à tous,
J'ai développé un fichier XL avec macros et je suis en phase de tests. Ce fichier fonctionne très bien chez moi avec mon XL 2010 (Windows seven 32 bits) mais je rencontre un problème chez un ami qui utilise XL 2013 (Windows 10 - 64 bits). En effet, son PC ne lit par correctement la macro ci-dessous qui se trouve dans le module MdlCM ((voir capture d'écran en PJ) :
PS : J'utilise ce code pour extraire un N° de disk dur, le récupérer et l'encoder.

Option Explicit

#If VBA7 Then
Private Declare PtrSafe Function GetVolumeInformation& Lib "kernel32" Alias "GetVolumeInformationA" _
  (ByVal lpRootPathName As String, ByVal pVolumeNameBuffer As String, ByVal nVolumeNameSize _
  As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, _
  lpFileSystemFlags As Long, ByVal lpFileSystemBuffer As String, _
  ByVal nFileSystemNameSize As Long)
#Else
Private Declare Function GetVolumeInformation& Lib "kernel32" Alias "GetVolumeInformationA" _
  (ByVal lpRootPathName As String, ByVal pVolumeNameBuffer As String, ByVal nVolumeNameSize _
  As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, _
  lpFileSystemFlags As Long, ByVal lpFileSystemBuffer As String, _
  ByVal nFileSystemNameSize As Long)
#End If

Private Const MAX_FILENAME_LEN = 256

Public Function GetSerialNumber(sDrive As String)
  #If VBA7 Then
    Dim Serial As LongPtr
  #Else
    Dim Serial As Long
  #End If
  Dim Vname As String * MAX_FILENAME_LEN
  Dim FSname As String * MAX_FILENAME_LEN
  Application.Volatile
  GetVolumeInformation sDrive + "\", Vname, MAX_FILENAME_LEN, Serial, 0, 0, FSname, MAX_FILENAME_LEN
  GetSerialNumber = Serial
End Function

Function CalculPW(MotdePasse As String) As String
  Dim ii As Integer
  Dim Nb As Long
  Dim N1 As Long
  Dim Res As String
  Res = ""
  N1 = 255
  For ii = 1 To Len(MotdePasse)
    Nb = Asc(Mid$(MotdePasse, ii, 1))
    Res = Res & Chr(Nb Xor N1)
  Next ii
  CalculPW = Res
End Function

Merci pour votre aide.
Tchotchodu31

 

[Orson83]

Merci à vous deux.
Je testerai cela demain vous ferai un retour.
Bonne soirée.

 

[Staple1600]

Re

[Variante avant le dodo]
A manier avec prudence
(Ici nul besoin de vérifier le disque dur ou l'adresse MAC)

'''Sub ChapiChapo()
'''SaveSetting appname:="LaPorte", section:="La Serrure", Key:="La Clé", setting:="Achtung_Baby!"
'''End Sub
'''Sub ChapoChapi()
'''MsgBox GetSetting(appname:="LaPorte", section:="La Serrure", Key:="La Clé")
'''End Sub

C'est pour la prudence que j'ai mis les guillements (three times ) parce qu'on écrit dans la base de registre Windows.

=>Tchotchodu31
Si tu as des questions, sur l'usage de la chose, n'hésites pas.

NB: Evidemment tout ceci ne servira pas à grand-chose si on n'active pas les macros.
Mais au moins, tu as désormais plusieurs façons de "vérifier" qui utilises le classeur.

 

[Orson83]

bonjour essaie ca

#If VBA7 Then
Private Declare PtrSafe Function GetVolumeInformation& Lib "kernel32" Alias "GetVolumeInformationA" _
  (ByVal lpRootPathName As String, ByVal pVolumeNameBuffer As String, ByVal nVolumeNameSize _
  As Long, lpVolumeSerialNumber As LongPtr, lpMaximumComponentLength As Long, _
  lpFileSystemFlags As Long, ByVal lpFileSystemBuffer As String, _
  ByVal nFileSystemNameSize As LongPtr)
#Else

mais pas convaincu
tu est sur d'injecter le disque corectement
exemple "C:\" et pas seulement C

Patricktoulon, le forum,
J'ai testé cette modification sur un PC W7 64 bits et ça fonctionne.
Je te remercie pour cette contribution.
Concernant le code développé au post #12, je ne parviens pas à l'intégrer dans le code du Module MdlCM qui est indiqué au post #1.

 

[Orson83]

re

Sub test()
    Dim oFSO, oDrv
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    oDrv = Left(Environ("SystemDrive"), 1)
    Set oDrv = oFSO.GetDrive(oDrv)
    MsgBox "mondisque d'exploitation " & vbCrLf & _
    "DriveLetter     : " & oDrv.DriveLetter & vbCrLf & _
           "DriveType       : " & oDrv.drivetype & vbCrLf & _
           "FileSystem      : " & oDrv.FileSystem & vbCrLf & _
           "AvailableSpace  : " & oDrv.AvailableSpace & vbCrLf & _
           "FreeSpace       : " & oDrv.FreeSpace & vbCrLf & _
           "IsReady         : " & oDrv.IsReady & vbCrLf & _
           "Path            : " & oDrv.Path & vbCrLf & _
           "RootFolder      : " & oDrv.RootFolder & vbCrLf & _
           "SerialNumber    : " & oDrv.SerialNumber & vbCrLf & _
           "ShareName       : " & oDrv.ShareName & vbCrLf & _
           "VolumeName      : " & oDrv.VolumeName & vbCrLf & _
           "TotalSize       : " & oDrv.TotalSize
End Sub
Sub test2()
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each Drv In FSO.Drives
        If Drv.IsReady Then
            texte = texte & vbCrLf & "le support " & Drv.DriveLetter & vbCrLf & "drivetype : " & Drv.drivetype & vbCrLf & "Numero de serie : " & Drv.SerialNumber & vbCrLf & "espace disponible : :" & Drv.FreeSpace & " octets"
            texte = texte & vbCrLf & "****************************"
        End If
    Next
    MsgBox texte
End Sub

pour les api tu reviens à l'hapy hour hein

patricktoulon, le forum,
J'ai testé ce code mais je ne parviens pas à l'intégrer dans la macro qui est indiquée au post #1.
J'ai une erreur de variable avec Sub test2().

 

[Orson83]

Re

Et là aussi, tant pis pour les MACistes

Sub test()
Dim NoPasaran$
NoPasaran = GetMACAddress
MsgBox NoPasaran
End Sub
Private Function GetMACAddress(Optional PrivacyWasNotWas) As String
Dim sComputer$, myMacAddress$, oWMIService As Object, cItems As Object, oItem As Object
sComputer = "."
Set oWMIService = GetObject("winmgmts:\\" & sComputer & "\root\cimv2")
Set cItems = oWMIService.ExecQuery("SELECT * FROM Win32_NetworkAdapterConfiguration WHERE IPEnabled = True")
For Each oItem In cItems
        If Not IsNull(oItem.IPAddress) Then myMacAddress = oItem.macAddress
        Exit For
    Next
GetMACAddress = myMacAddress
End Function

NB: En théorie, on change plus souvent de disque dur que de carte réseau
Mais si on change de PC, le classeur ne fonctionnera plus.
(Heureusement que...)

Staple, le forum,
Merci pour ce code mais le classeur n'est pas destiné aux possesseurs de Mac, car dans ce cas, je devrais revoir la totalité du code VBA de mon classeur. Je ne vais pas m'aventurer sur ce terrain

 

[Orson83]

Re

[Variante avant le dodo]
A manier avec prudence
(Ici nul besoin de vérifier le disque dur ou l'adresse MAC)

'''Sub ChapiChapo()
'''SaveSetting appname:="LaPorte", section:="La Serrure", Key:="La Clé", setting:="Achtung_Baby!"
'''End Sub
'''Sub ChapoChapi()
'''MsgBox GetSetting(appname:="LaPorte", section:="La Serrure", Key:="La Clé")
'''End Sub

C'est pour la prudence que j'ai mis les guillements (three times ) parce qu'on écrit dans la base de registre Windows.

=>Tchotchodu31
Si tu as des questions, sur l'usage de la chose, n'hésites pas.

NB: Evidemment tout ceci ne servira pas à grand-chose si on n'active pas les macros.
Mais au moins, tu as désormais plusieurs façons de "vérifier" qui utilises le classeur.

Staple, le forum,
Merci pour ce code mais le classeur n'est pas destiné aux possesseurs de Mac et je préfère éviter d'aller piocher des infos dans la base de registre d'un PC. Je cherche effectivement à protéger le classeur mais je n'irai pas jusque là.
Merci d'avoir regardé.

 

[Staple1600]

Re

Tchotchodu31
Tu n'as pas compris le sens de mon message.
(Je voulais dire que ma syntaxe comme de patricktoulon ne peut fonctionner que sur un environnement Windows)
Quant à la proposition de tester la MAC address (qui n'a rien avoir avec le MAC d'Apple), c'est plus simple que tester le numéro de série d"un disque dur (car comme je l'ai dit on change plus souvent de disque dur que de carte réséau)

Est-ce tu as testé le code pour affcher l'adresse MAC de ta carte réseau?

Tu verras que cela renvoie un String (comme le numéro de série d'un disque dur)

Donc dans ce cas, il n'y a pas grand-chose à changer.

 

[Orson83]

Re

Tchotchodu31
Tu n'as pas compris le sens de mon message.
(Je voulais dire que ma syntaxe comme de patricktoulon ne peut fonctionner sur un environnement Windows)
Quant à la proposition de tester la MAC address (qui n'a rien avoir avec le MAC d'Apple), c'est plus simple que tester le numéro de série d"un disque dur (car comme je l'ai dit on change plus souvent de disque dur que de carte réséau)

Est-ce tu as testé le code pour affcher l'adresse MAC de ta carte réseau?

Tu verras que cela renvoie un String (comme le numéro de série d'un disque dur)

Donc dans ce cas, il n'y a pas grand-chose à changer.

D'accord, merci, je vais regarder.

 

[Staple1600]

RE

Ce qui donnerait avec le code précemment fourni (et avec ton code de ton premier message)

Sub test_II()
Dim vMAC$, xORMAC$
vMAC = GetMACAddress
MsgBox vMAC
xORMAC = CalculPW(vMAC)
MsgBox xORMAC
End Sub

 

[patricktoulon]

re

bonjour tout les deux
Staple1600 j'y ai pensé hier a wmi et au registre ,je ne les ai pas proposé car souvent il sont rejetés

le registre bon ben on sait pourquoi
wmi données incomplète

 

[Staple1600]

Bonjour patricktoulon

=>patricktoulon
La MAC adress ca peut suffire, non ?
(même si on sait tous les deux que cela qu'au final ne protège que le sentiment que le classeur est protégé )

 

[Orson83]

RE

Ce qui donnerait avec le code précemment fourni (et avec ton code de ton premier message)

Sub test_II()
Dim vMAC$, xORMAC$
vMAC = GetMACAddress
MsgBox vMAC
xORMAC = CalculPW(vMAC)
MsgBox xORMAC
End Sub

Merci beaucoup, je vais tester cela.
A+

 

[patricktoulon]

re
@Staple1600
oui bien sur c'est une hérésie de croire protéger un classeur

 

[Orson83]

Merci beaucoup, je vais tester cela.
A+

Je n'ai pas testé MAC Adress car j'ai fondé ma protection sur le N° du disque dur. Ceci dit, je suis d'accord qu'il est plus probable de remplacer un disque dur q'une carte réseau.
J'ai également élaboré avec XL et grâce aux participants de ce forum, un utilitaire qui me permet de récupérer le N° de DD, encoder, décoder, etc.
Je suis content d'avoir enfin finalisé mon projet et mon faible niveau en VBA me contraint à me satisfaire de ce qui fonctionne aujourd'hui. Merci Staple pour cette proposition.

 

[Staple1600]

Spoiler: Attention message rédigé avec mon crayon "Humour"

************************************************************************

Re

Merci à vous deux.
Je testerai cela demain vous ferai un retour.
Bonne soirée.

[avis personnel rédigé en écoutant https://www.youtube.com/watch?v=GhK6D05EamE]
*: Par simple courtoisie, l'usage serait que le demandeur prenne le temps de tester un code VBA ou une formule proposés par chaque intervenant dans sa discussion.
Comme chaque intervenant prends le temps de chercher, tester et proposer des codes et/ou formules sur le forum.
*: C'est indolore et très peu chronophage.
CTRL/C/V puis F5
[avis personnel]



[Pour mémoire]
Tout ceci ne "sert" à rien puisque Excel permet à tout utilisateur d'ouvrir un classeur sans activer les macros.
Et quant cet utilisateur aura ouvert ce classeur sans activer les macros, il suffira de faire un Enregistrer sous => *.xlsx
Mais au moins, on aura passé un peu de temps dans VBE à pondre du VBA, ce qui est toujours plaisant.
[/Pour mémoire]