Онлайн кредиты займы Казахстан онлайн кредиты усть-каманеногорск кредиты онлайн алматы взять онлайн займ в Казахстане гта5 играть на компьютере Pole Dance алматы играть онлайн форсаж 8 pokemon go играть вот ссылка гороскоп совместимости любовный гороскоп на 2017 рак девушка сексуальный гороскоп он телец она рыбы гороскопы близнецов любовный одиночные любовный любовный гороскоп гороскоп совместимости совместимость знаков в любви любовный гороскоп для рыб на сегодня и на завтра любовный гороскоп знака водолей гороскоп совместимости парень козерог девушка весы гороскоп совместимость гороскоп на месяц любовный рак основываясь на этих данных гороскоп женщина рыба мужчина весы совместимость гороскоп совместимости смотрите подробнее гороскоп на эту неделю стрелец любовный гороскоп дева любовный на сегодня и завтра гороскоп любви весы на завтра вот ссылка сексуальный гороскоп девы и овна гороскоп на совместимость телец и рыбы рак на сегодня гороскоп любовь гороскоп весы гороскоп совместимости для рыб на 2017 гороскоп семейный и любовный на сегодня гороскоп рак любовный совместимость по гороскопу женщина телец мужчина рак совместимость гороскоп секс гороскоп совместимости гороскоп телец мужчина женщина скорпион совместимость гороскоп любовный гороскоп любовный узнать больше перейти гороскоп совместимости любовный гороскоп двух львов гороскоп на неделю телец любовный гороскоп стрелец женщина и весы мужчина совместимость в браке гороскоп совместимости весы жен овен муж гороскоп совместимости сексуальный гороскоп совместимости гороскоп сегодня совместимость гороскопу источник статьи гороскоп козы ссылка на страницу гороскоп весы и лев любовный гороскоп совместимость совместимость по гороскопу рыба и дева гороскоп для женщины рак на сегодня любовь читать больше гороскоп пифагора совместимости знаков зодиака совместимость овен и лев по гороскопу подробнее на этой странице гороскоп гороскоп сексуальный любовный гороскоп ссылка совместимость свиньи и петуха по восточному гороскопу гороскоп совместимости гороскоп совместимости гороскоп на совместимость женщина телец любовный гороскоп гороскоп дева совместимость гороскопов лев скорпион гороскоп гороскоп гороскоп совместимости рыба тигр любовный гороскоп женщина козерог 2017 любовный гороскоп козерог на сегодня женщина любовный гороскоп для девы на сегодня и завтра гороскоп стрелец гороскоп на тельца на совместимость гороскоп на сегодня дева на оракул любовный гороскоп совместимости по знакам зодиака овен и водолей
Rambler's Top100
Российский фонд помощи
Навигация
Главная
MS ACCESS
VB
ASP
PHP
Наши друзья
Поиск
Форум
Лента новостей
Новый сайт

Online
Сейчас на сайте находятся:
1 гость
Рассылки Subscribe.Ru
Работа с MS Access
Подписаться письмом
Реклама на сайте
 
Главная arrow MS ACCESS arrow Функция шифрования строки алгоритмом MD5
Функция шифрования строки алгоритмом MD5 Печать E-mail
Автор Прислал HOUSE MD   
24.05.2010 г.

Функция шифрования строки алгоритмом MD5.

Взята с сайта  http://www.di-mgt.com.au/crypto.html#MD5

 

Option Compare Database
Option Base 0

' A VB6/VBA procedure for the MD5 message-digest algorithm
' as described in RFC 1321 by R. Rivest, April 1992

' First published 16 September 2005.
'************************* COPYRIGHT NOTICE*************************
' This code was originally written in Visual Basic by David Ireland
' and is copyright (c) 2005 D.I. Management Services Pty Limited,
' all rights reserved.

' You are free to use this code as part of your own applications
' provided you keep this copyright notice intact and acknowledge
' its authorship with the words:

'   "Contains cryptography software by David Ireland of
'   DI Management Services Pty Ltd <www.di-mgt.com.au>."

' If you use it as part of a web site, please include a link
' to our site in the form
' <A HREF="http://www.di-mgt.com.au/crypto.html">Cryptography
' Software Code</a>

' This code may only be used as part of an application. It may
' not be reproduced or distributed separately by any means without
' the express written permission of the author.

' David Ireland and DI Management Services Pty Limited make no
' representations concerning either the merchantability of this
' software or the suitability of this software for any particular
' purpose. It is provided "as is" without express or implied
' warranty of any kind.

' The latest version of this source code can be downloaded from
' www.di-mgt.com.au/crypto.html.
' Comments and bug reports to http://www.di-mgt.com.au/contact.html
'****************** END OF COPYRIGHT NOTICE*************************

' POSSIBLE SPEED-UPS
' 1. Use memory copy functions from Win32 API to copy bytes into
'    32-bit words directly.
' 2. Write 16 x specific Rotate_Left_By_n functions with hardcoded
'    multiplicands for each possible shift S11..S44;
'    i.e. for n = 4-7, 9-12, 14-17, 20-23.

Private Const MD5_BLK_LEN As Long = 64
' Constants for MD5Transform routine
Private Const S11 As Long = 7
Private Const S12 As Long = 12
Private Const S13 As Long = 17
Private Const S14 As Long = 22
Private Const S21 As Long = 5
Private Const S22 As Long = 9
Private Const S23 As Long = 14
Private Const S24 As Long = 20
Private Const S31 As Long = 4
Private Const S32 As Long = 11
Private Const S33 As Long = 16
Private Const S34 As Long = 23
Private Const S41 As Long = 6
Private Const S42 As Long = 10
Private Const S43 As Long = 15
Private Const S44 As Long = 21
' Constants for unsigned word addition
Private Const OFFSET_4 = 4294967296#
Private Const MAXINT_4 = 2147483647



' TEST FUNCTIONS...
' MD5 test suite:
' MD5 ("") = d41d8cd98f00b204e9800998ecf8427e
' MD5 ("a") = 0cc175b9c0f1b6a831c399e269772661
' MD5 ("abc") = 900150983cd24fb0d6963f7d28e17f72
' MD5 ("message digest") = f96b697d7cb7938d525a2f31aaf161d0
' MD5 ("abcdefghijklmnopqrstuvwxyz") = c3fcd3d76192e4007dfb496cca67e13b
' MD5 ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789") =
' d174ab98d277d9f5a5611c2c9f419d9f
' MD5 ("123456789012345678901234567890123456789012345678901234567890123456
' 78901234567890") = 57edf4a22be3c955ac49da2e2107b67a

' MD5 (1 million x 'a') = 7707d6ae4e027c70eea2a935c2296f21

Public Function Test_md5_abc()
    Debug.Print MD5_string("abc")
End Function


Public Function md5_test_suite()
    Debug.Print MD5_string("")
    Debug.Print MD5_string("a")
    Debug.Print MD5_string("abc")
    Debug.Print MD5_string("message digest")
    Debug.Print MD5_string("abcdefghijklmnopqrstuvwxyz")
    Debug.Print MD5_string("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789")
    Debug.Print MD5_string("12345678901234567890123456789012345678901234567890123456789012345678901234567890")
End Function


Public Function test_md5_empty()
    Debug.Print MD5_string("")
End Function


Public Function test_md5_around64()
    Dim strMessage As String
    strMessage = "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
    Debug.Print MD5_string(strMessage)
    Debug.Print MD5_string(Left(strMessage, 65))
    Debug.Print MD5_string(Left(strMessage, 64))
    Debug.Print MD5_string(Left(strMessage, 63))
    Debug.Print MD5_string(Left(strMessage, 62))
    Debug.Print MD5_string(Left(strMessage, 57))
    Debug.Print MD5_string(Left(strMessage, 56))
    Debug.Print MD5_string(Left(strMessage, 55))
End Function


Public Function test_md5_million_a()
' This may take some time...
    Dim abMessage() As Byte
    Dim mLen As Long
    Dim i As Long
    mLen = 1000000
    ReDim abMessage(mLen - 1)
    For i = 0 To mLen - 1
        abMessage(i) = &H61     ' 0x61 = 'a'
    Next
    Debug.Print MD5_bytes(abMessage, mLen)

End Function


' MAIN EXPORTED MD5 FUNCTIONS...

Public Function MD5_string(strMessage As StringAs String
' Returns 32-char hex string representation of message digest
' Input as a string (max length 2^29-1 bytes)
    Dim abMessage() As Byte
    Dim mLen As Long
    ' Cope with the empty string
    If Len(strMessage) > 0 Then
        abMessage = StrConv(strMessage, vbFromUnicode)
        ' Compute length of message in bytes
        mLen = UBound(abMessage) - LBound(abMessage) + 1
    End If
    MD5_string = MD5_bytes(abMessage, mLen)
End Function


Public Function MD5_bytes(abMessage() As Byte, mLen As LongAs String
' Returns 32-char hex string representation of message digest
' Input as an array of bytes of length mLen bytes

    Dim nBlks As Long
    Dim nBits As Long
    Dim block(MD5_BLK_LEN - 1) As Byte
    Dim state(3) As Long
    Dim wb(3) As Byte
    Dim sHex As String
    Dim index As Long
    Dim partLen As Long
    Dim i As Long
    Dim j As Long

    ' Catch length too big for VB arithmetic (268 million!)
    If mLen >= &HFFFFFFF Then Error 6     ' overflow

    ' Initialise
    ' Number of complete 512-bit/64-byte blocks to process
    nBlks = mLen \ MD5_BLK_LEN

    ' Load magic initialization constants
    state(0) = &H67452301
    state(1) = &HEFCDAB89
    state(2) = &H98BADCFE
    state(3) = &H10325476

    ' Main loop for each complete input block of 64 bytes
    index = 0
    For i = 0 To nBlks - 1
        Call md5_transform(state, abMessage, index)
        index = index + MD5_BLK_LEN
    Next

    ' Construct final block(s) with padding
    partLen = mLen Mod MD5_BLK_LEN
    index = nBlks * MD5_BLK_LEN
    For i = 0 To partLen - 1
        block(i) = abMessage(index + i)
    Next
    block(partLen) = &H80
    ' Make sure padding (and bit-length) set to zero
    For i = partLen + 1 To MD5_BLK_LEN - 1
        block(i) = 0
    Next
    ' Two cases: partLen is < or >= 56
    If partLen >= MD5_BLK_LEN - 8 Then
        ' Need two blocks
        Call md5_transform(state, block, 0)
        For i = 0 To MD5_BLK_LEN - 1
            block(i) = 0
        Next
    End If
    ' Append number of bits in little-endian order
    nBits = mLen * 8
    block(MD5_BLK_LEN - 8) = nBits And &HFF
    block(MD5_BLK_LEN - 7) = nBits \ &H100 And &HFF
    block(MD5_BLK_LEN - 6) = nBits \ &H10000 And &HFF
    block(MD5_BLK_LEN - 5) = nBits \ &H1000000 And &HFF
    ' (NB we don't try to cope with number greater than 2^31)

    ' Final padded block with bit length
    Call md5_transform(state, block, 0)

    ' Decode 4 x 32-bit words into 16 bytes with LSB first each time
    ' and return result as a hex string
    MD5_bytes = ""
    For i = 0 To 3
        Call uwSplit(state(i), wb(3), wb(2), wb(1), wb(0))
        For j = 0 To 3
            If wb(j) < 16 Then
                sHex = "0" & Hex(wb(j))
            Else
                sHex = Hex(wb(j))
            End If
            MD5_bytes = MD5_bytes & sHex
        Next
    Next

End Function


' INTERNAL FUNCTIONS...

Private Sub md5_transform(state() As Long, buf() As ByteByVal index As Long)
' Updates 4 x 32-bit values in state
' Input: the next 64 bytes in buf starting at offset index
' Assumes at least 64 bytes are present after offset index
    Dim a As Long
    Dim b As Long
    Dim c As Long
    Dim d As Long
    Dim j As Integer
    Dim x(15) As Long

    a = state(0)
    b = state(1)
    c = state(2)
    d = state(3)

    ' Decode the next 64 bytes into 16 words with LSB first
    For j = 0 To 15
        x(j) = uwJoin(buf(index + 3), buf(index + 2), buf(index + 1), buf(index))
        index = index + 4
    Next

    ' Round 1
    a = FF(a, b, c, d, x(0), S11, &HD76AA478)   ' 1
    d = FF(d, a, b, c, x(1), S12, &HE8C7B756)   ' 2
    c = FF(c, d, a, b, x(2), S13, &H242070DB)   ' 3
    b = FF(b, c, d, a, x(3), S14, &HC1BDCEEE)   ' 4
    a = FF(a, b, c, d, x(4), S11, &HF57C0FAF)   ' 5
    d = FF(d, a, b, c, x(5), S12, &H4787C62A)   ' 6
    c = FF(c, d, a, b, x(6), S13, &HA8304613)   ' 7
    b = FF(b, c, d, a, x(7), S14, &HFD469501)   ' 8
    a = FF(a, b, c, d, x(8), S11, &H698098D8)   ' 9
    d = FF(d, a, b, c, x(9), S12, &H8B44F7AF)   ' 10
    c = FF(c, d, a, b, x(10), S13, &HFFFF5BB1)  ' 11
    b = FF(b, c, d, a, x(11), S14, &H895CD7BE)  ' 12
    a = FF(a, b, c, d, x(12), S11, &H6B901122)  ' 13
    d = FF(d, a, b, c, x(13), S12, &HFD987193)  ' 14
    c = FF(c, d, a, b, x(14), S13, &HA679438E)  ' 15
    b = FF(b, c, d, a, x(15), S14, &H49B40821)  ' 16

    ' Round 2
    a = GG(a, b, c, d, x(1), S21, &HF61E2562)   ' 17
    d = GG(d, a, b, c, x(6), S22, &HC040B340)   ' 18
    c = GG(c, d, a, b, x(11), S23, &H265E5A51)  ' 19
    b = GG(b, c, d, a, x(0), S24, &HE9B6C7AA)   ' 20
    a = GG(a, b, c, d, x(5), S21, &HD62F105D)   ' 21
    d = GG(d, a, b, c, x(10), S22, &H2441453)   ' 22
    c = GG(c, d, a, b, x(15), S23, &HD8A1E681)  ' 23
    b = GG(b, c, d, a, x(4), S24, &HE7D3FBC8)   ' 24
    a = GG(a, b, c, d, x(9), S21, &H21E1CDE6)   ' 25
    d = GG(d, a, b, c, x(14), S22, &HC33707D6)  ' 26
    c = GG(c, d, a, b, x(3), S23, &HF4D50D87)   ' 27
    b = GG(b, c, d, a, x(8), S24, &H455A14ED)   ' 28
    a = GG(a, b, c, d, x(13), S21, &HA9E3E905)  ' 29
    d = GG(d, a, b, c, x(2), S22, &HFCEFA3F8)   ' 30
    c = GG(c, d, a, b, x(7), S23, &H676F02D9)   ' 31
    b = GG(b, c, d, a, x(12), S24, &H8D2A4C8A)  ' 32

    ' Round 3
    a = HH(a, b, c, d, x(5), S31, &HFFFA3942)   ' 33
    d = HH(d, a, b, c, x(8), S32, &H8771F681)   ' 34
    c = HH(c, d, a, b, x(11), S33, &H6D9D6122)  ' 35
    b = HH(b, c, d, a, x(14), S34, &HFDE5380C)  ' 36
    a = HH(a, b, c, d, x(1), S31, &HA4BEEA44)   ' 37
    d = HH(d, a, b, c, x(4), S32, &H4BDECFA9)   ' 38
    c = HH(c, d, a, b, x(7), S33, &HF6BB4B60)   ' 39
    b = HH(b, c, d, a, x(10), S34, &HBEBFBC70)  ' 40
    a = HH(a, b, c, d, x(13), S31, &H289B7EC6)  ' 41
    d = HH(d, a, b, c, x(0), S32, &HEAA127FA)   ' 42
    c = HH(c, d, a, b, x(3), S33, &HD4EF3085)   ' 43
    b = HH(b, c, d, a, x(6), S34, &H4881D05)    ' 44
    a = HH(a, b, c, d, x(9), S31, &HD9D4D039)   ' 45
    d = HH(d, a, b, c, x(12), S32, &HE6DB99E5)  ' 46
    c = HH(c, d, a, b, x(15), S33, &H1FA27CF8)  ' 47
    b = HH(b, c, d, a, x(2), S34, &HC4AC5665)   ' 48

    ' Round 4
    a = II(a, b, c, d, x(0), S41, &HF4292244)   ' 49
    d = II(d, a, b, c, x(7), S42, &H432AFF97)   ' 50
    c = II(c, d, a, b, x(14), S43, &HAB9423A7)  ' 51
    b = II(b, c, d, a, x(5), S44, &HFC93A039)   ' 52
    a = II(a, b, c, d, x(12), S41, &H655B59C3)  ' 53
    d = II(d, a, b, c, x(3), S42, &H8F0CCC92)   ' 54
    c = II(c, d, a, b, x(10), S43, &HFFEFF47D)  ' 55
    b = II(b, c, d, a, x(1), S44, &H85845DD1)   ' 56
    a = II(a, b, c, d, x(8), S41, &H6FA87E4F)   ' 57
    d = II(d, a, b, c, x(15), S42, &HFE2CE6E0)  ' 58
    c = II(c, d, a, b, x(6), S43, &HA3014314)   ' 59
    b = II(b, c, d, a, x(13), S44, &H4E0811A1)  ' 60
    a = II(a, b, c, d, x(4), S41, &HF7537E82)   ' 61
    d = II(d, a, b, c, x(11), S42, &HBD3AF235)  ' 62
    c = II(c, d, a, b, x(2), S43, &H2AD7D2BB)   ' 63
    b = II(b, c, d, a, x(9), S44, &HEB86D391)   ' 64

    state(0) = uwAdd(state(0), a)
    state(1) = uwAdd(state(1), b)
    state(2) = uwAdd(state(2), c)
    state(3) = uwAdd(state(3), d)

End Sub


' FF, GG, HH, and II transformations for rounds 1, 2, 3, and 4

Private Function AddRotAdd(f As Long, a As Long, b As Long, x As Long, s As Integer, ac As LongAs Long
' Common routine for FF, GG, HH and II
' #define AddRotAdd(f, a, b, c, d, x, s, ac) { \
'  (a) += f + (x) + (UINT4)(ac); \
'  (a) = ROTATE_LEFT ((a), (s)); \
'  (a) += (b); \
'  }
    Dim temp As Long
    temp = uwAdd(a, f)
    temp = uwAdd(temp, x)
    temp = uwAdd(temp, ac)
    temp = uwRol(temp, s)
    AddRotAdd = uwAdd(temp, b)
End Function


Private Function FF(a As Long, b As Long, c As Long, d As Long, x As Long, s As Integer, ac As LongAs Long
' Returns new value of a
' #define F(x, y, z) (((x) & (y)) | ((~x) & (z)))
' #define FF(a, b, c, d, x, s, ac) { \
'  (a) += F ((b), (c), (d)) + (x) + (UINT4)(ac); \
'  (a) = ROTATE_LEFT ((a), (s)); \
'  (a) += (b); \
'  }
    Dim t As Long
    Dim t2 As Long
    ' F ((b), (c), (d)) = (((b) & (c)) | ((~b) & (d)))
    t = b And c
    t2 = (Not b) And d
    t = t Or t2
    FF = AddRotAdd(t, a, b, x, s, ac)
End Function


Private Function GG(a As Long, b As Long, c As Long, d As Long, x As Long, s As Integer, ac As LongAs Long
' #define G(b, c, d) (((b) & (d)) | ((c) & (~d)))
    Dim t As Long
    Dim t2 As Long
    t = b And d
    t2 = c And (Not d)
    t = t Or t2
    GG = AddRotAdd(t, a, b, x, s, ac)
End Function


Private Function HH(a As Long, b As Long, c As Long, d As Long, x As Long, s As Integer, ac As LongAs Long
' #define H(b, c, d) ((b) ^ (c) ^ (d))
    Dim t As Long
    t = b Xor c Xor d
    HH = AddRotAdd(t, a, b, x, s, ac)
End Function


Private Function II(a As Long, b As Long, c As Long, d As Long, x As Long, s As Integer, ac As LongAs Long
' #define I(b, c, d) ((c) ^ ((b) | (~d)))
    Dim t As Long
    t = b Or (Not d)
    t = c Xor t
    II = AddRotAdd(t, a, b, x, s, ac)
End Function


' Unsigned 32-bit word functions suitable for VB/VBA

Private Function uwRol(w As Long, s As IntegerAs Long
' Return 32-bit word w rotated left by s bits
' avoiding problem with VB sign bit
    Dim i As Integer
    Dim t As Long

    uwRol = w
    For i = 1 To s
        t = uwRol And &H3FFFFFFF
        t = t * 2
        If (uwRol And &H40000000) <> 0 Then
            t = t Or &H80000000
        End If
        If (uwRol And &H80000000) <> 0 Then
            t = t Or &H1
        End If
        uwRol = t
    Next
End Function


Private Function uwJoin(a As Byte, b As Byte, c As Byte, d As ByteAs Long
' Join 4 x 8-bit bytes into one 32-bit word a.b.c.d
    uwJoin = ((a And &H7F) * &H1000000) Or (b * &H10000) Or (CLng(c) * &H100) Or d
    If a And &H80 Then
        uwJoin = uwJoin Or &H80000000
    End If
End Function


Private Sub uwSplit(ByVal w As Long, a As Byte, b As Byte, c As Byte, d As Byte)
' Split 32-bit word w into 4 x 8-bit bytes
    a = CByte(((w And &HFF000000) \ &H1000000) And &HFF)
    b = CByte(((w And &HFF0000) \ &H10000) And &HFF)
    c = CByte(((w And &HFF00) \ &H100) And &HFF)
    d = CByte((w And &HFF) And &HFF)
End Sub


Private Function uwAdd(wordA As Long, wordB As LongAs Long
' Adds words A and B avoiding overflow
    Dim myUnsigned As Double

    myUnsigned = LongToUnsigned(wordA) + LongToUnsigned(wordB)
    ' Cope with overflow
    If myUnsigned > OFFSET_4 Then
        myUnsigned = myUnsigned - OFFSET_4
    End If
    uwAdd = UnsignedToLong(myUnsigned)

End Function


'****************************************************
' These two functions from Microsoft Article Q189323
' "HOWTO: convert between Signed and Unsigned Numbers"

Private Function UnsignedToLong(value As DoubleAs Long
    If value < 0 Or value >= OFFSET_4 Then Error 6 ' Overflow
    If value <= MAXINT_4 Then
        UnsignedToLong = value
    Else
        UnsignedToLong = value - OFFSET_4
    End If
End Function


Private Function LongToUnsigned(value As LongAs Double
    If value < 0 Then
        LongToUnsigned = value + OFFSET_4
    Else
        LongToUnsigned = value
    End If
End Function

' End of Microsoft-article functions
'****************************************************

 

 

Пример вызова:

 



Dim strMessage As String
strMessage ="Строка для шифрования"

Debug.Print MD5_string(strMessage)
 


Просмотров: 16767

  Коментарии (2)
 1 Написал(а) Дмитрий, в 19:36 06.06.2010
А можно как нибудь перевести в обратном порядке. из зашифрованной строки в текст? Мое мыло cektop48@маил.ru
 2 Написал(а) osmor, в 04:11 07.06.2010
Дмитрий, MD5 относится к алгоритмам хеширования, т.е. не может использоваться там где нужна последующая расшифровка данных. 
Методов расшифровки MD5 нет. Можно, используя словари или последовательный перебор, подобрать строку которая будет иметь такой же хеш как и зашифрованная, но в большой долей вероятности это будет другая строка. Если нужно шифрование с последующей расшифровкой спользуйте другие алгоритмы например Blowfish 
http://hiprog.com/index.php?option=com_content&task=view&id=251661649&Itemid=35

Добавить коментарий
Имя:
E-mail
Коментарий:



Код:* Code

 
Реклама на сайте
HiProg.com - Технологии программирования
Rambler's Top100 TopList