des.frm

本程序封装了一个加解密模块. 使用时直接调用其中的函数即可.

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form Form1 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "DES加解密 - PAN工作室"
   ClientHeight    =   2505
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   7650
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   ScaleHeight     =   2505
   ScaleWidth      =   7650
   StartUpPosition =   3  '窗口缺省
   Begin MSComDlg.CommonDialog CDl 
      Left            =   3420
      Top             =   2880
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.PictureBox Pic 
      AutoRedraw      =   -1  'True
      Height          =   435
      Left            =   1500
      ScaleHeight     =   25
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   401
      TabIndex        =   13
      Top             =   1980
      Width           =   6075
   End
   Begin VB.CommandButton Command1 
      Caption         =   "开始(&B)"
      Height          =   435
      Left            =   120
      TabIndex        =   9
      Top             =   1980
      Width           =   1275
   End
   Begin VB.Frame Frame1 
      Height          =   1875
      Left            =   60
      TabIndex        =   0
      Top             =   0
      Width           =   7515
      Begin VB.OptionButton Option2 
         Caption         =   "解密"
         Height          =   315
         Left            =   4860
         TabIndex        =   3
         Top             =   300
         Width           =   795
      End
      Begin VB.OptionButton Option1 
         Caption         =   "加密"
         Height          =   315
         Left            =   4020
         TabIndex        =   2
         Top             =   300
         Value           =   -1  'True
         Width           =   855
      End
      Begin VB.CommandButton Command3 
         Caption         =   "..."
         Height          =   315
         Left            =   7020
         TabIndex        =   8
         ToolTipText     =   "保存目标文件"
         Top             =   1320
         Width           =   435
      End
      Begin VB.CommandButton Command2 
         Caption         =   "..."
         Height          =   315
         Left            =   7020
         TabIndex        =   6
         ToolTipText     =   "打开源文件"
         Top             =   840
         Width           =   435
      End
      Begin VB.CheckBox Check1 
         Caption         =   "备份源文件"
         Enabled         =   0   'False
         Height          =   315
         Left            =   5760
         TabIndex        =   4
         Top             =   300
         Value           =   1  'Checked
         Width           =   1335
      End
      Begin VB.TextBox TxtS 
         Height          =   375
         Left            =   1080
         TabIndex        =   5
         Top             =   780
         Width           =   5895
      End
      Begin VB.TextBox TxtT 
         Height          =   375
         Left            =   1080
         TabIndex        =   7
         Top             =   1260
         Width           =   5895
      End
      Begin VB.TextBox TxtK 
         Height          =   375
         Left            =   1080
         TabIndex        =   1
         Top             =   300
         Width           =   2775
      End
      Begin VB.Label Label1 
         Caption         =   "源文件:"
         Height          =   255
         Left            =   120
         TabIndex        =   12
         Top             =   840
         Width           =   975
      End
      Begin VB.Label Label2 
         Caption         =   "目标文件:"
         Height          =   315
         Left            =   120
         TabIndex        =   11
         Top             =   1320
         Width           =   975
      End
      Begin VB.Label Label3 
         Caption         =   "密码:"
         Height          =   255
         Left            =   120
         TabIndex        =   10
         Top             =   360
         Width           =   975
      End
   End
   Begin VB.CommandButton Command4 
      Caption         =   "暂停"
      Height          =   435
      Left            =   120
      TabIndex        =   14
      Top             =   1980
      Visible         =   0   'False
      Width           =   615
   End
   Begin VB.CommandButton Command5 
      Caption         =   "停止"
      Height          =   435
      Left            =   780
      TabIndex        =   15
      Top             =   1980
      Visible         =   0   'False
      Width           =   615
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'DES加解密算法实现 vb版 v1.0
'
'作者: 潘炳镇
'日期: 2004年07月11日
'
'刚写完的DES加解密程序,不足之处请多多指正.
'由于DES是用块加密的,而每个文件的长度又不
'能保证是8的倍数.
'所以本程序在文件的头部加一个标志,来记录此
'文件最后一块的长度.

Dim NoEnoughLong As Boolean
Dim IsStop As Boolean
Private Sub Command2_Click()
CDl.CancelError = True
On Error GoTo ErrHandler
CDl.Filter = "All Files(*.*)|*.*"
CDl.Flags = cdlOFNExplorer Or cdlOFNFileMustExist Or cdlOFNHideReadOnly Or cdlOFNNoValidate Or cdlOFNNoLongNames
CDl.ShowOpen
TxtS.Text = CDl.FileName

If IsDESFile(CDl.FileName) = True Then
'如果是加密的文件,则变为解密方式
Option1.Value = False
Option2.Value = True
Else
    If Option2.Value = True Then
    MsgBox ("文件 " + CDl.FileName + " 不是DES加密的文件...")
    
    TxtS = ""
    Exit Sub
    End If
End If

If Option1.Value = True Then
    If Check1.Value = 1 Then
    TxtT.Text = GetFileName(CDl.FileName) + "_DES." + GetFileKZ(CDl.FileName)
    Else
    TxtT.Text = CDl.FileName
    End If
Else

    If IsDESFile(CDl.FileName) = False Then
    TxtT.Text = GetFileName(CDl.FileName) + "_De." + GetFileKZ(CDl.FileName)
    Else
        If Mid(GetFileName(CDl.FileName), Len(GetFileName(CDl.FileName)) - 3, 4) = "_DES" Then
        TxtT = Mid(GetFileName(CDl.FileName), 1, Len(GetFileName(CDl.FileName)) - 4) + "." + GetFileKZ(CDl.FileName)
        End If
    End If

End If

Exit Sub
ErrHandler:
End Sub

Private Sub Command3_Click()
CDl.CancelError = True
On Error GoTo ErrHandler
CDl.Filter = "All Files(*.*)|*.*"
CDl.Flags = cdlOFNExplorer Or cdlOFNFileMustExist Or cdlOFNHideReadOnly Or cdlOFNNoValidate Or cdlOFNNoLongNames
CDl.ShowSave
TxtT.Text = CDl.FileName
Exit Sub
ErrHandler:
End Sub


Private Sub Command1_Click()
Dim sData(7) As Byte
Dim tData(7) As Byte
Dim tProgram As Long
Dim FileLong As Long
Dim FileSee As Long
Dim Files As Long
Dim NoEnough(7) As Byte
Dim sKey As String
Dim BufferFile(262144, 8) As Byte
Dim BufferNum As Long

'源文件是否存在
If Dir(TxtS) = "" Then
MsgBox ("源文件不存在,或者是文件具有稳藏和只读属性.请打开一个文件...")
Exit Sub
End If


NoEnough(0) = Asc("P"): NoEnough(1) = Asc("A"): NoEnough(2) = Asc("N"): NoEnough(3) = Asc(" ")
NoEnough(4) = Asc("D"): NoEnough(5) = Asc("E"): NoEnough(6) = Asc("S"): NoEnough(7) = 0

If TxtS = "" Then
MsgBox ("请打开一个要加密的文件...")
Exit Sub
End If

If TxtT = "" Then
MsgBox ("请选定保存加密后文件的文件夹...")
Exit Sub
End If

If TxtK = "" Then
MsgBox ("请输入密码. 注:前十六位有效")
Exit Sub
End If

Command1.Visible = False
Command4.Visible = True
Command5.Visible = True
Command2.Enabled = False
Command3.Enabled = False
Option1.Enabled = False: Option2.Enabled = False

'打密匙变为8位密匙
sKey = TxtK
If Len(sKey) > 8 Then
sKey = ChangeKey(sKey)
End If


'打开文件
FileSee = 1
Open TxtS For Binary As #1
Open TxtT For Binary As #2
FileLong = LOF(1)

'文件分成8位的块的块数
If FileLong / 8 <> FileLong \ 8 Then
Files = FileLong \ 8 + 2
NoEnoughLong = True
NoEnough(7) = FileLong - (Files - 2) * 8
Else
    If Option1.Value = True Then
    Files = FileLong \ 8 + 1
    Else
    Files = FileLong \ 8
    End If
    
NoEnoughLong = False
End If

For i = 1 To Files

'读取文件
    If Option1.Value = True Then
        
         If i <> 1 Then
         Get #1, FileSee - 8, sData()
         End If

    Else
    Get #1, FileSee, sData()
        If i = 1 Then
           If sData(0) = Asc("P") And sData(1) = Asc("A") And sData(2) = Asc("N") And sData(3) = Asc(" ") And sData(4) = Asc("D") And sData(5) = Asc("E") And sData(6) = Asc("S") Then
           NoEnough(7) = sData(7)
               If NoEnough(7) = 0 Then
                NoEnoughLong = False
                Else
                NoEnoughLong = True
                End If
           End If
        End If
    End If
'加密
If Option1.Value = True Then

    If i = 1 Then
        For o = 0 To 7
        tData(o) = NoEnough(o)
        Next o
    Else
        
    DESEn sData(), sKey, tData()
    End If

Else
'解密
    If i <> 1 Then
    DESDe sData(), sKey, tData()
    End If
End If

'保存文件
If Option1.Value = True Then
Put #2, FileSee, tData()
Else

    If i <> 1 Then
        If i <= Files - 1 Then
        Put #2, FileSee - 8, tData()
        Else

            If NoEnoughLong = True Then
            For o = 0 To NoEnough(7) - 1
            Put #2, FileSee - 8 + o, tData(o)
            Next o
            Else
            Put #2, FileSee - 8, tData()
            End If

        End If

    End If
End If

FileSee = FileSee + 8   '移动指针
Program (24 * i \ Files)
DoEvents

If IsStop = True Then   '停止加解密
Exit For
End If

Next i

Close #1
Close #2

If IsStop = False Then

    If Option1.Value = True Then
    MsgBox ("加密完成...")
    Else
    MsgBox ("解密完成...")
    End If

Else

    If Option1.Value = True Then
    MsgBox ("加密被用户终止...")
    Else
    MsgBox ("解密被用户终止...")
    End If

End If

Pic.Cls
Option1.Enabled = True: Option2.Enabled = True
Command1.Visible = True
Command4.Visible = False
Command5.Visible = False
Command2.Enabled = True
Command3.Enabled = True

IsStop = False
End Sub


Function Program(Pro As Integer)
'显示进度
For i = 0 To Pro
Pic.Line (1 + i * 16, 1)-(15 + i * 16, 23), QBColor(3), BF
Next i
End Function

Private Sub Command4_Click()
MsgBox ("暂无此功能...")
End Sub

Private Sub Command5_Click()
IsStop = True
End Sub

Private Sub Form_Load()
Initialize  '初始化
End Sub

Function GetFileName(FileName As String) As String
'去除扩展文件名
For i = Len(FileName) To 1 Step -1
If Mid(FileName, i, 1) = "." Then
GetFileName = Mid(FileName, 1, i - 1)
Exit Function
End If
Next i
End Function

Function GetFileKZ(FileName As String) As String
For i = Len(FileName) To 1 Step -1
If Mid(FileName, i, 1) = "." Then
GetFileKZ = Mid(FileName, i + 1, Len(FileName) - i)
Exit Function
End If
Next i

End Function

Function IsDESFile(FileName As String) As Boolean
'是否为DES加密的文件
Dim dTemp(7) As Byte

If FileName = "" Then
IsDESFile = False
Exit Function
End If

Open FileName For Binary As #1
Get #1, 1, dTemp()
Close #1
If dTemp(0) = Asc("P") And dTemp(1) = Asc("A") And dTemp(2) = Asc("N") And dTemp(3) = Asc(" ") And dTemp(4) = Asc("D") And dTemp(5) = Asc("E") And dTemp(6) = Asc("S") Then
IsDESFile = True
Else
IsDESFile = False
End If
End Function

Private Sub Option1_Click()

If IsDESFile(TxtS) = True Then
MsgBox ("文件 " + TxtS + " 己是加密和文件,这将进行重复加密...")
End If
End Sub

Function ChangeKey(Key As String) As String
Dim dTemp(7) As Byte
Dim tKey As String
Dim tRe(7) As Byte

If Len(Key) > 16 Then
Key = Mid(Key, 1, 16)
End If

For i = 0 To 7
dTemp(i) = Asc(Mid(Key, i + 1, 1))
Next i

tKey = Mid(Key, i + 1, Len(Key) - 8)
DESEn dTemp, tKey, tRe()

For i = 0 To 7
ChangeKey = ChangeKey + Chr(tRe(i))
Next i

End Function