Compatibilité 32 bits 64 bits

Le 15/04/2017 à 17:45

Bonjour à tous,

Je développe un fichier Excel qui va me permettre de gérer des licences.

Dans l'état il fonctionne à merveille auprès de longues heures de recherche et d'aide de la part du forum (chapeau bas).

Et là j'ai plusieurs retours de personnes qui n'arrivent pas à l'utiliser.

J’ai donc grâce à teamviewer regardé et je me suis aperçu qu'ils sont en 64 bits.

Après avoir pris des renseignements à droite et à gauche sur les forums il y a du code à modifier, mais j'essaie depuis deux jours et rien ne va.

Je voudrais intégrer les deux versions dans le même fichier comme cela pas besoin de demander si il a une version 32 ou 64.

J’ai vu avec le test VBA7 WIN32..... mais je ne m'en sors pas.

J’ai donc extirpé le code qui me semble poser problème pour savoir si quelqu'un pourrait m'aider à le transformer pour qu'il fonctionne en 32 et en 64 bits. le reste du code est du standard (action sur des cellules, calcul,....)

à l'avance un grand merci pour votre aide.

le fichier possède les fonction suivante:

  • détection d'une licence sur un site
  • version d'essai + ou - longue
  • une partie ADMIN
  • un chrono pour limiter l'utilisation
Option Private Module
Public Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" _
(ByVal lpRootPathName As String, _
ByVal lpVolumeNameBuffer As String, _
ByVal nVolumeNameSize As Long, _
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 Essai()
    [H1] = Abs(NumSerieDD("C"))
End Sub
Option Private Module
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
    "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, _
    ByVal szFileName As String, ByVal dwReserved As Long, _
    ByVal lpfnCB As Long) As Long

Function TestFichierRenomm_()
    '----------------------------------------------------------
    '                             Test si fichier a _t_ renomm_
    '----------------------------------------------------------
    If ThisWorkbook.Name <> [ND_NomFich] Then
        xMess = Empty
        xMess = xMess & "Le nom du fichier n'est pas celui d'origine" & Chr(13)
        xMess = xMess & "Opération de renommage interdite" & Chr(13) & Chr(13)
        xMess = xMess & "Fermeture imminente du fichier"
        MsgBox xMess, vbCritical, "Renommage du fichier interdit"
        xRenomme = True
    Else
        xRenomme = False
    End If
    TestFichierRenomm_ = xRenomme
End Function

Function TestAdministrateur()
    '-----------------------------------------------------------
    '                                     Test si ADMINISTRATEUR
    '-----------------------------------------------------------
       For f = 1 To Range("Tab_ADMIN[Nom]").Count
        If Application.UserName = [Tab_ADMIN[Nom]].Item(f) Then                     'Option EXCEL
            xAdmin = True               'Si ADMINISTRATEUR trouv_, on quitte
            xMess = Empty

            MsgBox xMess, vbInformation, "ADMINISTRATEUR"
                    Sheets("ADMIN").Range("A5") = 1

            Exit For
        Else
                    Sheets("ADMIN").Range("A5") = 0

            xAdmin = False              'Si pas ADMINISTRATEUR
        End If
    Next f
    If xAdmin = True Then
    Sheets("MENU").Visible = True
    Sheets("Donnees").Visible = True
    Sheets("Feuil1").Visible = True
    Sheets("ADMIN").Visible = True
    Else
    Sheets("MENU").Visible = True
    Sheets("Donnees").Visible = False
    Sheets("Feuil1").Visible = False
    Sheets("ADMIN").Visible = False
    End If
    [ND_Admin] = xAdmin
    TestAdministrateur = xAdmin
End Function

Function TestPCAutoris_()
    '----------------------------------------------------------
    '                    Test si fichier ouvert sur PC autoris_
    '----------------------------------------------------------

    Dim FichierASupprimer As String

If Worksheets("ADMIN").Range("A5").Value = 1 Then GoTo fin

For f = 16 To 150

        If Worksheets("ADMIN").Range("G" & f).Value = Worksheets("ADMIN").Range("H1").Value Then
            xPCOK = True
            Worksheets("ADMIN").Range("A1") = 1
            Exit For
        Else
            xPCOK = False
            Worksheets("ADMIN").Range("A1") = 0
        End If
    Next f

    If xPCOK = False Then
        xMess = Empty
        xMess = xMess & "Pas de licence achetée pour ce logiciel" & Chr(13) & Chr(13)
        xMess = xMess & ""
        MsgBox xMess, vbCritical, "Pas d'autorisation"
    End If

    TestPCAutoris_ = xPCOK
fin:

End Function

    '----------------------------------------------------------

    '----------------------------------------------------------
    Xdate = Worksheets("ADMIN").Range("c5").Value
    lDate = Worksheets("ADMIN").Range("c6").Value
    TE_L1 = Worksheets("ADMIN").Range("L2").Value
    TE_L3 = Worksheets("ADMIN").Range("L4").Value

   ' lance une fois par jour

    If TE_L3 = 1 And Date = Xdate Then
        xMess = Empty
        xMess = xMess & "Fichier ouvert aujourd'hui pour la deuxieme fois" & Chr(13)
        xMess = xMess & "Une seule utilisation est prevue par jour" & Chr(13) & Chr(13)
        xMess = xMess & "Fermeture imminente du fichier"

        xMemeJour = True
        Sheets("ADMIN").Visible = False

        Worksheets("ADMIN").Range("c5").Value = Date
        Sheets("ADMIN").Range("A2") = 0
        Call Sauve

    Else
        xMemeJour = False

        Worksheets("ADMIN").Range("c5").Value = Date
        Sheets("ADMIN").Range("A2") = 1
        Sheets("ADMIN").Visible = False

    End If

    Worksheets("ADMIN").Range("c5").Value = Date

    Sheets("ADMIN").Visible = False

End Function

 Sub Get_File_From_FTP()
    Dim URL As String
    Dim LocalFileName As String
    Dim ErrorText As String

    URL = "http://monsite.fr/Licences/REVERSIBLE.txt"
    LocalFileName = Workbooks(ActiveWorkbook.Name).Path & "\LICENCE.txt"
    B = DownloadFile(UrlFileName:=URL, _
                    DestinationFileName:=LocalFileName, _
                    Overwrite:=OverwriteRecycle, _
                    ErrorText:=ErrorText)
    If B = False Then
        MsgBox "Site des licences hors ligne veuillez essayer plus tard"
        Call quitte
    Else
    End If

End Sub

Function TestTrial()
    '----------------------------------------------------------
    '            Test si fichier version Trial
    '----------------------------------------------------------
    Xdate = Worksheets("ADMIN").Range("c5").Value
    lDate = Worksheets("ADMIN").Range("c6").Value
    TE_L1 = Worksheets("ADMIN").Range("L2").Value
    TE_L3 = Worksheets("ADMIN").Range("L4").Value

    If Date < Xdate Then
    xMess = xMess & "remettre l'ordinateur à la date du jour." & Chr(13)
        xMess = xMess & "Si vous voulez continuer à utiliser le logiciel" & Chr(13) & Chr(13)
        xMess = xMess & "merci de l'acheter ou de prendre un abonnement"
        MsgBox xMess, vbCritical, "Changer la DATE"
        Call quitte

Else
End If
    'lance pour une periode

    If TE_L1 = 1 And Date > lDate Then
        xMess = Empty
        xMess = xMess & "Le fichier est arrivé à la fin de sa période d'évaluation" & Chr(13)
        xMess = xMess & "Si vous voulez continuer à utiliser le logiciel" & Chr(13) & Chr(13)
        xMess = xMess & "merci de l'acheter ou de prendre un abonnement"
        MsgBox xMess, vbCritical, "Version d'évaluation"
        xtrial = True
        TestTrial = xtrial
        Worksheets("ADMIN").Range("c5").Value = Date
        Worksheets("ADMIN").Range("M2").Value = Date
        Sheets("ADMIN").Range("A4") = 0

    Else
        xtrial = False
        TestTrial = xtrial
        Sheets("ADMIN").Range("A4") = 1
    End If

    TestTrial = xtrial

End Function
Option Private Module
Option Explicit
Option Compare Text

Public Enum DownloadFileDisposition
    OverwriteKill = 0
    OverwriteRecycle = 1
    DoNotOverwrite = 2
    PromptUser = 3
End Enum

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Windows API functions, constants,and types.
' Used for RecycleFile.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Declare Function SHFileOperation Lib "shell32.dll" Alias _
    "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long

Private Declare Function PathIsNetworkPath Lib "shlwapi.dll" _
    Alias "PathIsNetworkPathA" ( _
    ByVal pszPath As String) As Long

Private Declare Function GetSystemDirectory Lib "kernel32" _
    Alias "GetSystemDirectoryA" ( _
    ByVal lpBuffer As String, _
    ByVal nSize As Long) As Long

Private Declare Function SHEmptyRecycleBin _
    Lib "shell32" Alias "SHEmptyRecycleBinA" _
    (ByVal hWnd As Long, _
     ByVal pszRootPath As String, _
     ByVal dwFlags As Long) As Long

Private Const FO_DELETE = &H3
Private Const FOF_ALLOWUNDO = &H40
Private Const FOF_NOCONFIRMATION = &H10
Private Const MAX_PATH As Long = 260

Private Type SHFILEOPSTRUCT
    hWnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer
    fAnyOperationsAborted As Boolean
    hNameMappings As Long
    lpszProgressTitle As String
End Type

''''''''''''''''''''''''''''''''''''''
' Download API functions.
''''''''''''''''''''''''''''''''''''''
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
                        "URLDownloadToFileA" ( _
                            ByVal pCaller As Long, _
                            ByVal szURL As String, _
                            ByVal szFileName As String, _
                            ByVal dwReserved As Long, _
                            ByVal lpfnCB As Long) As Long

Private Declare Function DeleteUrlCacheEntry Lib "wininet.dll" Alias _
    "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long

Public Function DownloadFile(UrlFileName As String, _
                            DestinationFileName As String, _
                            Overwrite As DownloadFileDisposition, _
                            ErrorText As String) As Boolean

Dim Disp As DownloadFileDisposition
Dim Res As VbMsgBoxResult
Dim B As Boolean
Dim S As String
Dim L As Long

ErrorText = vbNullString

If Dir(DestinationFileName, vbNormal) <> vbNullString Then
    Select Case Overwrite
        Case OverwriteKill
            On Error Resume Next
            Err.Clear
            Kill DestinationFileName
            If Err.Number <> 0 Then
                ErrorText = "Error Kill'ing file '" & DestinationFileName & "'." & vbCrLf & Err.Description
                DownloadFile = False
                Exit Function
            End If

        Case OverwriteRecycle
            On Error Resume Next
            Err.Clear
            B = RecycleFileOrFolder(DestinationFileName)
            If B = False Then
                ErrorText = "Error Recycle'ing file '" & DestinationFileName & "." & vbCrLf & Err.Description
                DownloadFile = False
                Exit Function
            End If

        Case DoNotOverwrite
            DownloadFile = False
            ErrorText = "File '" & DestinationFileName & "' exists and disposition is set to DoNotOverwrite."
            Exit Function

        'Case PromptUser
        Case Else
            S = "The destination file '" & DestinationFileName & "' already exists." & vbCrLf & _
                "Do you want to overwrite the existing file?"
            Res = MsgBox(S, vbYesNo, "Download File")
            If Res = vbNo Then
                ErrorText = "User selected not to overwrite existing file."
                DownloadFile = False
                Exit Function
            End If
            B = RecycleFileOrFolder(DestinationFileName)
            If B = False Then
                ErrorText = "Error Recycle'ing file '" & DestinationFileName & "." & vbCrLf & Err.Description
                DownloadFile = False
                Exit Function
            End If
    End Select
End If

L = DeleteUrlCacheEntry(UrlFileName)

L = URLDownloadToFile(0&, UrlFileName, DestinationFileName, 0&, 0&)
If L = 0 Then
    DownloadFile = True
Else
    ErrorText = "Buffer length invalid or not enough memory."
    DownloadFile = False
End If

End Function

Private Function RecycleFileOrFolder(FileSpec As String) As Boolean

    Dim FileOperation As SHFILEOPSTRUCT
    Dim lReturn As Long

    If (Dir(FileSpec, vbNormal) = vbNullString) And _
        (Dir(FileSpec, vbDirectory) = vbNullString) Then
        ' FileSpec does not exist. Return true since the
        ' end result is the same as if the file/folder was
        ' recycled.
        RecycleFileOrFolder = True
        Exit Function
    End If

    With FileOperation
        .wFunc = FO_DELETE
        .pFrom = FileSpec
        .fFlags = FOF_ALLOWUNDO
        '
        ' OR if you want to suppress the "Do You want
        ' to delete the file" message, use
        '
        .fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMATION
    End With

    lReturn = SHFileOperation(FileOperation)
    If lReturn = 0 Then
        RecycleFileOrFolder = True
    Else
        RecycleFileOrFolder = False
    End If
End Function
Le 15/04/2017 à 18:08

Bonjour,

Teste pour voir mais sans réussite à 100%

30test.xlsm (26.37 Ko)
Le 15/04/2017 à 20:02

Bonsoir,

j'ai mis le tout dans mon fichier d'origine et la il ne veux plus s'ouvrir excel plante à chaque fois.

je vais regarder si je trouve quelque chose.

merci pour ton aide.

Daniel

ci-joint mon fichier.

alors il va y avoir des erreurs car j'ai supprimé les pages sensibles.

mais le code concerné par le 32 et 64 bits est dedans

a l'avance un grand merci.

Daniel

23jeux-v2.xlsm (74.83 Ko)
Le 15/04/2017 à 21:08

Bonsoir,

L'explication est très bien détaillée dans l'Aide...

#If Vba7 Then
    Declare PtrSafe Sub...
#Else
    Declare Sub...
#EndIf

VBA7 intervient à partir d'Excel 2010. La 2e version de ta déclaration d'API (sous #Else) qui est la version d'origine s'appliquera aux version antérieures d'Excel (qui sont en 32 bits). La 1re qui est la version modifiée s'appliquera aux versions à partir de 2010, 32 ou 64 bits.

Les modifications à opérer dans la déclaration consiste d'une part à l'introduire avec le mot-clé PtrSafe, d'autre part à modifier les déclarations de type des variables Long en LongPtr.

La version de M12 ( ) a omis ce dernier point que tu peux rapidement rectifier pour la reprendre...

Ensuite, faut attendre les retours de tests !

NB- Les Long sont déclarées Long dans ton API, mais tu peux trouver dans certaines le nom de la variable terminé par & qui est le caractère de déclaration de type pour Long : dans ce cas il faut supprimer ce & et le remplacer par As LongPtr).

Cordialement.

Le 16/04/2017 à 11:04

bonjour,

j'ai donc fait les modification et là il tourne en 32 bits reste à voir s'il n'y as pas de problème en 64 bits.

encore merci je vous tiens au courant.

Daniel

Le 17/04/2017 à 12:36

Bonjour à tous,

Bon je viens de passer quelques heures sur mon fichier est Grrrrrrrrrr cela ne marche pas.

explications:

J’ai donc réalisé un fichier avec une version 32 bits et le problème est que des personnes ont une version 64 bits.

J’ai donc à l'aide de test fait pour que cela marche sur les deux versions, mais en 64 bits j'ai des erreurs et pas moyen de trouver la solution.

Je crois que je ne suis pas loin, mais voilà je n'ai qu'une version 32 bits et pour tester dur dur je suis obligé d'attendre le retour d'une personne pour savoir. mais là je ne sais vraiment plus quoi faire.

Donc si une personne a une version 64 bits pour tester et corriger ce serait le bonheur.

Je vous joins donc mon fichier qui j'espère va vous inspirer pour m'aider.

À l'avance mille mercis.

Daniel

35test-reversible-64-bits.xlsm (161.51 Ko)
Le 17/04/2017 à 13:15

Relis tes déclarations déjà ! Pour le code devant fonctionner sur 64 ou 32 bits, chaque fois chaque fois que tu as Long, non remplacé par LongPtr, c'est une variable qui ne fonctionnera pas sous 64 bits !

Cordialement.

Le 17/04/2017 à 13:17

ok je regarde mais si je met longptr cela va fonctionner quand même sur 32 bits?

Le 17/04/2017 à 13:21

bonjour M ferrand, danval et le forum

dans un des post dessous cette discussion engue engue a donner un exemple de code compatible qui a résolu le post du demandeur

https://forum.excel-pratique.com/excel/compatibilite-excel-2010-32-bits-et-64-bits-t53704.html

Le 17/04/2017 à 13:23

Oui, LongPtr n'est pas un type de données, c'est un type de déclaration qui se traduit par Long sur 32 bits et LongLong sur 64 bits.

Le 17/04/2017 à 14:46

Re,

bon avec vos conseil j'ai fais les modifs et la tout fonctionne.

miracle du savoir des gens.

Merci à tous

Le 17/04/2017 à 16:00

juste encore un problème:

j'ai besoin d'une détection de numéro de DD.

en version 32 bits cela marche mais pas en 64 bits.

voici le code 32 bits qui fonctionne:

Public Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" _
(ByVal lpRootPathName As String, _
ByVal lpVolumeNameBuffer As String, _
ByVal nVolumeNameSize As Long, _
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 LongPtr
    Dim R As LongPtr
    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

pour la version 64 bits ce code marche:

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

Sub Macro1()
 Dim Serial As Long, VName As String, FSName As String
    VName = String$(255, Chr$(0))
    FSName = String$(255, Chr$(0))
    GetVolumeInformation "C:\", VName, 255, Serial, 0, 0, FSName, 255
    MsgBox Trim(Str$(Serial))
End Sub

il affiche le numéro du DD.

j'aimerais pourvoir intégrer les deux afin d'avoir dans la variable NumSerieDD le numéro du DD suivant la version mais là pas moyen??

avez vous une idée?

MERCI pour votre aide. aprés je vous embête plus.

Daniel

Le 17/04/2017 à 20:16

rebonjour,

voila comment j'ai placé mon code est-ce que quelqu'un peux tester sur une version 64 bits et me dire si cela fonctionne.

il y as la macro toto pour afficher le numéro dans la case H1.

à l'avance merci.

Daniel

Option Private Module

#If VBA7 Then

Public Declare PtrSafe Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" _
(ByVal lpRootPathName As String, _
ByVal lpVolumeNameBuffer As String, _
ByVal nVolumeNameSize As LongPtr, _
lpVolumeSerialNumber As LongPtr, _
lpMaximumComponentLength As LongPtr, _
lpFileSystemFlags As LongPtr, _
ByVal lpFileSystemNameBuffer As String, _
ByVal nFileSystemNameSize As LongPtr) As LongPtr

#Else

Public Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" _
(ByVal lpRootPathName As String, _
ByVal lpVolumeNameBuffer As String, _
ByVal nVolumeNameSize As Long, _
lpVolumeSerialNumber As Long, _
lpMaximumComponentLength As Long, _
lpFileSystemFlags As Long, _
ByVal lpFileSystemNameBuffer As String, _
ByVal nFileSystemNameSize As Long) As Long
#End If

    Function NumSerieDD(LettreDD As String) As LongPtr

    Dim Serial As LongPtr, VName As String, FSName As String

    VName = String$(255, Chr$(0))
    FSName = String$(255, Chr$(0))
    GetVolumeInformation "C:\", VName, 255, Serial, 0, 0, FSName, 255
    NumSerieDD = Serial

End Function

Sub Essai()
    [H1] = Abs(NumSerieDD("C"))
End Sub

Sub toto()
    Dim Serial As LongPtr, VName As String, FSName As String
    VName = String$(255, Chr$(0))
    FSName = String$(255, Chr$(0))
    GetVolumeInformation "C:\", VName, 255, Serial, 0, 0, FSName, 255
    VName = Left$(VName, InStr(1, VName, Chr$(0)) - 1)
    FSName = Left$(FSName, InStr(1, FSName, Chr$(0)) - 1)
    [H1] = Trim(Str$(Serial))
    End Sub
Le 18/04/2017 à 15:14

Bonjour,

personne en 64 bits pour tester et me dire s'il y as un problème?

Le 18/04/2017 à 21:51

Bonsoir danval

je n'ai pas 64 bits mais il me semble que le code 32/64 se mets en tout du module avant même option explicit ou compare où autre

Le 19/04/2017 à 09:57

Bonjour à tous,

suite aux remarques j'ai modifié mon code.

dans le fichier ci-joint deux macros qui permettent de mettre en H1 et H3 le numéro de DD.

je viens de tester sur 32 bits et cela fonctionne dans les deux cas.

quelqu'un pourrait tester sur un 64 bits et me dire si cela marche sur les deux macros ou sur une et laquelle ou pas du tout.

à l'avance un grand merci

Daniel

19essai-daniel.xlsm (12.92 Ko)
Le 19/04/2017 à 14:35

personne pour me faire ce petit test???

Le 19/04/2017 à 14:51

Peu de monde pour utiliser Excel en 64 bits !

Tes clients concernés testeront... !

Rechercher des sujets similaires à "compatibilite bits"