[XL-2010] Chiffrement et déchiffrement de données VBA/VB6

Bonjour le forum,

J'étais en train de préparer une contribution pour le forum concernant un suivi bancaire sur Excel et j'avous que je bloque un peu sur un problème de chiffrement.

Pour vous présentez le décor voici le modèle relationnel que j'ai conçu pour m'aider
Pièce jointe 437208

Vous pouvez voir que la feuille centrale est nommé FEC (Fichier des écritures comptable). En faite c'est un standard pour les entreprises en cas d'audit de la part de l'administration. Étant bien structuré, je n'aurais pas de mal à faire du reporting derrière et si un particulier se fait contrôler il pourra le donner. Afin de créer une sécurité des données, je me suis lancé dans l'idée de chiffrer/déchiffer les données.

Le problème est le suivant : J'ai des problèmes concernant le chiffrement de données via le cryptosystème Rinjdael (AES). Le vecteur est encodé sur 128 bits (16 bytes) et les block sur 128 (en output j'ai du 16 ou 32 bytes par blocs en général).

1 - Mais parfois j'ai des blocks non conforme (Inférieur à 16).
2 - Il arrive que le premier caractère soit ' et quand je souhaite déchiffrer Excel n'en tiens pas compte
3 - Je penses que j'ai un problème de conversion des bytes vers les caractères ASCII. (Fonction BytesToString)
4 - Parfois avec le bon vecteur cela marche nikel.

Pour illustrer voici une image des données en clair
Pièce jointe 437209

Et voici le résultat une fois chiffré. Si tous c'est bien passé chaque chaine de texte doit avoir une longueur modulo 16

Pièce jointe 437211

Voici le code du module Sécurité :

Code:

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
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
'************************************************************************************************************
' NAME : MSecurity (MODULE)
' AUTHOR : John Mc Evee
' VERSION : 1.0
' DATE : 27/12/2018
' DESCRIPTION : Le module permet de se connecter et de dévérouiller les données grâce à un logging et un
' mot de passe. Avant de fermer le classeur, le processus va chiffrer les données afin de proteger les
' données contre une lecture par le mapping xml
' NOTE : Utilisation du hash SHA256 pour le mot de passe
'        Utilisation du cryptosystème Rinjdael pour le chiffrement et déchiffrement avec une clé de 128 bits
' et des blocs de 256 bits.
' L'application ne fonctionne que pour un seul identifiant car si l'on crée un nouvel identifiant et que
' les données sont chiffrés, il est impossible de les déchiffer sans avoir le mot de passe du dernier
' idenfiant connecté.
'************************************************************************************************************
Option Explicit
Option Base 0
 
'************************************************************************************************************
'                                            Variable privée
'************************************************************************************************************
Private oSheetData   As Excel.Worksheet     'Feuille contenant les données d'environement
Private oSheetFEC    As Excel.Worksheet     'Feuille contenant les données du FEC
Private oRangeData   As Excel.Range         'Plage contenant les données
Private oCellData    As Excel.Range         'Cellule Active
Private oCrypto      As VBA.Collection      'Contient les données chiffrés, la clé et l'IV
Private RMCrypto     As Object              'Object Rinjdael AES
Private SHA256       As Object              'Object SHA256
Private sData        As String              'Donnée en chaine de texte
Private sKey         As String              'Clé en chaine de texte
Private sIV          As String              'Vecteur d'initialisation en chaine de texte
Private sHash        As String              'Hash du mot de passe
Private lLastColumn  As Long                'Dernière colonne
Private lFirstColumn As Long                'Première colonne
Private lLastRow     As Long                'Dernière ligne
Private lFirstRow    As Long                'Première ligne
Private bPassword()  As Byte                'Byte du mot de passe
Private bData()      As Byte                'Donnée à chiffrer/Déchiffrer
Private bKey()       As Byte                'Clé de chiffrement/Déchiffrement
Private bIV()        As Byte                'Vecteur d'initialisation
 
'************************************************************************************************************
'                                               Public Methode
'************************************************************************************************************
 
'************************************************************************************************************
' NAME : Authentification (FUNCTION)
' INPUT : sUsername (String), sPassword (String)
' OUTPUT : True/False (Boolean)
' DESCRIPTION : Vérifie que l'utilisateur a saisi le bon mot de passe et dechiffre les données à l'aide du
' mot de passe et du vecteur d'initialisation du précédent chiffrement.
'************************************************************************************************************
Public Function Authentification(sUsername As String, sPassword As String) As Boolean
 
    Authentification = False 'Initialisation de la fonction
 
    Set oSheetData = ThisWorkbook.Worksheets("Environ")
 
    If oSheetData Is Nothing Then InfoUtilisateur _
    "La feuille Environ est introuvable", "Authentification", VBA.vbCritical
 
    With oSheetData
 
        'On set la colonne contenant les identifiants
        Set oRangeData = SetRange(oSheetData, 1, .Rows.Count, 1, 1)
 
        'On récupère le hash du mot de passe
        sHash = "ƒ]mÈ‹p‹ÆFÖÛ‚ÈSïA‚ú»Ô¨ÞYÂòµ«:çÙ¾"
        'sHash = oRangeData.Find(sUsername).Offset(0, 1).Value
        bPassword = StringToBytes(sPassword)
 
        'Si le Hash n'existe pas
        If sHash = VBA.vbNullString Then
 
            Authentification = False
            InfoUtilisateur "Identifiant non créé", "Authentification", VBA.vbCritical
 
        'Si le mot de passe est le bon
        ElseIf HashSHA256(bPassword) = sHash Then
 
            'Si l'utilisateur utilise le chiffrement
            If CBool(oRangeData.Find(sUsername).Offset(0, 5).Value) Then
 
                '********************************************************************************************
                'Déchiffrement de la feuille FEC
                '********************************************************************************************
                Set oSheetFEC = ThisWorkbook.Worksheets("FEC")
 
                If oSheetData Is Nothing Then
                    InfoUtilisateur "La feuille FEC est introuvable", "Authentification", VBA.vbCritical
                    Exit Function
                End If
 
                With oSheetFEC
 
                    'Fixe des dimensions
                    lFirstRow = 1
                    lLastRow = EndOf(oSheetFEC, .Rows.Count, 1, xlUp).Row
                    lFirstColumn = 1
                    lLastColumn = EndOf(oSheetFEC, 1, .Columns.Count, xlToLeft).Column
 
                    'Initialisation de la clé et du vecteur d'initialisation
                    bKey = StringToBytes(HashSHA256(StringToBytes(sUsername & sPassword)))
                    bIV = StringToBytes(oRangeData.Find(sUsername).Offset(0, 4).Value)
 
                    'Boucle sur les données du FEC
                    For Each oCellData In SetRange(oSheetFEC, lFirstRow, lLastRow, lFirstColumn, lLastColumn)
 
                        'On évite les cellules vide
                        If oCellData.Value <> VBA.vbNullString Then
 
                            'On converti les données
                            VBA.DoEvents
                            bData = StringToBytes(CStr(oCellData.Value))
                            Set oCrypto = Decryption(bData, bKey, bIV)
                            'On inscrit les données déchiffrer
                            oCellData.Value = BytesToString(oCrypto("Data"))
                            VBA.DoEvents
 
                        End If
 
                    Next oCellData
 
                End With
 
                Erase bData 'Vidange
                Erase bIV
                Erase bKey
                Set oCrypto = Nothing
 
            End If
 
            Authentification = True
 
        Else 'Si le mot de passe n'est pas le bon
 
            Authentification = False
            InfoUtilisateur "Mot de passe incorrect", "Authentification", VBA.vbCritical
 
        End If
 
        Set oRangeData = Nothing
 
    End With
 
    Set oSheetData = Nothing
 
End Function
 
'************************************************************************************************************
' NAME : Deconnexion (FUNCTION)
' INPUT : sUsername(String), bChiffrement (Boolean)
' OUTPUT : True/False (Boolean)
' DESCRIPTION : Chiffre les données du FEC avant la déconnexion du classeur si bChiffrement est à true
'************************************************************************************************************
Public Function Deconnexion(sUsername As String, sPassword As String, bChiffrement As Boolean) As Boolean
 
    ThisWorkbook.Save
 
    If bChiffrement Then
 
        Set oSheetData = ThisWorkbook.Worksheets("Environ")
 
        If oSheetData Is Nothing Then InfoUtilisateur _
        "La feuille Environ est introuvable", "Authentification", VBA.vbCritical
 
        With oSheetData
 
            'On set la colonne contenant les identifiants
            Set oRangeData = SetRange(oSheetData, 1, .Rows.Count, 1, 1)
            'Initialisation de la clé et du vecteur d'initialisation
 
            bKey = StringToBytes(HashSHA256(StringToBytes(sUsername & sPassword)))
            'On supprime l'IV
            oRangeData.Find(sUsername).Offset(0, 4).ClearContents
 
            'On génére un nouvel IV
            VBA.DoEvents
 
            bData = StringToBytes("Test")
            Set oCrypto = Encryption(bData, bKey)
            bIV = oCrypto("IV")
 
            sIV = BytesToString(oCrypto("IV"))
            oRangeData.Find(sUsername).Offset(0, 4).Value = sIV
            VBA.DoEvents
 
            '****************************************************************************************************
            ' Début du chiffrement
            '****************************************************************************************************
            Set oSheetFEC = ThisWorkbook.Worksheets("FEC")
 
            If oSheetData Is Nothing Then
                InfoUtilisateur "La feuille FEC est introuvable", "Authentification", VBA.vbCritical
                Exit Function
            End If
 
            With oSheetFEC
 
                'Fixe des dimensions
                lFirstRow = 1
                lLastRow = EndOf(oSheetFEC, .Rows.Count, 1, xlUp).Row
                lFirstColumn = 1
                lLastColumn = EndOf(oSheetFEC, 1, .Columns.Count, xlToLeft).Column
 
                'Boucle sur les données du FEC
                For Each oCellData In SetRange(oSheetFEC, lFirstRow, lLastRow, lFirstColumn, lLastColumn)
                     'On évite les cellules vide
                    If oCellData.Value <> VBA.vbNullString Then
 
                        'On converti les données
                        bData = StringToBytes(CStr(oCellData.Value))
                        Set oCrypto = Encryption(bData, bKey, bIV)
                        'On inscrit les données déchiffrer
                        oCellData.Value = BytesToString(oCrypto("Data"))
                        VBA.DoEvents
 
                    End If
 
                Next oCellData
 
            End With
 
        End With
 
    End If
 
    Deconnexion = True
 
End Function
 
'************************************************************************************************************
'                                               Private Methode
'************************************************************************************************************
 
'************************************************************************************************************
' NAME : Decryption (FUNCTION)
' INPUT : dData (Byte), bKey (Byte), bIV (Byte)
' OUTPUT : ClearText (Byte)
' DESCRIPTION : Return a clear text with key and initialisation vector
'************************************************************************************************************
Private Function Decryption(bData() As Byte, bKey() As Byte, bIV() As Byte) As VBA.Collection
 
    Dim bClearData() As Byte
    Dim Decode As Object
    Set Decryption = New VBA.Collection
    Set RMCrypto = VBA.CreateObject("System.Security.Cryptography.RijndaelManaged")
 
    With RMCrypto
 
        .KeySize = 256
        .BlockSize = 128
        .Mode = 1 'CBC
        .Key = bKey
        .IV = bIV
 
        VBA.DoEvents
        Set Decode = .CreateDecryptor()
        bClearData = Decode.TransformFinalBlock((bData), 0, VBA.LenB(bData))
 
        Decryption.Add bClearData, "Data"
        Decryption.Add .Key, "Key"
        Decryption.Add .IV, "IV"
 
    End With
 
    Set RMCrypto = Nothing
 
End Function
 
'************************************************************************************************************
' NAME : Encryption (FUNCTION)
' INPUT : dData (Byte)
' OUTPUT : sKey (String), sIV(String), CipherData (Byte)
' DESCRIPTION : Return a cipher text with key and initialisation vector
'************************************************************************************************************
Private Function Encryption(ByRef bData() As Byte, Optional bKey As Variant = Empty, _
                                                   Optional bIV As Variant = Empty) As VBA.Collection
 
    Dim bCipherData() As Byte
    Dim Encode        As Object
 
    Set Encryption = New VBA.Collection
 
    Set RMCrypto = VBA.CreateObject("System.Security.Cryptography.RijndaelManaged")
 
    With RMCrypto
 
        .KeySize = 256
        .BlockSize = 128
        .Mode = 1 'CBC
 
        Select Case VBA.VarType(bKey)
            Case VBA.vbArray + VBA.vbByte
                .Key = bKey
            Case VBA.vbEmpty
                .GenerateKey
        End Select
 
        Select Case VBA.VarType(bIV)
            Case VBA.vbArray + VBA.vbByte
                .IV = bIV
            Case VBA.vbEmpty
 
                Do
                .GenerateIV
                Loop While UBound(.IV) <> 15 '---> Pour forcer la bonne longueur de l'IV
 
        End Select
 
        VBA.DoEvents
        Set Encode = .CreateEncryptor()
 
        Do
 
            bCipherData = Encode.TransformFinalBlock((bData), 0, VBA.LenB(bData))
 
        Loop While UBound(bCipherData) < 15 '---> Pour éviter les mauvais blocks (Inf à 128 bits)
 
        Set Encode = Nothing
 
        Encryption.Add bCipherData, "Data"
        Encryption.Add .Key, "Key"
        Encryption.Add .IV, "IV"
 
    End With
 
    Erase bCipherData
 
    Set RMCrypto = Nothing
 
End Function
 
'************************************************************************************************************
' NAME : HashSHA256
' INPUT : TextBytes (Byte Array)
' OUTPUT : sHash (String)
' DESCRIPTION : Calculate hash of SHA256 algorithm
'************************************************************************************************************
Private Function HashSHA256(TextBytes() As Byte) As String
 
    Dim sHash As String
    Dim CipherHash() As Byte
 
    Set SHA256 = VBA.CreateObject("System.Security.Cryptography.SHA256Managed")
 
    With SHA256
        .Initialize
        CipherHash = .ComputeHash_2((TextBytes))
    End With
 
    Set SHA256 = Nothing
 
    HashSHA256 = BytesToString(CipherHash)
 
End Function
 
'************************************************************************************************************
' NAME : StringToBytes (FUNCTION)
' INPUT : sData (String)
' OUTPUT : Byte Array
' DESCRIPTION : Converti une chaine de texte en byte
'************************************************************************************************************
Private Function StringToBytes(sData As String) As Byte()
 
    StringToBytes = VBA.StrConv(sData, VBA.vbFromUnicode)
    VBA.DoEvents
 
End Function
 
'************************************************************************************************************
' NAME : BytesToString (FUNCTION)
' INPUT : dData (Byte)
' OUTPUT : String
' DESCRIPTION : Converti une chaine de byte en string (Code ASCII)
'************************************************************************************************************
Private Function BytesToString(bData() As Byte) As String
 
    BytesToString = VBA.StrConv(bData, VBA.vbUnicode)
    VBA.DoEvents
 
End Function

Pour les fonctions Standard :

Code:

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
'************************************************************************************************************
' NAME : MFunction (MODULE)
' DESCRIPTION : Module contenant des functions standards et utilié dans les différents modules
'************************************************************************************************************
Option Explicit
 
'************************************************************************************************************
' NAME : EndOf (FUNCTION)
' INPUT : oSheetData (Worksheet), lRow (Long), lColumn (Long), eDirection (XlDirection), sType(String)
' OUTPUT : EndOf (Range)
' DESCRIPTION : Retourne la cellule spécifié par l'énumération en partant des coordonnées (lRow, lColumn)
' NOTE : Pour récupérer le numéro de colonne (EndOf.column)
'************************************************************************************************************
Public Function EndOf(oSheetData As Excel.Worksheet, lRow As Long, lColumn As Long, _
                      eDirection As XlDirection) As Excel.Range
 
    Set EndOf = oSheetData.Cells(lRow, lColumn).End(eDirection)
 
End Function
 
'************************************************************************************************************
' NAME : Apps (PROCESS)
' INPUT : bStart (Boolean)
' DESCRIPTION : Désactive/Active des paramètres par défaut de l'application afin de gagner en efficacité
'************************************************************************************************************
Public Sub Apps(bStart As Boolean)
 
    With Application
 
        If bStart Then
            .ScreenUpdating = False
        Else
            .ScreenUpdating = True
        End If
 
    End With
 
End Sub
'************************************************************************************************************
' NAME : SetRange
' INPUT : lFirstRow (long), lLastRow (Long), LFirstColumn (Long), lLastColumn (Long)
' DESCRIPTION : Set une range en fonction de 4 points de coordonées
'************************************************************************************************************
Public Function SetRange(oSheetData As Excel.Worksheet, lFirstRow As Long, lLastRow As Long, _
                         lFirstColumn As Long, lLastColumn As Long) As Excel.Range
    With oSheetData
        Set SetRange = .Range(.Cells(lFirstRow, lFirstColumn), .Cells(lLastRow, lLastColumn))
    End With
 
End Function
 
'************************************************************************************************************
' NAME : InfoUtilisateur
' INPUT : sInfo (String), sProcess(String), eBox (VbMsgBoxResult)
' DESCRIPTION : Renvoi un message d'erreur à l'utilisateur
'************************************************************************************************************
Public Sub InfoUtilisateur(sInfo As String, sProcess As String, eBox As VbMsgBoxResult)
 
    VBA.MsgBox sInfo & VBA.vbNewLine & sProcess, eBox
 
End Sub

Enfin voici une image de la table Environ pour faire le lien avec les données récupérer par le module
Pièce jointe 437213

N'hésitez pas si j'ai manqué de précision et si vous souhaitez que je mettes à disposition un fichier de Test.

Je vous remercie par avance de votre aide.

A+

Bonjour à tous,

Après avoir chercher pendant au moins 3h, j'ai trouvé les solutions à mes problèmes.

En faite c'était plutôt logique :D et le tout est lié au processus de chiffrement.

Problème 1 : L'algorithme générait en sortie des blocs de données de taille non conforme.
Solution 1 : Le problème venait du caractère 0 de la Table ASCII (Null). Lorsqu'on le colle dans une cellule, le déchiffrement est impossible par la suite. Pour le résoudre, j'ai crée une fonction de contrôle pour inspecter les blocs et si il trouve ce caractère, il régénère une nouvelle pair Clé/Vecteur et recommence le travail. A voir si cette solution est pérenne avec un très grand nombre de données mais pour ce que je veux faire cela suffira.

Problème 2 : Les cellules Excel n'accepte pas les caractère = ou ' en première position.
Solution 2 : Pour palier à ce problème, je rajoute le caractère " devant chaque chaine de texte chiffrée et je n'en tiens pas compte lors du déchiffrement.

Problème 3 : Le vecteur d'initialisation (IV) doit respecter les deux contraintes précédentes.
Solution : J'ai créer une fonction GenerateIV qui incrémente les deux exceptions précédentes.

Cependant, si les cellules contiennent des données identiques, le résultat de sortie sera identique donc la cryptanalyse est grandement facilité. Le temps de déchiffrement ne dépendra que de la solidité de vos mots de passe à une attaque par force brute.

Voici le code du module complet et corrigé des fautes précédentes. En espérant que cela profite à d'autre.

Code:

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
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
'************************************************************************************************************
' NAME : MSecurity (MODULE)
' AUTHOR : John Mc Evee
' VERSION : 1.0
' DATE : 29/12/2018
' DESCRIPTION : Le module permet de se connecter et de dévérouiller les données grâce à un logging et un
' mot de passe. Avant de fermer le classeur, le processus va chiffrer les données afin de proteger les
' données contre une lecture par le mapping xml
' La clé de chiffrement est le hash (SHA256) de la concaténation du Username et du Password
'
' NOTE : Utilisation du hash SHA256 pour le mot de passe
'        Utilisation du cryptosystème Rinjdael pour le chiffrement et déchiffrement avec une clé de 256 bits
' et des blocs de 128 bits.
' L'application ne fonctionne que pour un seul identifiant car si l'on crée un nouvel identifiant et que
' les données sont chiffrés, il est impossible de les déchiffrer sans avoir le mot de passe du dernier
' idenfiant connecté.
'
' EXCEPTION : Le processus de chiffrement élimine toutes données chiffrés contenant le caractère Null
' (Ascii 0) car ce caractère est impossible à déchiffrer. Pour tenir compte des spécificités des cellules
' Excel les données ne peuvent commencées par = ou '. Pour contrecarrer ces problèmes on rajoute le
' caractère " devant toutes les entrées de valeur. Quand à l'IV, il ne peut commencer par ces caractères
' Avec ces contraintes de conformité le processus de chiffrement va chercher un vecteur d'initialisation
' tel qu'avec la clé et l'ensemble des données évite les exceptions ci-dessus.
'************************************************************************************************************
Option Explicit
Option Base 0
 
'************************************************************************************************************
'                                            Variable privée
'************************************************************************************************************
Private oSheetData   As Excel.Worksheet     'Feuille contenant les données d'environement
Private oSheetFEC    As Excel.Worksheet     'Feuille contenant les données du FEC
Private oRangeData   As Excel.Range         'Plage contenant les données
Private oCellData    As Excel.Range         'Cellule Active
Private oCrypto      As VBA.Collection      'Contient les données chiffrés, la clé et l'IV
Private RMCrypto     As Object              'Object Rinjdael AES
Private SHA256       As Object              'Object SHA256
Private vData()      As Variant             'Tableau contenant les données chiffrées
Private sUsername    As String              'Identifiant de l'utilisateur
Private sPassword    As String              'Mot de passe de l'utilisateur
Private sData        As String              'Donnée en chaine de texte
Private sKey         As String              'Clé en chaine de texte
Private sIV          As String              'Vecteur d'initialisation en chaine de texte
Private sHash        As String              'Hash du mot de passe
Private lLastColumn  As Long                'Dernière colonne
Private lFirstColumn As Long                'Première colonne
Private lColumn      As Long                'Compteur de colonne
Private lLastRow     As Long                'Dernière ligne
Private lFirstRow    As Long                'Première ligne
Private lRow         As Long                'Compteur de ligne
Private lBuffer      As Long                'Compteur de 3ème boucle
Private bPassword()  As Byte                'Byte du mot de passe
Private bData()      As Byte                'Donnée à chiffrer/Déchiffrer
Private bKey()       As Byte                'Clé de chiffrement/Déchiffrement
Private bIV()        As Byte                'Vecteur d'initialisation
 
'************************************************************************************************************
'                                               Public Methode
'************************************************************************************************************
 
'************************************************************************************************************
' NAME : Authentification (FUNCTION)
' INPUT : sUsername (String), sPassword (String)
' OUTPUT : True/False (Boolean)
' DESCRIPTION : Vérifie que l'utilisateur a saisi le bon mot de passe et dechiffre les données à l'aide du
' mot de passe et du vecteur d'initialisation du précédent chiffrement.
'************************************************************************************************************
Public Function Authentification(sUsername As String, sPassword As String) As Boolean
 
    Authentification = False 'Initialisation de la fonction
 
    Set oSheetData = ThisWorkbook.Worksheets("Environ")
 
    If oSheetData Is Nothing Then InfoUtilisateur _
    "La feuille Environ est introuvable", "Authentification", VBA.vbCritical
 
    With oSheetData
 
        'On set la colonne contenant les identifiants
        Set oRangeData = SetRange(oSheetData, 1, .Rows.Count, 1, 1)
 
        'On récupère le hash du mot de passe
        sHash = oRangeData.Find(sUsername).Offset(0, 1).Value
        bPassword = StringToBytes(sPassword)
 
        'Si le Hash n'existe pas
        If sHash = VBA.vbNullString Then
 
            Authentification = False
            InfoUtilisateur "Identifiant non créé", "Authentification", VBA.vbCritical
 
        'Si le mot de passe est le bon
        ElseIf HashSHA256(bPassword) = sHash Then
 
            'Si l'utilisateur utilise le chiffrement
            If CBool(oRangeData.Find(sUsername).Offset(0, 5).Value) Then
 
                '********************************************************************************************
                'Déchiffrement de la feuille FEC
                '********************************************************************************************
                Set oSheetFEC = ThisWorkbook.Worksheets("FEC")
 
                If oSheetFEC Is Nothing Then
                    InfoUtilisateur "La feuille FEC est introuvable", "Authentification", VBA.vbCritical
                    Exit Function
                End If
 
                With oSheetFEC
 
                    'Fixe des dimensions
                    lFirstRow = 1
                    lLastRow = EndOf(oSheetFEC, .Rows.Count, 1, xlUp).Row
                    lFirstColumn = 1
                    lLastColumn = EndOf(oSheetFEC, 1, .Columns.Count, xlToLeft).Column
 
                    'Initialisation de la clé et du vecteur d'initialisation
                    bKey = StringToBytes(HashSHA256(StringToBytes(sUsername & sPassword)))
                    bIV = StringToBytes(oRangeData.Find(sUsername).Offset(0, 4).Value)
 
                    'Boucle sur les données du FEC
                    For Each oCellData In SetRange(oSheetFEC, lFirstRow, lLastRow, lFirstColumn, lLastColumn)
 
                        'On évite les cellules vide
                        If oCellData.Value <> VBA.vbNullString Then
 
                            'On converti les données
                            VBA.DoEvents
                            bData = StringToBytes(CStr(VBA.Right$(oCellData.Value, VBA.Len(oCellData.Value) - 1)))
                            Set oCrypto = Decryption(bData, bKey, bIV)
                            'On inscrit les données déchiffrer
                            oCellData.Value = BytesToString(oCrypto("Data"))
                            VBA.DoEvents
 
                        End If
 
                    Next oCellData
 
                End With
 
                Erase bData 'Vidange
                Erase bIV
                Erase bKey
                Set oCrypto = Nothing
 
            End If
 
            Authentification = True
 
        Else 'Si le mot de passe n'est pas le bon
 
            Authentification = False
            InfoUtilisateur "Mot de passe incorrect", "Authentification", VBA.vbCritical
 
        End If
 
        Set oRangeData = Nothing
 
    End With
 
    Set oSheetData = Nothing
 
End Function
 
'************************************************************************************************************
' NAME : Deconnexion (FUNCTION)
' INPUT : sUsername(String), bChiffrement (Boolean)
' OUTPUT : True/False (Boolean)
' DESCRIPTION : Chiffre les données du FEC avant la déconnexion du classeur si bChiffrement est à true
'************************************************************************************************************
Public Function Deconnexion(sUsername As String, sPassword As String, bChiffrement As Boolean) As Boolean
 
    If bChiffrement Then
 
        Set oSheetData = ThisWorkbook.Worksheets("Environ")
 
        If oSheetData Is Nothing Then
            InfoUtilisateur "La feuille Environ est introuvable", "Authentification", VBA.vbCritical
            Exit Function
        End If
 
        With oSheetData
 
            'On set la colonne contenant les identifiants
            Set oRangeData = SetRange(oSheetData, 1, .Rows.Count, 1, 1)
 
            'Initialisation de la clé et du vecteur d'initialisation
            bKey = StringToBytes(HashSHA256(StringToBytes(sUsername & sPassword)))
            sIV = oRangeData.Find(sUsername).Offset(0, 4).Value
 
            'Si l'IV est Vide on lance la procédure de création et de checking
            If sIV = VBA.vbNullString Then
                bIV = GenerateIV(sUsername, sPassword)
                sIV = BytesToString(bIV)
                oRangeData.Find(sUsername).Offset(0, 4).Value = sIV
            Else
                bIV = StringToBytes(sIV)
            End If
 
            '****************************************************************************************************
            ' Début du chiffrement
            '****************************************************************************************************
            Set oSheetFEC = ThisWorkbook.Worksheets("FEC")
 
            If oSheetFEC Is Nothing Then
                InfoUtilisateur "La feuille FEC est introuvable", "Authentification", VBA.vbCritical
                Exit Function
            End If
 
            With oSheetFEC
 
                'Fixe des dimensions
                lFirstRow = 1
                lLastRow = EndOf(oSheetFEC, .Rows.Count, 1, xlUp).Row
                lFirstColumn = 1
                lLastColumn = EndOf(oSheetFEC, 1, .Columns.Count, xlToLeft).Column
 
                'Boucle sur les données du FEC
                vData = SetRange(oSheetFEC, lFirstRow, lLastRow, lFirstColumn, lLastColumn)
                For lRow = LBound(vData, 1) To UBound(vData, 1) Step 1
 
                    For lColumn = LBound(vData, 2) To UBound(vData, 2) Step 1
 
                         'On évite les cellules vide
                        If vData(lRow, lColumn) <> VBA.vbNullString Then
 
                            'On converti les données
                            bData = StringToBytes(CStr(vData(lRow, lColumn)))
                            Set oCrypto = Encryption(bData, bKey, bIV)
 
                            'Si les données n'ont pas de caractère null chr(0)
                            If CheckData(oCrypto("Data")) Then
                                'On inscrit les données déchiffrer en commencant par "
                                vData(lRow, lColumn) = VBA.Chr$(34) & CStr(BytesToString(oCrypto("Data")))
                                VBA.DoEvents
                            Else
 
                                'Suppression du début de travail & éffacement de l'IV précédent
                                Erase vData
                                oRangeData.Find(sUsername).Offset(0, 4).ClearContents
 
                                'On recommance le processus jusqu'a obtenir la bonne combinaison
                                If Deconnexion(sUsername, sPassword, bChiffrement) Then
                                    Deconnexion = True
                                    Exit Function
                                End If
 
                            End If
 
                        End If
 
                    Next lColumn
 
                Next lRow
 
                'On colle les données
                .Range("A1").Resize(UBound(vData, 1), UBound(vData, 2)) = vData
 
            End With
 
            Set oSheetFEC = Nothing
 
        End With
 
    End If
 
    Set oSheetData = Nothing
    ThisWorkbook.Save
    Deconnexion = True
 
End Function
 
'************************************************************************************************************
'                                               Private Methode
'************************************************************************************************************
 
'************************************************************************************************************
' NAME : StringToBytes (FUNCTION)
' INPUT : sData (String)
' OUTPUT : Byte Array
' DESCRIPTION : Converti une chaine de texte en byte
'************************************************************************************************************
Private Function StringToBytes(sData As String) As Byte()
 
    StringToBytes = VBA.StrConv(sData, VBA.vbFromUnicode)
 
End Function
 
'************************************************************************************************************
' NAME : BytesToString (FUNCTION)
' INPUT : dData (Byte)
' OUTPUT : String
' DESCRIPTION : Converti une chaine de byte en string (Code ASCII)
'************************************************************************************************************
Private Function BytesToString(bData() As Byte) As String
 
    BytesToString = VBA.StrConv(bData, VBA.vbUnicode)
 
End Function
 
'************************************************************************************************************
' NAME : Decryption (FUNCTION)
' INPUT : dData (Byte), bKey (Byte), bIV (Byte)
' OUTPUT : bKey (byte), bIV(byte), bClearData (Byte)
' DESCRIPTION : retourne une collection avec le texte claire, la clé de déchiffrement et l'IV
'************************************************************************************************************
Private Function Decryption(bData() As Byte, bKey() As Byte, bIV() As Byte) As VBA.Collection
 
    Dim bClearData() As Byte
    Dim Decode As Object
 
    Set Decryption = New VBA.Collection
    Set RMCrypto = VBA.CreateObject("System.Security.Cryptography.RijndaelManaged")
 
    With RMCrypto
 
        'Paramètre de l'algorithyme
        .KeySize = 256
        .BlockSize = 128
        .Mode = 1 'CBC
        .Key = bKey
        .IV = bIV
 
        Set Decode = .CreateDecryptor()
        'On décode le
        bClearData = Decode.TransformFinalBlock((bData), 0, VBA.LenB(bData))
 
        Decryption.Add bClearData, "Data"
        Decryption.Add .Key, "Key"
        Decryption.Add .IV, "IV"
 
    End With
 
    Erase bClearData
    Set RMCrypto = Nothing
 
End Function
 
'************************************************************************************************************
' NAME : Encryption (FUNCTION)
' INPUT : dData (Byte), sIV(byte), sKey (Byte)
' OUTPUT : bKey (byte), bIV(byte), bCipherData (Byte)
' DESCRIPTION : retourne une collection le texte chiffré, la clé de chiffrement et l'IV
'************************************************************************************************************
Private Function Encryption(ByRef bData() As Byte, Optional bKey As Variant, Optional bIV As Variant) As VBA.Collection
 
    Dim bCipherData() As Byte
    Dim Encode        As Object
 
    Set Encryption = New VBA.Collection
    Set RMCrypto = VBA.CreateObject("System.Security.Cryptography.RijndaelManaged")
 
    With RMCrypto
 
        'Paramètres de l'algorithme
        .KeySize = 256
        .BlockSize = 128
        .Mode = 1 'CBC
 
        'Incrémentation de la clé
        If VBA.VarType(bKey) = (VBA.vbArray + VBA.vbByte) Then
            .Key = bKey
        Else
            .GenerateKey
        End If
 
        'Incrémentation du vecteur d'initialisation
        If VBA.VarType(bIV) = (VBA.vbArray + VBA.vbByte) Then
            .IV = bIV
        Else
            .GenerateIV
        End If
 
        Set Encode = .CreateEncryptor()
        VBA.DoEvents
        bCipherData = Encode.TransformFinalBlock((bData), 0, VBA.LenB(bData))
 
        Set Encode = Nothing
 
        Encryption.Add bCipherData, "Data"
        Encryption.Add .Key, "Key"
        Encryption.Add .IV, "IV"
 
    End With
 
    Erase bCipherData
 
    Set RMCrypto = Nothing
 
End Function
 
'************************************************************************************************************
' NAME : HashSHA256
' INPUT : TextBytes (Byte Array)
' OUTPUT : sHash (String)
' DESCRIPTION : Calculate hash of SHA256 algorithm
'************************************************************************************************************
Private Function HashSHA256(TextBytes() As Byte) As String
 
    Dim CipherHash() As Byte
 
    Set SHA256 = VBA.CreateObject("System.Security.Cryptography.SHA256Managed")
 
    With SHA256
        .Initialize
        CipherHash = .ComputeHash_2((TextBytes))
    End With
 
    Set SHA256 = Nothing
 
    HashSHA256 = BytesToString(CipherHash)
 
End Function
 
'************************************************************************************************************
' NAME : GenerateIV
' INPUT : sUsername (String), sPassword (String)
' OUTPUT : bIV (Byte Array)
' DESCRIPTION : Calcule un IV correct pour la éviter la génération. On génère un tableau préalable puis
' on le chiffre et on le déchiffre pour voir si le résultat est correct
'************************************************************************************************************
Private Function GenerateIV(sUsername As String, sPassword As String) As Byte()
 
    On Error Resume Next
 
    Dim bResult      As Boolean
 
    'Génération de la clé
    bKey = StringToBytes(HashSHA256(StringToBytes(sUsername & sPassword)))
 
    Do 'Tant que l'IV ne respecte pas les contraintes
 
        bResult = True
 
        'On génère un nouvel IV
        bData = StringToBytes("Test")
        Set oCrypto = Encryption(bData, bKey)
 
        'On annule les caractères interdit dans une cellule
        If oCrypto("IV")(0) = VBA.AscB("=") Or oCrypto("IV")(0) = VBA.AscB("'") Then bResult = False
 
        'On annule si un des caractères est Null (Chr(0))
        If Not CheckData(oCrypto("IV")) Then bResult = False
 
        If bResult And VBA.Err.Number = 0 And UBound(oCrypto("IV")) = 15 Then
            GenerateIV = oCrypto("IV")
            Exit Function
        Else
            VBA.Err.Clear
        End If
 
        Set oCrypto = Nothing
 
    Loop
 
End Function
 
'************************************************************************************************************
' NAME : CheckData (FUNCTION)
' INPUT : sData (Byte Array)
' OUTPUT : True/False
' DESCRIPTION : Vérifie que la chaine de byte ne comporte pas de caractère null VBA.Chr(0)
'************************************************************************************************************
Private Function CheckData(bData() As Byte) As Boolean
 
    CheckData = True
 
    For lBuffer = LBound(bData) To UBound(bData) Step 1
        If bData(lBuffer) = 0 Then CheckData = False
    Next lBuffer
 
End Function

Avec les fonctions standard

Code:

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
'************************************************************************************************************
' NAME : MFunction (MODULE)
' DESCRIPTION : Module contenant des functions standards et utilié dans les différents modules
'************************************************************************************************************
Option Explicit
 
'************************************************************************************************************
' NAME : EndOf (FUNCTION)
' INPUT : oSheetData (Worksheet), lRow (Long), lColumn (Long), eDirection (XlDirection), sType(String)
' OUTPUT : EndOf (Range)
' DESCRIPTION : Retourne la cellule spécifié par l'énumération en partant des coordonnées (lRow, lColumn)
' NOTE : Pour récupérer le numéro de colonne (EndOf.column)
'************************************************************************************************************
Public Function EndOf(oSheetData As Excel.Worksheet, lRow As Long, lColumn As Long, _
                      eDirection As XlDirection) As Excel.Range
 
    Set EndOf = oSheetData.Cells(lRow, lColumn).End(eDirection)
 
End Function
 
'************************************************************************************************************
' NAME : Apps (PROCESS)
' INPUT : bStart (Boolean)
' DESCRIPTION : Désactive/Active des paramètres par défaut de l'application afin de gagner en efficacité
'************************************************************************************************************
Public Sub Apps(bStart As Boolean)
 
    With Application
 
        If bStart Then
            .ScreenUpdating = False
        Else
            .ScreenUpdating = True
        End If
 
    End With
 
End Sub
'************************************************************************************************************
' NAME : SetRange
' INPUT : lFirstRow (long), lLastRow (Long), LFirstColumn (Long), lLastColumn (Long)
' DESCRIPTION : Set une range en fonction de 4 points de coordonées
'************************************************************************************************************
Public Function SetRange(oSheetData As Excel.Worksheet, lFirstRow As Long, lLastRow As Long, _
                         lFirstColumn As Long, lLastColumn As Long) As Excel.Range
    With oSheetData
        Set SetRange = .Range(.Cells(lFirstRow, lFirstColumn), .Cells(lLastRow, lLastColumn))
    End With
 
End Function
 
'************************************************************************************************************
' NAME : InfoUtilisateur
' INPUT : sInfo (String), sProcess(String), eBox (VbMsgBoxResult)
' DESCRIPTION : Renvoi un message d'erreur à l'utilisateur
'************************************************************************************************************
Public Function InfoUtilisateur(sInfo As String, sProcess As String, eBox As VbMsgBoxStyle) As VbMsgBoxResult
 
   InfoUtilisateur = VBA.MsgBox(sInfo & VBA.vbNewLine & sProcess, eBox)
 
End Function

A+