[VBA Excel Word]Adapter un code Excel a Word

**Baxter67** · 08/08/2005, 10h39

Voila mon code pour crypter un fichier excel

Module de classe Crypt

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
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 :

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
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

**Baxter67** · 08/08/2005, 12h00

personne sais comment adapter ceci a word??????

Cordialement Baxter

**Baxter67** · 08/08/2005, 13h59

En fait a mon avie il n'y a que sa a adapter
je pense

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
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

il faut juste savoir comment recuperer les chaine a crypter sur le doc word

ET c sa que je voudrais savoir

Meric par avance

Cordialement Baxter

**sozie9372** · 08/08/2005, 14h35

Salut !

N'y a t'il pas moyen de selectionner un bout de texte à chaque fois et de le passer à ta fonction de cryptage ?
Genre comme ca :

Code :

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

1
2
3
4
 
myWord.Range(0, 0).Select
Selection.MoveEnd wdStory
Crypte(Selection)            ' Je ne sais pas du tout si ca peu marcher...

J'ai cherché un peu sur le net des infos pour lire du texte dans Word et personne n'en parle...

+++
Ju

**Baxter67** · 08/08/2005, 23h43

apparement sa ne marche pas

personne connais une autre solution ????
*

Cordialement Baxter

[VBA Excel Word]Adapter un code Excel a Word

VBA Word

Discussions similaires

Partager

Partager