Encriptação SHA1 retificação

Teixeira

Aqui também dá erro, é quase no fim da função

SHA1 = LCase(Right("00000000" & Hex(HASH(0)), & _
Right("00000000" & Hex(HASH(1)), & _
Right("00000000" & Hex(HASH(2)), & _
Right("00000000" & Hex(HASH(3)), & _
Right("00000000" & Hex(HASH(4)), )

Obrigado

Olá, vou postar todo de novo:
Copiei do poste original (http://www.forosdelweb.com/1935907-post3.html) e rectifiquei um erro (tinha um espaço)

Código:

Option Explicit
'http://www.forosdelweb.com/1935907-post3.html

 Private m_lOnBits(30) As Long
 Private m_l2Power(30) As Long
 Private Const BITS_TO_A_BYTE As Long = 8
 Private Const BYTES_TO_A_WORD As Long = 4
 Private Const BITS_TO_A_WORD As Long = BYTES_TO_A_WORD * BITS_TO_A_BYTE
 
Private Sub Class_Initialize()
 m_lOnBits(0) = 1
 m_lOnBits(1) = 3
 m_lOnBits(2) = 7
 m_lOnBits(3) = 15
 m_lOnBits(4) = 31
 m_lOnBits(5) = 63
 m_lOnBits(6) = 127
 m_lOnBits(7) = 255
 m_lOnBits(8) = 511
 m_lOnBits(9) = 1023
 m_lOnBits(10) = 2047
 m_lOnBits(11) = 4095
 m_lOnBits(12) = 8191
 m_lOnBits(13) = 16383
 m_lOnBits(14) = 32767
 m_lOnBits(15) = 65535
 m_lOnBits(16) = 131071
 m_lOnBits(17) = 262143
 m_lOnBits(18) = 524287
 m_lOnBits(19) = 1048575
 m_lOnBits(20) = 2097151
 m_lOnBits(21) = 4194303
 m_lOnBits(22) = 8388607
 m_lOnBits(23) = 16777215
 m_lOnBits(24) = 33554431
 m_lOnBits(25) = 67108863
 m_lOnBits(26) = 134217727
 m_lOnBits(27) = 268435455
 m_lOnBits(28) = 536870911
 m_lOnBits(29) = 1073741823
 m_lOnBits(30) = 2147483647

 m_l2Power(0) = 1
 m_l2Power(1) = 2
 m_l2Power(2) = 4
 m_l2Power(3) = 8
 m_l2Power(4) = 16
 m_l2Power(5) = 32
 m_l2Power(6) = 64
 m_l2Power(7) = 128
 m_l2Power(8) = 256
 m_l2Power(9) = 512
 m_l2Power(10) = 1024
 m_l2Power(11) = 2048
 m_l2Power(12) = 4096
 m_l2Power(13) = 8192
 m_l2Power(14) = 16384
 m_l2Power(15) = 32768
 m_l2Power(16) = 65536
 m_l2Power(17) = 131072
 m_l2Power(18) = 262144
 m_l2Power(19) = 524288
 m_l2Power(20) = 1048576
 m_l2Power(21) = 2097152
 m_l2Power(22) = 4194304
 m_l2Power(23) = 8388608
 m_l2Power(24) = 16777216
 m_l2Power(25) = 33554432
 m_l2Power(26) = 67108864
 m_l2Power(27) = 134217728
 m_l2Power(28) = 268435456
 m_l2Power(29) = 536870912
 m_l2Power(30) = 1073741824
End Sub
 
Private Function LShift(ByVal lValue As Long, _
 ByVal iShiftBits As Integer) As Long
 If iShiftBits = 0 Then
 LShift = lValue
 Exit Function
 ElseIf iShiftBits = 31 Then
 If lValue And 1 Then
 LShift = &H80000000
 Else
 LShift = 0
 End If
 Exit Function

 ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
 Err.Raise 6
 End If
 If (lValue And m_l2Power(31 - iShiftBits)) Then
 LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * _
 m_l2Power(iShiftBits)) Or &H80000000

 Else
 LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * _
 m_l2Power(iShiftBits))

 End If
 End Function
 Private Function RShift(ByVal lValue As Long, _
 ByVal iShiftBits As Integer) As Long

 If iShiftBits = 0 Then
 RShift = lValue
 Exit Function

 ElseIf iShiftBits = 31 Then
 If lValue And &H80000000 Then
 RShift = 1
 Else
 RShift = 0
 End If
 Exit Function

 ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
 Err.Raise 6
 End If

 RShift = (lValue And &H7FFFFFFE) \ m_l2Power(iShiftBits)

 If (lValue And &H80000000) Then
 RShift = (RShift Or (&H40000000 \ m_l2Power(iShiftBits - 1)))
 End If
 End Function
 Private Function AddUnsigned(ByVal lX As Long, _
 ByVal lY As Long) As Long
 Dim lX4 As Long
 Dim lY4 As Long
 Dim lX8 As Long
 Dim lY8 As Long
 Dim lResult As Long

 lX8 = lX And &H80000000
 lY8 = lY And &H80000000
 lX4 = lX And &H40000000
 lY4 = lY And &H40000000

 lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF)

 If lX4 And lY4 Then
 lResult = lResult Xor &H80000000 Xor lX8 Xor lY8
 ElseIf lX4 Or lY4 Then
 If lResult And &H40000000 Then
 lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8
 Else
 lResult = lResult Xor &H40000000 Xor lX8 Xor lY8
 End If
 Else
 lResult = lResult Xor lX8 Xor lY8
 End If

 AddUnsigned = lResult
 End Function
 Private Function LRot(ByVal x As Long, ByVal n As Long) As Long
 LRot = LShift(x, n) Or RShift(x, (32 - n))
 End Function
 Private Function ConvertToWordArray(sMessage As String) As Long()
 Dim lMessageLength As Long
 Dim lNumberOfWords As Long
 Dim lWordArray() As Long
 Dim lBytePosition As Long
 Dim lByteCount As Long
 Dim lWordCount As Long
 Dim lByte As Long

 Const MODULUS_BITS As Long = 512
 Const CONGRUENT_BITS As Long = 448

 lMessageLength = Len(sMessage)

 lNumberOfWords = (((lMessageLength + _
 ((MODULUS_BITS - CONGRUENT_BITS) \ BITS_TO_A_BYTE)) \ _
 (MODULUS_BITS \ BITS_TO_A_BYTE)) + 1) * _
 (MODULUS_BITS \ BITS_TO_A_WORD)
 ReDim lWordArray(lNumberOfWords - 1)

 lBytePosition = 0
 lByteCount = 0
 Do Until lByteCount >= lMessageLength
 lWordCount = lByteCount \ BYTES_TO_A_WORD

 lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE

 lByte = AscB(Mid(sMessage, lByteCount + 1, 1))

 lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(lByte, lBytePosition)
 lByteCount = lByteCount + 1
 Loop

 lWordCount = lByteCount \ BYTES_TO_A_WORD
 lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE
 lWordArray(lWordCount) = lWordArray(lWordCount) Or _
 LShift(&H80, lBytePosition)

 lWordArray(lNumberOfWords - 1) = LShift(lMessageLength, 3)
 lWordArray(lNumberOfWords - 2) = RShift(lMessageLength, 29)

 ConvertToWordArray = lWordArray
 End Function
 Public Function SHA1(sMessage As String) As String
 Dim HASH(4) As Long
 Dim M() As Long
 Dim W(79) As Long
 Dim a, b, c, d, e As Long
 Dim g, h, i, j As Long
 Dim T1, T2 As Long

 HASH(0) = &H67452301
 HASH(1) = &HEFCDAB89
 HASH(2) = &H98BADCFE
 HASH(3) = &H10325476
 HASH(4) = &HC3D2E1F0

 M = ConvertToWordArray(sMessage)

 For i = 0 To UBound(M) Step 16
 a = HASH(0)
 b = HASH(1)
 c = HASH(2)
 d = HASH(3)
 e = HASH(4)

 For g = 0 To 15
 W(g) = M(i + g)
 Next g

 For g = 16 To 79
 W(g) = LRot(W(g - 3) Xor W(g - 8) Xor W(g - 14) Xor W(g - 16), 1)
 Next g

 For j = 0 To 79

 If j <= 19 Then
 T1 = (b And c) Or ((Not b) And d)
 T2 = &H5A827999
 ElseIf j <= 39 Then
 T1 = b Xor c Xor d
 T2 = &H6ED9EBA1
 ElseIf j <= 59 Then
 T1 = (b And c) Or (b And d) Or (c And d)
 T2 = &H8F1BBCDC
 ElseIf j <= 79 Then
 T1 = b Xor c Xor d
 T2 = &HCA62C1D6
 End If

 h = AddUnsigned(AddUnsigned(AddUnsigned(AddUnsigned(LRot(a, 5), T1), e), T2), W(j))
 e = d
 d = c
 c = LRot(b, 30)
 b = a
 a = h
 Next j

 HASH(0) = AddUnsigned(a, HASH(0))
 HASH(1) = AddUnsigned(b, HASH(1))
 HASH(2) = AddUnsigned(c, HASH(2))
 HASH(3) = AddUnsigned(d, HASH(3))
 HASH(4) = AddUnsigned(e, HASH(4))

 Next i

 SHA1 = LCase(Right("00000000" & Hex(HASH(0)), 8) & _
 Right("00000000" & Hex(HASH(1)), 8) & _
 Right("00000000" & Hex(HASH(2)), 8) & _
 Right("00000000" & Hex(HASH(3)), 8) & _
 Right("00000000" & Hex(HASH(4)), 8))
 End Function

Abraço

Bom dia,

Gostava de saber como posso utilizar código acima para minha BD.
Que passos devo fazer?

Abraço...

Teixeira

Não estou a conseguir chamar a função com o código que esta na Msg. Nº 1
E dá erro no " Debug "

Dim oSHA1 As New SHA

Obrigado

Assis o mesmo erro dá a mim, e não estou a conseguir dar a volta

Olá Amigos , como sabem aqui não podemos postar duvidas.
Colocar o modulo classe com o nome oSHA1
No entanto vamos aguardar se o colega que postou código disponibiliza pequeno exemplo.
Uma busca VBA SHA1 encontramos diversos exemplos.
Abraço

eu uso esse aqui

Option Compare Database
Option Explicit

Private m_lOnBits(30) As Long
Private m_l2Power(30) As Long

Private Const BITS_TO_A_BYTE As Long = 8
Private Const BYTES_TO_A_WORD As Long = 4
Private Const BITS_TO_A_WORD As Long = BYTES_TO_A_WORD * BITS_TO_A_BYTE

Private Sub class_Initialize()
m_lOnBits(0) = 1
m_lOnBits(1) = 3
m_lOnBits(2) = 7
m_lOnBits(3) = 15
m_lOnBits(4) = 31
m_lOnBits(5) = 63
m_lOnBits(6) = 127
m_lOnBits(7) = 255
m_lOnBits( = 511
m_lOnBits(9) = 1023
m_lOnBits(10) = 2047
m_lOnBits(11) = 4095
m_lOnBits(12) = 8191
m_lOnBits(13) = 16383
m_lOnBits(14) = 32767
m_lOnBits(15) = 65535
m_lOnBits(16) = 131071
m_lOnBits(17) = 262143
m_lOnBits(18) = 524287
m_lOnBits(19) = 1048575
m_lOnBits(20) = 2097151
m_lOnBits(21) = 4194303
m_lOnBits(22) = 8388607
m_lOnBits(23) = 16777215
m_lOnBits(24) = 33554431
m_lOnBits(25) = 67108863
m_lOnBits(26) = 134217727
m_lOnBits(27) = 268435455
m_lOnBits(28) = 536870911
m_lOnBits(29) = 1073741823
m_lOnBits(30) = 2147483647
m_l2Power(0) = 1
m_l2Power(1) = 2
m_l2Power(2) = 4
m_l2Power(3) = 8
m_l2Power(4) = 16
m_l2Power(5) = 32
m_l2Power(6) = 64
m_l2Power(7) = 128
m_l2Power( = 256
m_l2Power(9) = 512
m_l2Power(10) = 1024
m_l2Power(11) = 2048
m_l2Power(12) = 4096
m_l2Power(13) = 8192
m_l2Power(14) = 16384
m_l2Power(15) = 32768
m_l2Power(16) = 65536
m_l2Power(17) = 131072
m_l2Power(18) = 262144
m_l2Power(19) = 524288
m_l2Power(20) = 1048576
m_l2Power(21) = 2097152
m_l2Power(22) = 4194304
m_l2Power(23) = 8388608
m_l2Power(24) = 16777216
m_l2Power(25) = 33554432
m_l2Power(26) = 67108864
m_l2Power(27) = 134217728
m_l2Power(28) = 268435456
m_l2Power(29) = 536870912
m_l2Power(30) = 1073741824
End Sub
Private Function LShift(ByVal lValue As Long, _
ByVal iShiftBits As Integer) As Long
If iShiftBits = 0 Then
LShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And 1 Then
LShift = &H80000000
Else
LShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
err.Raise 6
End If
If (lValue And m_l2Power(31 - iShiftBits)) Then
LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * _
m_l2Power(iShiftBits)) Or &H80000000

Else
LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * _
m_l2Power(iShiftBits))

End If
End Function

Private Function RShift(ByVal lValue As Long, _
ByVal iShiftBits As Integer) As Long

If iShiftBits = 0 Then
RShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And &H80000000 Then
RShift = 1
Else
RShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
err.Raise 6
End If
RShift = (lValue And &H7FFFFFFE) \ m_l2Power(iShiftBits)
If (lValue And &H80000000) Then
RShift = (RShift Or (&H40000000 \ m_l2Power(iShiftBits - 1)))
End If
End Function
Private Function AddUnsigned(ByVal lX As Long, _
ByVal lY As Long) As Long
Dim lX4 As Long
Dim lY4 As Long
Dim lX8 As Long
Dim lY8 As Long
Dim lResult As Long

lX8 = lX And &H80000000
lY8 = lY And &H80000000
lX4 = lX And &H40000000
lY4 = lY And &H40000000

lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF)

If lX4 And lY4 Then
lResult = lResult Xor &H80000000 Xor lX8 Xor lY8
ElseIf lX4 Or lY4 Then
If lResult And &H40000000 Then
lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8
Else
lResult = lResult Xor &H40000000 Xor lX8 Xor lY8
End If
Else
lResult = lResult Xor lX8 Xor lY8
End If

AddUnsigned = lResult
End Function
Private Function LRot(ByVal X As Long, ByVal N As Long) As Long
LRot = LShift(X, N) Or RShift(X, (32 - N))
End Function
Private Function ConvertToWordArray(sMessage As String) As Long()
Dim lMessageLength As Long
Dim lNumberOfWords As Long
Dim lWordArray() As Long
Dim lBytePosition As Long
Dim lByteCount As Long
Dim lWordCount As Long
Dim lByte As Long

Const MODULUS_BITS As Long = 512
Const CONGRUENT_BITS As Long = 448

lMessageLength = Len(sMessage)
lNumberOfWords = (((lMessageLength + _
((MODULUS_BITS - CONGRUENT_BITS) \ BITS_TO_A_BYTE)) \ _
(MODULUS_BITS \ BITS_TO_A_BYTE)) + 1) * _
(MODULUS_BITS \ BITS_TO_A_WORD)
ReDim lWordArray(lNumberOfWords - 1)
lBytePosition = 0
lByteCount = 0
Do Until lByteCount >= lMessageLength
lWordCount = lByteCount \ BYTES_TO_A_WORD

lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE
lByte = AscB(Mid(sMessage, lByteCount + 1, 1))

lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(lByte, lBytePosition)
lByteCount = lByteCount + 1
Loop
lWordCount = lByteCount \ BYTES_TO_A_WORD
lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) Or _
LShift(&H80, lBytePosition)
lWordArray(lNumberOfWords - 1) = LShift(lMessageLength, 3)
lWordArray(lNumberOfWords - 2) = RShift(lMessageLength, 29)

ConvertToWordArray = lWordArray
End Function
Public Function SHA1(sMessage As String) As String
Dim HASH(4) As Long
Dim M() As Long
Dim w(79) As Long
Dim a, b, C, d, E As Long
Dim G, H, I, j As Long
Dim T1, T2 As Long
HASH(0) = &H67452301
HASH(1) = &HEFCDAB89
HASH(2) = &H98BADCFE
HASH(3) = &H10325476
HASH(4) = &HC3D2E1F0
M = ConvertToWordArray(sMessage)
For I = 0 To UBound(M) Step 16
a = HASH(0)
b = HASH(1)
C = HASH(2)
d = HASH(3)
E = HASH(4)
For G = 0 To 15
w(G) = M(I + G)
Next G
For G = 16 To 79
w(G) = LRot(w(G - 3) Xor w(G - Xor w(G - 14) Xor w(G - 16), 1)
Next G
For j = 0 To 79

If j <= 19 Then
T1 = (b And C) Or ((Not b) And d)
T2 = &H5A827999
ElseIf j <= 39 Then
T1 = b Xor C Xor d
T2 = &H6ED9EBA1
ElseIf j <= 59 Then
T1 = (b And C) Or (b And d) Or (C And d)
T2 = &H8F1BBCDC
ElseIf j <= 79 Then
T1 = b Xor C Xor d
T2 = &HCA62C1D6
End If
H = AddUnsigned(AddUnsigned(AddUnsigned(AddUnsigned(LRot(a, 5), T1), E), T2), w(j))
E = d
d = C
C = LRot(b, 30)
b = a
a = H
Next j
HASH(0) = AddUnsigned(a, HASH(0))
HASH(1) = AddUnsigned(b, HASH(1))
HASH(2) = AddUnsigned(C, HASH(2))
HASH(3) = AddUnsigned(d, HASH(3))
HASH(4) = AddUnsigned(E, HASH(4))

Next I
SHA1 = LCase(Right("00000000" & Hex(HASH(0)), & _
Right("00000000" & Hex(HASH(1)), & _
Right("00000000" & Hex(HASH(2)), & _
Right("00000000" & Hex(HASH(3)), & _
Right("00000000" & Hex(HASH(4)), )
End Function

chamo ele assim

Dim oSHA1 As New Class1
Dim LngStart, LngEnd As Long
LngStart = GetTickCount
Me.TT = oSHA1.SHA1(Me.chvs)
LngEnd = GetTickCount
Set oSHA1 = Nothing

NADIRONUNES

No debug da erro aqui:

Dim oSHA1 As New Class1

Não será falta de uma " Referencia " ?

Dava, se não fosse muito trabalho fazer um pequeno exemplo para mim...

aqui segue um exemplo a bombar

https://www.dropbox.com/s/7e3hmdg4e82dypz/SHA1.mdb?dl=0

espero que gostem .

abraço

Não consigo baixar, politica da empresa
Da para enviar para meu email?

Abraço...

claro da mail

para quem não consegue baixar aqui vai

cria um novo modulo e dá o nome CRPTSHA1

Option Explicit

Private m_lOnBits(30) As Long
Private m_l2Power(30) As Long
Private Const BITS_TO_A_BYTE As Long = 8
Private Const BYTES_TO_A_WORD As Long = 4
Private Const BITS_TO_A_WORD As Long = BYTES_TO_A_WORD * BITS_TO_A_BYTE

Private Sub Class_Initialize()
m_lOnBits(0) = 1
m_lOnBits(1) = 3
m_lOnBits(2) = 7
m_lOnBits(3) = 15
m_lOnBits(4) = 31
m_lOnBits(5) = 63
m_lOnBits(6) = 127
m_lOnBits(7) = 255
m_lOnBits( = 511
m_lOnBits(9) = 1023
m_lOnBits(10) = 2047
m_lOnBits(11) = 4095
m_lOnBits(12) = 8191
m_lOnBits(13) = 16383
m_lOnBits(14) = 32767
m_lOnBits(15) = 65535
m_lOnBits(16) = 131071
m_lOnBits(17) = 262143
m_lOnBits(18) = 524287
m_lOnBits(19) = 1048575
m_lOnBits(20) = 2097151
m_lOnBits(21) = 4194303
m_lOnBits(22) = 8388607
m_lOnBits(23) = 16777215
m_lOnBits(24) = 33554431
m_lOnBits(25) = 67108863
m_lOnBits(26) = 134217727
m_lOnBits(27) = 268435455
m_lOnBits(28) = 536870911
m_lOnBits(29) = 1073741823
m_lOnBits(30) = 2147483647

m_l2Power(0) = 1
m_l2Power(1) = 2
m_l2Power(2) = 4
m_l2Power(3) = 8
m_l2Power(4) = 16
m_l2Power(5) = 32
m_l2Power(6) = 64
m_l2Power(7) = 128
m_l2Power( = 256
m_l2Power(9) = 512
m_l2Power(10) = 1024
m_l2Power(11) = 2048
m_l2Power(12) = 4096
m_l2Power(13) = 8192
m_l2Power(14) = 16384
m_l2Power(15) = 32768
m_l2Power(16) = 65536
m_l2Power(17) = 131072
m_l2Power(18) = 262144
m_l2Power(19) = 524288
m_l2Power(20) = 1048576
m_l2Power(21) = 2097152
m_l2Power(22) = 4194304
m_l2Power(23) = 8388608
m_l2Power(24) = 16777216
m_l2Power(25) = 33554432
m_l2Power(26) = 67108864
m_l2Power(27) = 134217728
m_l2Power(28) = 268435456
m_l2Power(29) = 536870912
m_l2Power(30) = 1073741824
End Sub

Private Function LShift(ByVal lValue As Long, _
ByVal iShiftBits As Integer) As Long
If iShiftBits = 0 Then
LShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And 1 Then
LShift = &H80000000
Else
LShift = 0
End If
Exit Function

ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If
If (lValue And m_l2Power(31 - iShiftBits)) Then
LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * _
m_l2Power(iShiftBits)) Or &H80000000

Else
LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * _
m_l2Power(iShiftBits))

End If
End Function
Private Function RShift(ByVal lValue As Long, _
ByVal iShiftBits As Integer) As Long

If iShiftBits = 0 Then
RShift = lValue
Exit Function

ElseIf iShiftBits = 31 Then
If lValue And &H80000000 Then
RShift = 1
Else
RShift = 0
End If
Exit Function

ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If

RShift = (lValue And &H7FFFFFFE) \ m_l2Power(iShiftBits)

If (lValue And &H80000000) Then
RShift = (RShift Or (&H40000000 \ m_l2Power(iShiftBits - 1)))
End If
End Function
Private Function AddUnsigned(ByVal lX As Long, _
ByVal lY As Long) As Long
Dim lX4 As Long
Dim lY4 As Long
Dim lX8 As Long
Dim lY8 As Long
Dim lResult As Long

lX8 = lX And &H80000000
lY8 = lY And &H80000000
lX4 = lX And &H40000000
lY4 = lY And &H40000000

lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF)

If lX4 And lY4 Then
lResult = lResult Xor &H80000000 Xor lX8 Xor lY8
ElseIf lX4 Or lY4 Then
If lResult And &H40000000 Then
lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8
Else
lResult = lResult Xor &H40000000 Xor lX8 Xor lY8
End If
Else
lResult = lResult Xor lX8 Xor lY8
End If

AddUnsigned = lResult
End Function
Private Function LRot(ByVal x As Long, ByVal n As Long) As Long
LRot = LShift(x, n) Or RShift(x, (32 - n))
End Function
Private Function ConvertToWordArray(sMessage As String) As Long()
Dim lMessageLength As Long
Dim lNumberOfWords As Long
Dim lWordArray() As Long
Dim lBytePosition As Long
Dim lByteCount As Long
Dim lWordCount As Long
Dim lByte As Long

Const MODULUS_BITS As Long = 512
Const CONGRUENT_BITS As Long = 448

lMessageLength = Len(sMessage)

lNumberOfWords = (((lMessageLength + _
((MODULUS_BITS - CONGRUENT_BITS) \ BITS_TO_A_BYTE)) \ _
(MODULUS_BITS \ BITS_TO_A_BYTE)) + 1) * _
(MODULUS_BITS \ BITS_TO_A_WORD)
ReDim lWordArray(lNumberOfWords - 1)

lBytePosition = 0
lByteCount = 0
Do Until lByteCount >= lMessageLength
lWordCount = lByteCount \ BYTES_TO_A_WORD

lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE

lByte = AscB(Mid(sMessage, lByteCount + 1, 1))

lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(lByte, lBytePosition)
lByteCount = lByteCount + 1
Loop

lWordCount = lByteCount \ BYTES_TO_A_WORD
lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) Or _
LShift(&H80, lBytePosition)

lWordArray(lNumberOfWords - 1) = LShift(lMessageLength, 3)
lWordArray(lNumberOfWords - 2) = RShift(lMessageLength, 29)

ConvertToWordArray = lWordArray
End Function
Public Function SHA1(sMessage As String) As String
Dim HASH(4) As Long
Dim M() As Long
Dim W(79) As Long
Dim a, b, c, d, e As Long
Dim g, h, i, j As Long
Dim T1, T2 As Long

HASH(0) = &H67452301
HASH(1) = &HEFCDAB89
HASH(2) = &H98BADCFE
HASH(3) = &H10325476
HASH(4) = &HC3D2E1F0

M = ConvertToWordArray(sMessage)

For i = 0 To UBound(M) Step 16
a = HASH(0)
b = HASH(1)
c = HASH(2)
d = HASH(3)
e = HASH(4)

For g = 0 To 15
W(g) = M(i + g)
Next g

For g = 16 To 79
W(g) = LRot(W(g - 3) Xor W(g - Xor W(g - 14) Xor W(g - 16), 1)
Next g

For j = 0 To 79

If j <= 19 Then
T1 = (b And c) Or ((Not b) And d)
T2 = &H5A827999
ElseIf j <= 39 Then
T1 = b Xor c Xor d
T2 = &H6ED9EBA1
ElseIf j <= 59 Then
T1 = (b And c) Or (b And d) Or (c And d)
T2 = &H8F1BBCDC
ElseIf j <= 79 Then
T1 = b Xor c Xor d
T2 = &HCA62C1D6
End If

h = AddUnsigned(AddUnsigned(AddUnsigned(AddUnsigned(LRot(a, 5), T1), e), T2), W(j))
e = d
d = c
c = LRot(b, 30)
b = a
a = h
Next j

HASH(0) = AddUnsigned(a, HASH(0))
HASH(1) = AddUnsigned(b, HASH(1))
HASH(2) = AddUnsigned(c, HASH(2))
HASH(3) = AddUnsigned(d, HASH(3))
HASH(4) = AddUnsigned(e, HASH(4))

Next i

SHA1 = LCase(Right("00000000" & Hex(HASH(0)), & _
Right("00000000" & Hex(HASH(1)), & _
Right("00000000" & Hex(HASH(2)), & _
Right("00000000" & Hex(HASH(3)), & _
Right("00000000" & Hex(HASH(4)), )
End Function


no formulario e no evento click(botão)

Private Sub Comando5_Click()
Dim oSHA1 As New CRIPTSHA1
Dim LngStart, LngEnd As Long
LngStart = GetTickCount
Me.testeSHA = oSHA1.SHA1(Me.Nome)
LngEnd = GetTickCount
Set oSHA1 = Nothing
End Sub

Tópico movido para Off-Topic.

Quando tudo estiver direito, será recolocado na sala de Exemplos.

Será que esqueci de colocar algo?

Está aqui o exemplo:
https://www.dropbox.com/s/a97zkaj6xs74ig0/sha1.mdb?dl=0

se reparares o exemplo esta acima a funcionar.

abraço

Exemplo testado e a funcionar.

Tópico recolocado;

http://maximoaccess.forumeiros.com/t22400-encriptacao-sha1

administrador eu sei que funciona, mas eu ja tinha colocado um antes dele a funcionar, apenas isso.

cumprimentos

Boa tarde,

Já consegui aplicar o código que o nosso amigo Oscar disponibilizou a funfar.
Só uma pergunta:
E seu quiser fazer o inverso? Ex: Caso alguém se esqueça da palavra passe, existir
a possibilidade ao administrador do sistema poder visualiza-la.

Abraço..

nao ha reverso, no caso de passwords tens de ter uma chave unica para todos no caso de se esquecerem dela.

pelo menos foi a informação que pesquisei

encriptar via SHA1 ou MD5 é irreverssivel

Abraço

Estou a gostar de acompanhar e;

Este código encripta e volta ao normal texto;

http://maximoaccess.forumeiros.com/t996-encripta-descripta-texto

E nos 102 Códigos também, o código Encripta ou Decripta Senhas

http://maximoaccess.forumeiros.com/t11-102-codigos-vba-para-access#14

É seguro ??? A resposta é Não, não é.

Ok, Obrigado pela dica.
Vou criar botão "Repor" com chave unica onde só o Administrador do sistema tenha acesso.

Abraço...

Roberto, mas atenção ele fica vulneravel devido a ter a Password de reposição.

O melhor depois será recadastrar-se para de novo encriptar a password.

Abraço

Olá a todos.
Vejam este excelente artigo do mestre Avelino.
http://www.usandoaccess.com.br/dicas/dicas-praticas-de-access-parte-4.asp?id=1&idlista=190#inicio
Abraço

mas neste artigo fala em conversão de numeros apenas.

embora seja um bom artigo sem duvida


Abraço

Ola, veja este então:
http://www.usandoaccess.com.br/tutoriais/video-sistema-shareware-com-libercao-online.asp?id=1#inicio
Abraço