form1.frm

hash算法的vb实现.很好用!

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   3090
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3090
   ScaleWidth      =   4680
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton Command2 
      Caption         =   "Command2"
      Height          =   855
      Left            =   2760
      TabIndex        =   1
      Top             =   1800
      Width           =   1335
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   615
      Left            =   1320
      TabIndex        =   0
      Top             =   600
      Width           =   975
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub Initialize(vKeyString As String)
    Dim intI As Integer, intJ As Integer
Randomize Rnd(-1)
'得到初始值（种子值），每次调用初始值均相同
'根据初始值（种子值）得到随机数序列，
 '每次调用Initialize时，初始值均相同。
 '只要vKeyString相同，所产生的随机数序列一定相同
    For intI = 1 To Len(vKeyString)
    intJ = Rnd(-Rnd * AscW(Mid(vKeyString, intI, 1)))
    Randomize intJ
    Next intI
End Sub

Public Sub DoXor(ByRef msFileText As String)
'本函数用于对msFileText中的字符串进行XOR 27操作，
'英文或汉字均作为一个字符来处理，
    '加密方调用该模块用于加密，解密方调用该模块用于解密。
    '使用Unicode函数AscW 、ChrW可正确处理所有汉字
    '使用ASC函数Asc 、Chr无法正确处理所有汉字

    Dim intC As Integer
    Dim intB As Integer
    Dim lngI As Long
'下面，用Rnd产生随机序列数，
 '然后根据Int(Rnd ＊ 2 ^ 7)得到一个对应整数，
    '‘再用该整数与msFileText中字符XOR。
    For lngI = 1 To Len(msFileText)
        intC = AscW(Mid(msFileText, lngI, 1))
        intB = Int(Rnd * 2 ^ 7)
  ' ‘选用<=127可正确处理汉字，ChrW(n):n 有一个范围
 Mid(msFileText, lngI, 1) = ChrW(intC Xor intB)
   Next lngI
End Sub


    '有了上面的知识，就可以设计HASH函数。本加密解密方案中HASH函数如下：

Public Function Hash(ET As String) As String
Dim BitLenString As String
Dim KeyString As String
Dim FileText As String
BitLenString = "12345678"

KeyString = ET & BitLenString
Call Initialize(KeyString)
'根据KeyString产生随机数序列
    FileText = ET & BitLenString
Call DoXor(FileText)
'根据上述随机数序列对FileText加密

    KeyString = FileText
Call Initialize(KeyString)
'根据上述的加密结果产生新的随机数序列
    FileText = BitLenString
Call DoXor(FileText)
'根据上述随机数序列对FileText加密，8位字符

Hash = FileText
  '8位字符送作HASH值
End Function

  '　4．加密过程实现

Public Sub Encrypt()
Dim sHead As String
Dim DH As String
Dim ET As String
Dim n As Long
Dim KeyString As String
Dim FileText  As String
Dim PasswordChar As String
Dim FileOldName As String
Dim FileNewName As String

PasswordChar = InputBox("加密口令:")
FileOldName = InputBox("明文文件名(.txt):")
FileNewName = InputBox("存放密文文件名(.txt):")
  Open FileOldName For Binary As #1
 'FileOldName必须为ascwII格式
    ET = Input(LOF(1), #1)
    Close #1
    DH = Hash(Date & Str(Timer))    '加时间戳
sHead = "[Secret]" & DH & Hash(DH & PasswordChar)
'产生明文的加密密钥，8＋8＋8位字符

    KeyString = sHead
Call Initialize(KeyString)
'根据明文的加密密钥产生随机数序列
    FileText = ET
DoXor FileText
 '根据上述随机数序列对明文加密
    ET = FileText

   Open FileNewName For Binary As #1
  '存为ascwII格式
   Put #1, , sHead + ET
   Close #1
   MsgBox "加密完成!"
End Sub

  '　5．解密过程实现

Public Sub Decrypt()
Dim sHead As String
Dim KeyString As String
Dim FileText As String
Dim DH As String
Dim ET As String
Dim TH As String
Dim n As Long
Dim PasswordChar, FileOldName As String
Dim FileNewName As String

PasswordChar = InputBox("解密口令:")
FileOldName = InputBox("密文文件名(.txt):")
FileNewName = InputBox("存放明文文件名(.txt):")

    Open FileOldName For Binary As #1
    sHead = Input(LOF(1), #1)
    Close #1
   
    DH = Mid(sHead, 9, 8)          '得到DH
    ET = Mid(sHead, 25, Len(sHead) - 24) '得到密文
    sHead = Mid(sHead, 1, 24)  '得到解密密钥
If InStr(sHead, Hash(DH & PasswordChar)) <> 17 Then
     '口令鉴别
        MsgBox "口令不正确!"
        Exit Sub
    End If
                  
    KeyString = sHead
Call Initialize(KeyString)
'用8＋8＋8位解密密钥产生解密随机数序列，
FileText = ET
    DoXor (FileText)   '根据上述随机数序列解密
    ET = FileText              '明文存入ET
Open FileNewName For Binary As #1
 '‘存为ascwII格式
    Put #1, , ET
    Close #1
    MsgBox "解密完成!"
End Sub


Private Sub Command1_Click()
Encrypt
End Sub

Private Sub Command2_Click()
Decrypt
End Sub