frmmain.frm

UUE加解密算法 UUE加解密算法

VERSION 5.00
Begin VB.Form frmMain 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "UUE 编解码算法演示"
   ClientHeight    =   3135
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   3975
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   3135
   ScaleWidth      =   3975
   StartUpPosition =   3  '窗口缺省
   Begin VB.Frame fraUUE 
      Caption         =   "编解码文件"
      Height          =   1215
      Index           =   1
      Left            =   0
      TabIndex        =   5
      Top             =   1920
      Width           =   3975
      Begin VB.TextBox txtSrc 
         Height          =   270
         Index           =   1
         Left            =   120
         OLEDropMode     =   1  'Manual
         TabIndex        =   9
         ToolTipText     =   "源文件(把文件拖放到这里)"
         Top             =   360
         Width           =   3015
      End
      Begin VB.TextBox txtDst 
         Height          =   270
         Index           =   1
         Left            =   120
         OLEDropMode     =   1  'Manual
         TabIndex        =   8
         ToolTipText     =   "UUE 格式文件(把文件拖放到这里)"
         Top             =   720
         Width           =   3015
      End
      Begin VB.CommandButton cmdConvert 
         Caption         =   "|∨"
         Height          =   660
         Index           =   2
         Left            =   3240
         TabIndex        =   7
         ToolTipText     =   "原文件转成 UUE 格式文件"
         Top             =   360
         Width           =   255
      End
      Begin VB.CommandButton cmdConvert 
         Caption         =   "∧|"
         Height          =   660
         Index           =   3
         Left            =   3600
         TabIndex        =   6
         ToolTipText     =   "UUE 格式文件转成原文件"
         Top             =   360
         Width           =   255
      End
   End
   Begin VB.Frame fraUUE 
      Caption         =   "编解码字符"
      Height          =   1815
      Index           =   0
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   3975
      Begin VB.CommandButton cmdStop 
         Cancel          =   -1  'True
         Caption         =   "停止"
         Height          =   615
         Left            =   1680
         TabIndex        =   10
         Top             =   960
         Width           =   615
      End
      Begin VB.CommandButton cmdConvert 
         Caption         =   "<-"
         Height          =   255
         Index           =   1
         Left            =   1680
         TabIndex        =   4
         ToolTipText     =   "UUE 反编码成原文本"
         Top             =   600
         Width           =   615
      End
      Begin VB.CommandButton cmdConvert 
         Caption         =   "->"
         Height          =   255
         Index           =   0
         Left            =   1680
         TabIndex        =   3
         ToolTipText     =   "UUE 编码原文本"
         Top             =   240
         Width           =   615
      End
      Begin VB.TextBox txtDst 
         Height          =   1455
         Index           =   0
         Left            =   2400
         MultiLine       =   -1  'True
         ScrollBars      =   3  'Both
         TabIndex        =   2
         Top             =   240
         Width           =   1455
      End
      Begin VB.TextBox txtSrc 
         Height          =   1455
         Index           =   0
         Left            =   120
         MultiLine       =   -1  'True
         ScrollBars      =   3  'Both
         TabIndex        =   1
         Text            =   "frmMain.frx":0000
         Top             =   240
         Width           =   1455
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'**************************************************************
'UUE 编码算法演示
'翻译+修改：TZWSOHO
'UUE 算法是 Unix 系统上常用的编码算法，通常用于邮件发送时附件的编码等
'由于这个程序仅作为演示版使用，我建议你不要尝试编码大于 200 KB 的文件
'否则你会看到 VB的局限性有多么的强大 -_-!!!
'
'该演示参考了网上的一篇 C 语言的技术文档：
'http://www.infosecurity.org.cn/content/websec/lm.htm
'
'作者的博客：http://blog.csdn.net/tzwsoho
'**************************************************************

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private bStop As Boolean

'/*Uuencode编码*/
'void Uue(unsigned char chasc[3], unsigned char chuue[4])
'/*
'chasc:   未编码的二进制代码
'chuue:   编码过的Uue代码
'*/
'{
'   int i, k = 2;
'   unsigned char t = NULL;
'   for(i = 0; i < 3; i++)
'   {
'       *(chuue + i) = *(chasc + i) >> k;
'       *(chuue + i) |= t;
'       if (*(chuue + i) == NULL) *(chuue + i) += 96;
'       else *(chuue + i) += 32;
'       t = *(chasc + i) << (8 - k);
'       t >>= 2;
'       k += 2;
'   }
'   *(chuue + 3) =* (chasc + 2) & 63;
'   if (*(chuue + 3) == NULL) *(chuue + 3) += 96;
'   else *(chuue + 3) += 32;
'}
'按每 3 字节编码成 4 个字节(由上面的 C 语言代码改写而成)
Private Sub EncodeUUEPart(sTmp() As Byte, dTmp() As Byte)
Dim i As Long, k As Long, t As Byte: k = 2
For i = 0 To 2
    dTmp(i) = sTmp(i) \ (2 ^ k)
    dTmp(i) = dTmp(i) Or t
    dTmp(i) = dTmp(i) + IIf(dTmp(i), 32, 96)
    t = sTmp(i) * (2 ^ (8 - k)) And &HFF
    t = t \ (2 ^ 2): k = k + 2
Next
dTmp(3) = sTmp(2) And 63
dTmp(3) = dTmp(3) + IIf(dTmp(3), 32, 96)
End Sub

'编码一个字节数组(按照网页上的说明写的)
Private Sub EncodeUUE(sArr() As Byte, dArr() As Byte)
'i 为剩余未读的字节数
'j 为当前读取的位置
Dim cLen As Long, strTmp As String
Dim i As Long, j As Long, k As Long
Dim sTmp(2) As Byte, dTmp(3) As Byte, ArrPart() As Byte
cLen = UBound(sArr)
Do
    Caption = FormatNumber(j / cLen * 100, 2) & "%": DoEvents
    If bStop Then Exit Do
    i = cLen - j + 1 '剩余的字节数
    k = IIf(i > 45, 45, i) '实际读取的字节数
    '每行首字符为 Chr$(实际读取的字节数 + 32)
    strTmp = strTmp & Chr$(32 + k)
    
    '原文：不足 45 个的用“NULL”补足为3的整数倍
    i = IIf(k < 45, k + (3 - k Mod 3) Mod 3, 45)
    ReDim ArrPart(i - 1): CopyMemory ArrPart(0), sArr(j), k
    
    For k = 0 To i / 3 - 1
        '每 3 个字节编码成 4 个字节
        CopyMemory sTmp(0), ArrPart(k * 3), 3
        Call EncodeUUEPart(sTmp, dTmp)
        '记录编码好的 4 字节
        strTmp = strTmp & StrConv(dTmp, vbUnicode)
    Next
    strTmp = strTmp & vbNewLine: j = j + i
Loop Until j > cLen
Caption = "UUE 编解码算法演示"
'写入目标字节数组
k = LenB(StrConv(strTmp, vbFromUnicode)): ReDim dArr(k - 3)
CopyMemory dArr(0), ByVal strTmp, k - 2 '除去末尾的 vbNewLine
End Sub

'/*Uuencode解码*/
'void unUue(unsigned char chuue[4], unsigned char chasc[3])
'/*
'chuue:   未解码的Uue代码
'chasc:   解码过的二进制代码
'*/
'{
'   int i, k = 2;
'   unsigned char t = NULL;
'   if (*chuue == 96) *chuue = NULL;
'   else *chuue -= 32;
'   for(i = 0; i < 3; i++)
'   {
'       *(chasc + i) = *(chuue + i) << k;
'       k += 2;
'       if (*(chuue + i + 1) == 96) *(chuue + i + 1) = NULL;
'       else *(chuue + i + 1) -= 32;
'       t = *(chuue + i + 1) >> (8 - k);
'       *(chasc + i) |= t;
'   }
'}
'按每 4 个字节解码成 3 个字节(由上面的 C 语言代码改写而成)
Private Sub DecodeUUEPart(dTmp() As Byte, sTmp() As Byte)
Dim i As Long, k As Long, t As Byte: k = 2
dTmp(0) = IIf(dTmp(0) = 96, 0, dTmp(0) - 32)
For i = 0 To 2
    sTmp(i) = dTmp(i) * (2 ^ k) And &HFF
    k = k + 2
    If dTmp(i + 1) = 96 Then
        dTmp(i + 1) = 0
    Else
        dTmp(i + 1) = dTmp(i + 1) - 32
    End If
    t = dTmp(i + 1) \ (2 ^ (8 - k))
    sTmp(i) = sTmp(i) Or t
Next
End Sub

'解码字节数组
Private Sub DecodeUUE(dArr() As Byte, sArr() As Byte, cLen As Long)
Dim i As Long, j As Long
Dim sTmp(2) As Byte, dTmp(3) As Byte
j = UBound(dArr) + 1: j = j \ 4 + Sgn(j Mod 4) - 1
For i = 0 To j
    Caption = FormatNumber(i / j * 100, 2) & "%": DoEvents
    If bStop Then Exit For
    CopyMemory dTmp(0), dArr(i * 4), 4
    Call DecodeUUEPart(dTmp, sTmp)
    ReDim Preserve sArr(i * 3 + 2)
    CopyMemory sArr(i * 3), sTmp(0), 3
Next
ReDim Preserve sArr(cLen - 1)
Caption = "UUE 编解码算法演示"
End Sub

Private Sub cmdConvert_Click(Index As Integer)
On Error GoTo er
Dim FrFl As Integer
Dim i As Long, lTxt As Long
Dim sArr() As Byte, dArr() As Byte
Dim strTmp As String, sTA() As String
Select Case Index
    Case 0 '编码文本
        lTxt = LenB(StrConv(txtSrc(0).Text, vbFromUnicode))
        ReDim sArr(lTxt - 1): CopyMemory sArr(0), ByVal txtSrc(0).Text, lTxt
        bStop = False: Call EncodeUUE(sArr, dArr)
        
        txtDst(0).Text = StrConv(dArr, vbUnicode)
    Case 1 '解码文本
        sTA = Split(txtDst(0).Text, vbNewLine)
        For i = 1 To UBound(sTA)
            If Len(sTA(i)) Then
                If (InStr(1, sTA(i), "begin ") = 0) And _
                        (InStrRev(sTA(i), "end") = 0) Then
                    lTxt = lTxt + Asc(sTA(i)) - 32
                    strTmp = strTmp & Mid$(sTA(i), 2) '去掉首字符
                End If
            End If
        Next
        i = Len(strTmp): ReDim dArr(i - 1)
        CopyMemory dArr(0), ByVal strTmp, i
        bStop = False: Call DecodeUUE(dArr, sArr, lTxt)
        
        txtSrc(0).Text = StrConv(sArr, vbUnicode)
    Case 2 '编码文件
        If Len(Dir(txtSrc(1).Text, 7)) > 0 Then
            If FileLen(txtSrc(1).Text) = 0 Then
                MsgBox "不能编码空数据的文件！", vbCritical, "错误"
                Exit Sub
            End If
                
            '打开源文件
            FrFl = FreeFile
            Open txtSrc(1).Text For Binary Access Read As #FrFl
            ReDim sArr(LOF(FrFl) - 1)
            Get #FrFl, , sArr
            Close #FrFl
            
            '编码数据
            bStop = False: Call EncodeUUE(sArr, dArr)
            
            '写入目标 UUE 文件
            FrFl = FreeFile
            Open txtDst(1).Text For Output As #FrFl
            Print #FrFl, vbNewLine; "begin 644 "; Mid$(txtSrc(1).Text, InStrRev(txtSrc(1).Text, "\") + 1)
            Print #FrFl, StrConv(dArr, vbUnicode)
            Print #FrFl, "end"; vbNewLine
            Close #FrFl
            
            MsgBox "成功生成 UUE 格式文件！", vbInformation, "成功"
        End If
    Case 3 '解码文件
        If Len(Dir(txtDst(1).Text, 7)) Then
            
            '读取 UUE 文件
            FrFl = FreeFile
            Open txtDst(1).Text For Binary Access Read As #FrFl
            ReDim dArr(LOF(FrFl) - 1)
            Get #FrFl, , dArr
            Close #FrFl
            
            '解码数据
            sTA = Split(StrConv(dArr, vbUnicode), vbNewLine)
            For i = 1 To UBound(sTA)
                If Len(sTA(i)) Then
                    If (InStr(1, sTA(i), "begin ") = 0) And _
                        (InStrRev(sTA(i), "end") = 0) Then
                        lTxt = lTxt + Asc(sTA(i)) - 32
                        strTmp = strTmp & Mid$(sTA(i), 2) '去掉首字符
                    End If
                End If
            Next
            i = Len(strTmp): ReDim dArr(i - 1)
            CopyMemory dArr(0), ByVal strTmp, i
            bStop = False: Call DecodeUUE(dArr, sArr, lTxt)
            
            FrFl = FreeFile
            Open txtSrc(1).Text For Binary Access Write As #FrFl
            Put #FrFl, , sArr
            Close #FrFl
            
            MsgBox "成功将 UUE 格式文件还原！", vbInformation, "成功"
        End If
End Select
Exit Sub
er:
Close
MsgBox "发生错误：" & Err.Description, vbCritical, "错误"
End Sub

Private Sub cmdStop_Click()
bStop = True
End Sub

Private Sub Form_Load()
Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2
End Sub

Private Sub txtDst_OLEDragDrop(Index As Integer, Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim FrFl As Integer, sTmp As String
If Data.GetFormat(vbCFFiles) Then
    If (Data.Files.Count = 1) And _
        (UCase$(Mid$(Data.Files(1), InStrRev(Data.Files(1), ".") + 1)) = "UUE") Then
        txtDst(1).Text = Data.Files(1): FrFl = FreeFile
        Open txtDst(1).Text For Input As #FrFl
        Do Until EOF(FrFl)
            Line Input #FrFl, sTmp
            If InStr(1, sTmp, "begin") Then
                txtSrc(1).Text = Left$(txtDst(1).Text, _
                                InStrRev(txtDst(1).Text, "\")) & _
                                Split(sTmp, " ", 3)(2)
                Exit Do
            End If
        Loop
        Close #FrFl
    End If
End If
End Sub

Private Sub txtSrc_OLEDragDrop(Index As Integer, Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
If Data.GetFormat(vbCFFiles) Then
    If Data.Files.Count = 1 Then
        txtSrc(1).Text = Data.Files(1)
        txtDst(1).Text = Left$(Data.Files(1), InStrRev(Data.Files(1), ".")) & "UUE"
    End If
End If
End Sub