Discussion :

[fanlabise31]

Bonjour,

On me demande de m'assurer lors de l'ouverture d'un document que ce dernier n'a pas été modifié.

Pour cela je souhaiterai calculer la valeur MD5 du document au moment de son ouverture. On pourrait aussi utiliser sa valeur CRC. J'ai déjà créé une macro qui permet de compter le nombre d'occurence (ligne, caractères, saut de pages...) puis qui transforme la valeur en Hexa. Malheureusement ce n'est pas assez robuste. Le MD5 checksum me parait être le plus adapté.

Je n'arrive pas à appliquer ce que je trouve sur le net.

Pouvez-vous m'aider?

Merci

[kiki29]

Salut, regarde ici pour les librairies et là pour un exemple ( juste pour une chaîne ), donc à adapter

PS : je me souviens d'avoir un fichier Excel qui fait du MD5 pour un fichier sélectionnable , mais je dois le retrouver sur mes CDs ....

[kiki29]

Salut, je soliloque mais pour l'instant pas de trace du MD5 par contre pour CRC32 j'ai retrouvé ceci :
A adapter à ton contexte, en affectant un bouton à la procédure "Test_Crc32"

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
Option Explicit
 
Private Declare Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean
 
Sub Test_Crc32()
Dim Debut As Currency, Fin As Currency, Freq As Currency
Dim sFichier As Variant
Dim sBuf As String
Dim aiBuf() As Byte
Dim iFichier As Integer
 
    sFichier = Application.GetOpenFilename(FileFilter:="Tous, *.*", Title:="Sélection Fichier")
    If sFichier = False Then Exit Sub
    QueryPerformanceCounter Debut
 
    iFichier = FreeFile
    Open sFichier For Binary Access Read As #iFichier
        sBuf = Input(LOF(iFichier), iFichier)
    Close iFichier
 
    aiBuf = StrConv(sBuf, vbFromUnicode)
    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq
    With Feuil1
        .Cells(1, 1) = sFichier
        .Cells(1, 2) = Hex(Crc32(aiBuf))
        .Cells(1, 3) = Format((Fin - Debut) / Freq, "0.00 s")
        .Columns("A:C").AutoFit
        .Cells(1, 4).Select
    End With
 
End Sub
 
Private Function Crc32(aiBuf() As Byte) As Long
Static aiCRC() As Long
Static bInit As Boolean
Dim i As Long, j As Long
Dim iLookup As Integer
Dim dwCrc As Long
Const iPoly As Long = &HEDB88320
 
    If Not bInit Then
        ReDim aiCRC(0 To 255)
        For i = 0 To 255
            dwCrc = i
            For j = 8 To 1 Step -1
                If (dwCrc And 1) Then
                    dwCrc = ((dwCrc And &HFFFFFFFE) \ 2&) And &H7FFFFFFF
                    dwCrc = dwCrc Xor iPoly
                Else
                    dwCrc = ((dwCrc And &HFFFFFFFE) \ 2&) And &H7FFFFFFF
                End If
            Next j
            aiCRC(i) = dwCrc
        Next i
        bInit = True
    End If
 
    Crc32 = &HFFFFFFFF
 
    For i = LBound(aiBuf) To UBound(aiBuf)
        iLookup = (Crc32 And &HFF) Xor aiBuf(i)
        Crc32 = ((Crc32 And &HFFFFFF00) \ &H100) And &HFFFFFF
        Crc32 = Crc32 Xor aiCRC(iLookup)
    Next i
 
    Crc32 = Not (Crc32)
End Function

les recherches archéologiques se poursuivent pour le MD5 .......

[clementmarcotte]

Bonjour,

Si c'est pour vérifier un fichier Office, il y a probablement toutes les informations nécessaires dans les propriétés des fichiers.

Sans être sur des vrais noms qui peuvent changer selon les versions, il y a :

DateLastSaved
DateLastModified
LastModifiedBy

À moins d'être un "Power User", comme ils disent en anglais, bien peu d'utilisateurs savent comment modifier ces données.

En VBA on peu interroger les BuiltInDocumentProperties ou passer par DSOFile. La dernière version de DSoFile (2.1, il me semble) supporte aussi les formats Office 2007 et suivants.

Un tutoriel:

http://silkyroad.developpez.com/VBA/...etesClasseurs/

[kiki29]

Salut, à adapter à ton contexte, en affectant un bouton à la procédure "Test_MD5"

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
Option Explicit
 
Private Declare Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean
 
Sub Test_MD5()
Dim Debut As Currency, Fin As Currency, Freq As Currency
Dim sStr As String, sNom As String
 
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = ThisWorkbook.path & "\"
        .Title = "Sélection Fichier"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Fichier"
        .Show
        If .SelectedItems.Count > 0 Then
            Application.StatusBar = ""
            QueryPerformanceCounter Debut
            DoEvents
            sNom = .SelectedItems(1)
            sStr = FileToMD5Hex(.SelectedItems(1))
            QueryPerformanceCounter Fin
            QueryPerformanceFrequency Freq
            With Feuil1
                .Cells(1, 1) = sNom
                .Cells(1, 2) = sStr
                .Cells(1, 3) = Format((Fin - Debut) / Freq, "0.00 s")
            End With
        End If
    End With
    With Feuil1
        .Columns("A:C").AutoFit
        .Range("D1").Select
    End With
End Sub
 
Private Function FileToMD5Hex(sFileName As String) As String
Dim enc As Object
Dim bytes
Dim outStr As String
Dim pos As Long
    Set enc = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
    bytes = GetFileBytes(sFileName)
    bytes = enc.ComputeHash_2((bytes))
    For pos = 1 To LenB(bytes)
        outStr = outStr & LCase$(Right$("0" & Hex$(AscB(MidB$(bytes, pos, 1))), 2))
    Next
    FileToMD5Hex = outStr
    Set enc = Nothing
End Function
 
Private Function GetFileBytes(ByVal path As String) As Byte()
Dim lngFileNum As Long
Dim bytRtnVal() As Byte
    lngFileNum = FreeFile
    If LenB(Dir(path)) Then
        Open path For Binary Access Read As lngFileNum
            ReDim bytRtnVal(LOF(lngFileNum) - 1&) As Byte
            Get lngFileNum, , bytRtnVal
        Close lngFileNum
    Else
        Err.Raise 53
    End If
    GetFileBytes = bytRtnVal
    Erase bytRtnVal
End Function

[kiki29]

Salut, à adapter à ton contexte, en affectant un bouton à la procédure "Test_SHA1"

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
Option Explicit
 
Private Declare Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean
 
 
Sub Test_SHA1()
Dim Debut As Currency, Fin As Currency, Freq As Currency
Dim sStr As String, sNom As String
 
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = ThisWorkbook.path & "\"
        .Title = "Sélection Fichier"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Fichier"
        .Show
        If .SelectedItems.Count > 0 Then
            Application.StatusBar = ""
            QueryPerformanceCounter Debut
            DoEvents
            sNom = .SelectedItems(1)
            sStr = FileToSHA1Hex(.SelectedItems(1))
            QueryPerformanceCounter Fin
            QueryPerformanceFrequency Freq
            With Feuil1
                .Cells(1, 1) = sNom
                .Cells(1, 2) = sStr
                .Cells(1, 3) = Format((Fin - Debut) / Freq, "0.00 s")
            End With
        End If
    End With
    With Feuil1
        .Columns("A:C").AutoFit
        .Range("D1").Select
    End With
End Sub
 
Private Function FileToSHA1Hex(sFileName As String) As String
Dim enc As Object
Dim bytes
Dim outStr As String
Dim pos As Long
    Set enc = CreateObject("System.Security.Cryptography.SHA1CryptoServiceProvider")
    bytes = GetFileBytes(sFileName)
    bytes = enc.ComputeHash_2((bytes))
    For pos = 1 To LenB(bytes)
        outStr = outStr & LCase$(Right$("0" & Hex$(AscB(MidB$(bytes, pos, 1))), 2))
    Next
    FileToSHA1Hex = outStr
    Set enc = Nothing
End Function
 
Private Function GetFileBytes(ByVal path As String) As Byte()
Dim lngFileNum As Long
Dim bytRtnVal() As Byte
    lngFileNum = FreeFile
    If LenB(Dir(path)) Then
        Open path For Binary Access Read As lngFileNum
        ReDim bytRtnVal(LOF(lngFileNum) - 1&) As Byte
        Get lngFileNum, , bytRtnVal
        Close lngFileNum
    Else
        Err.Raise 53
    End If
    GetFileBytes = bytRtnVal
    Erase bytRtnVal
End Function