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 |
Chiffrement et déchiffrement de données VBA/VB6
Répondre avec citation
et le tout est lié au processus de chiffrement.
Partager