[VBA Excel Word]Adapter un code Excel a Word
Voila mon code pour crypter un fichier excel
Module de classe Crypt
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
| Private mvarTexte As String 'copie locale
Public Enum TypeOperation
Cryptage = 0
Decryptage = 1
End Enum
Private mvarTypeWork As TypeOperation 'copie locale
Private mvarMotCle As String 'copie locale
Public Property Let MotCle(ByVal vData As String)
mvarMotCle = vData
End Property
Public Property Get MotCle() As String
MotCle = mvarMotCle
End Property
Public Property Let TypeWork(ByVal vData As TypeOperation)
mvarTypeWork = vData
End Property
Public Property Get TypeWork() As TypeOperation
TypeWork = mvarTypeWork
End Property
Public Function ReturnValue() As String
Dim TxtWork As String
Select Case mvarTypeWork
Case 0 'Crytage
TxtWork = CryptageTxt
Case 1 'Decryptage
TxtWork = DecryptageTxt
End Select
ReturnValue = TxtWork
End Function
Public Property Let Texte(ByVal vData As String)
mvarTexte = vData
End Property
Public Property Get Texte() As String
Texte = mvarTexte
End Property
'----------------------------------------------------------------------------
'---
'--- Fonction de decryptage
'---
'----------------------------------------------------------------------------
Private Function DecryptageTxt() As String
Dim strDecrypter, strCle As String 'Création de 2 variables de type String
Dim intTemp, longu As Integer 'Création de 2 variables de type Integer
Dim i
'Création des tableaux
Dim tabCle() As String
Dim tabDecryptage() As String
Dim tabAscii() As Integer
Dim tabFinal() As String
longu = Len(mvarMotCle)
strDecrypter = mvarTexte
lng = Len(strDecrypter)
ReDim tabDecryptage(lng) As String
ReDim tabAscii(lng) As Integer
ReDim tabFinal(lng) As String
ReDim tabCle(lng) As String
For i = 1 To lng
tabDecryptage(i) = Mid(strDecrypter, i, 1)
Next
strCle = mvarMotCle
intTemp = lng \ longu
For y = 0 To intTemp
For i = 1 To longu
w = (y * longu) + i
If w <= lng Then
tabCle(w) = Mid(strCle, i, 1)
If tabCle(w) = "" Then
Else
tabCle(w) = Asc(tabCle(w))
End If
End If
Next
Next
For i = 1 To lng
intTemp = Asc(tabDecryptage(i))
tabAscii(i) = intTemp
intTemp = Val(tabCle(i))
tabAscii(i) = tabAscii(i) - intTemp
If tabAscii(i) < 0 Then
tabAscii(i) = tabAscii(i) + 255
End If
tabFinal(i) = Chr(tabAscii(i))
DecryptageTxt = DecryptageTxt + tabFinal(i)
Next
End Function
'----------------------------------------------------------------------------
'---
'--- Fonction de cryptage
'---
'----------------------------------------------------------------------------
Private Function CryptageTxt() As String
Dim strCrypter, strCle As String 'Création de 2 variables de type String
Dim intTemp, longu As Integer 'Création de 2 variables de type Integer
Dim i
'Création des tableaux
Dim tabCle() As String
Dim tabCryptage() As String
Dim tabAscii() As Integer
Dim tabFinal() As String
longu = Len(mvarMotCle)
strCrypter = mvarTexte
strCrypter = Trim(strCrypter)
strCle = mvarMotCle
lng = Len(strCrypter)
ReDim tabCryptage(lng) As String
ReDim tabAscii(lng) As Integer
ReDim tabFinal(lng) As String
ReDim tabCle(lng) As String
intTemp = lng \ longu
For y = 0 To (intTemp)
For i = 1 To longu
w = (y * longu) + i
If w <= lng Then
tabCle(w) = Mid(strCle, i, 1)
If tabCle(w) = "" Then
Else
tabCle(w) = Asc(tabCle(w))
End If
End If
Next
Next
'Cette boucle vas crypter le texte
For i = 1 To lng
tabCryptage(i) = Mid(strCrypter, i, 1)
intTemp = Asc(tabCryptage(i))
tabAscii(i) = intTemp
intTemp = Val(tabCle(i))
tabAscii(i) = tabAscii(i) + intTemp
If tabAscii(i) > 255 Then
tabAscii(i) = tabAscii(i) - 255
End If
tabFinal(i) = Chr(tabAscii(i))
CryptageTxt = CryptageTxt + tabFinal(i)
Next
End Function |
Module 1
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
| Function DeCrypte(st As String) As String
Dim mCrypt As New Crypt
mCrypt.TypeWork = Decryptage
mCrypt.MotCle = "LOG"
mCrypt.Texte = st
Debug.Print mCrypt.ReturnValue
DeCrypte = mCrypt.ReturnValue
Set mCrypt = Nothing
End Function
Function Crypte(st As String) As String
Dim mCrypt As New Crypt
' CRYPTAGE
mCrypt.TypeWork = Cryptage
mCrypt.MotCle = "LOG"
mCrypt.Texte = st
Debug.Print mCrypt.ReturnValue
Crypte = mCrypt.ReturnValue
Set mCrypt = Nothing
End Function
Sub Test()
Dim a As String
For i = 1 To 100
For j = 1 To 100
a = Cells(i, j)
Cells(i, j) = Crypte(a)
Next j
Next i
End Sub
Sub Test2()
Dim b As String
For i = 1 To 100
For j = 1 To 100
b = Cells(i, j)
Cells(i, j) = DeCrypte(b)
Next j
Next i
End Sub |
Voila Test Cypt
Test2 Decrypte
pour l'instant c anarchiwue
Mais je vais protéger le cryptage par mot de passe ect
Ma question est :
Peut ton faire la meme chose pour un document word et comment
N'ayant jamais fais de VBA sous word je ne sais pas
Merci par avance
Cordialament Baxter
