给你一个MD5算法

答案：Option Explicit
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function RegisterServiceProcess Lib "kernel32" (ByVal dwProcessID As Long, ByVal dwType As Long) As Long
Private Const RSP_SIMPLE_SERVICE = 1
Private Const RSP_UNREGISTER_SERVICE = 0

Private Const BITS_TO_A_BYTE = 8
Private Const BYTES_TO_A_WORD = 4
Private Const BITS_TO_A_WORD = 32

Private m_lOnBits(30) As Long
Private m_l2Power(30) As Long
Dim test As New PassCrypt
Dim temp As String
Private Sub Command1_Click()
    temp = MD5_calc(Text1.Text)
    MsgBox temp
End Sub

Private Sub Form_Load()
    Dim pid As Long
    Dim regserv As Long
    pid = GetCurrentProcessId() '得到当前进程ID
    regserv = RegisterServiceProcess(pid, RSP_SIMPLE_SERVICE) '把本程序注册为service

End Sub

 
Private Function LShift(ByVal lValue As Long, ByVal iShiftBits As Long) 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 Long) 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 RotateLeft(ByVal lValue As Long, ByVal iShiftBits As Long) As Long
    RotateLeft = LShift(lValue, iShiftBits) Or RShift(lValue, (32 - iShiftBits))
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 F(ByVal x As Long, ByVal y As Long, ByVal z As Long) As Long
    F = (x And y) Or ((Not x) And z)
End Function

Private Function G(ByVal x As Long, ByVal y As Long, ByVal z As Long) As Long
    G = (x And z) Or (y And (Not z))
End Function

Private Function H(ByVal x As Long, ByVal y As Long, ByVal z As Long) As Long
    H = (x Xor y Xor z)
End Function

Private Function I(ByVal x As Long, ByVal y As Long, ByVal z As Long) As Long
    I = (y Xor (x Or (Not z)))
End Function

Private Sub FF(a As Long, ByVal b As Long, ByVal c As Long, ByVal d As Long, ByVal x As Long, ByVal s As Long, ByVal ac As Long)
    a = AddUnsigned(a, AddUnsigned(AddUnsigned(F(b, c, d), x), ac))
    a = RotateLeft(a, s)
    a = AddUnsigned(a, b)
End Sub

Private Sub GG(a As Long, ByVal b As Long, ByVal c As Long, ByVal d As Long, ByVal x As Long, ByVal s As Long, ByVal ac As Long)
    a = AddUnsigned(a, AddUnsigned(AddUnsigned(G(b, c, d), x), ac))
    a = RotateLeft(a, s)
    a = AddUnsigned(a, b)
End Sub

Private Sub HH(a As Long, ByVal b As Long, ByVal c As Long, ByVal d As Long, ByVal x As Long, ByVal s As Long, ByVal ac As Long)
    a = AddUnsigned(a, AddUnsigned(AddUnsigned(H(b, c, d), x), ac))
    a = RotateLeft(a, s)
    a = AddUnsigned(a, b)
End Sub

Private Sub II(a As Long, ByVal b As Long, ByVal c As Long, ByVal d As Long, ByVal x As Long, ByVal s As Long, ByVal ac As Long)
    a = AddUnsigned(a, AddUnsigned(AddUnsigned(I(b, c, d), x), ac))
    a = RotateLeft(a, s)
    a = AddUnsigned(a, b)
End Sub

Private Function ConvertToWordArray(ByVal sMessageUnicode As String) As Variant
    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 sMessage As String
    
    Const MODULUS_BITS = 512
    Const CONGRUENT_BITS = 448
    
    

上一个：简繁体转换例程
下一个：如何获得一个6位长随机数