module1.bas

这是一个加密解密程序

Attribute VB_Name = "Module1"
Public Function CheckPassWord(ByVal ps As String) As String
'密码的加密
On Error Resume Next
    
    If ps = "" Then Exit Function
    
    '产生一个随机数列
    Dim pss As String
    Dim j, i As Integer
    Dim R2 As Single
    Dim pas As String
    Dim Len1 As Integer
    Dim R1 As String
    
    pss = "0"
    For j = 1 To 3
        R2 = Rnd(2)
        pas = CStr(R2)
        Len1 = Len(pas)
        For i = 3 To Len1
            R1 = Mid(pas, i, 1)
            If R1 Like "[1-9]" And R1 Like ("[!" & pss & "]") Then
               pss = pss & R1
            End If
        Next i
    Next j
    If Len(pss) < 10 Then
       For i = 1 To 9
           R1 = CStr(i)
           If R1 Like ("[!" & pss & "]") Then pss = pss & R1
       Next i
    End If
    
    '长度,排列加密
    Dim Len2 As Integer
    Dim pss2 As String
    
    pss2 = ""
    
    For i = 1 To 4
        pss2 = pss2 & Chr(21 + CInt(Mid(pss, i * 2, 2)))
    Next i
    pss2 = pss2 & Chr(80 + CInt(Right(pss, 1)))
    
      '字符串加密
    Dim pss1 As String
    Dim Ord1(9) As Integer
    
    Len2 = Len(ps)
    If Len2 > 8 Then Len2 = 8
    ps = Left(ps + Right(pss, 8), 8) + Chr(Len2 + 90)  '不足8,则补足8个
    pss1 = ""
    For i = 1 To 9
        Ord1(i) = CInt(Mid(pss, i + 1, 1))
        pss1 = pss1 & Chr(158 - Asc(Mid(ps, Ord1(i), 1)))
    Next i
    
    '返回加密的密码
    CheckPassWord = pss2 & pss1
End Function
Public Function ReCheckPassWord(ByVal ps As String) As String
'密码的解密
    Dim pss1 As String, pss2 As String
    pss1 = Left(ps, 5) '信息段
    pss2 = Right(ps, 9) '内容段
   
   '求出密码长度,排列
    
    Dim i As Integer
    Dim pas As String
    pas = ""
    For i = 1 To 4
        pas = pas & CStr(Asc(Mid(pss1, i, 2)) - 21)
    Next i
    pas = pas & CStr(Asc(Right(pss1, 1)) - 80)
    
    
    Dim pws As String
    Dim Ord1(9) As String
    Debug.Print Asc(Mid(pss2, 9, 1))
    For i = 1 To 9
        Ord1(CInt(Mid(pas, i, 1))) = Chr(158 - Asc(Mid(pss2, i, 1)))
    Next i
    
    pws = ""
    For i = 1 To 9
        pws = pws & Ord1(i)
    Next i
    ReCheckPassWord = Left(pws, Asc(Ord1(9)) - 90)
End Function

Public Function EncryptPw(pw As String, Optional pa As Long = 3355) As String
       Dim i As Integer
       Dim s1 As String, s2 As String
       Dim p As Long
       Dim p1 As String
       Rnd (-(Abs(pa) + 1))
       s1 = pw
       s2 = ""
       For i = 1 To Len(s1)
           p = 1 + Rnd * 14
           s2 = s2 & Chr(p Xor Asc(Mid(s1, i, 1)))
       Next i
       EncryptPw = s2
End Function