MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

Obrigado

Administração do MaximoAccess

MaximoAccess

Gostaria de reagir a esta mensagem? Crie uma conta em poucos cliques ou inicie sessão para continuar.

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access

    Encriptação SHA1

    avatar
    igornovais
    Novato
    Novato

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 10
    Registrado : 20/10/2014

    Encriptação SHA1 Empty Encriptação SHA1

    Mensagem  igornovais em 18/3/2015, 02:27

    Olá pessoal, eu tinha um banco de dados MYSQL onde as senhas dos usuários estavam encriptadas utilizando o algoritmo SHA1. Depois de muito garimpar encontrei esse módulo para encriptar textos. No meu caso consegui comparar as senha inserida com a que estava no banco de dados.

    Módulo de Classe:
    No meu caso eu nomeei o modulo de classe de "SHA".
    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 -  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)), 8))
     End Function

    Exemplo de uso:
    Código:

    Option Compare Database

    Dim oSHA1 As New SHA

    Private Sub botao_Click()
    Me.txt2 = oSHA1.SHA1(Me.txt1)
    Set oSHA1 = Nothing
    End Sub

    Exemplo Download:
    http://dl.dropboxusercontent.com/u/771097/sha1.zip


    Referência: http://www.forosdelweb.com/1935907-post3.html


    Última edição por igornovais em 18/3/2015, 16:09, editado 1 vez(es)

      Data/hora atual: 3/12/2020, 19:15