megamail.bas

e-maill文件加密程序完整的源代码

Attribute VB_Name = "Mail21"
' StealthMail 2.1/RTF (High security version)
' CBC mode E-mail/file encryption program
' Copyright Patterson Programming, 1996-1999
' Contains registered material

' This version implements the LeapFrog2 cipher
' which is NOT compatible with LeapFrog

'WARNING: This is an original work of authorship; however, patents
'         might or might not exist that apply to certain sections.
'         In addition, export from the U.S. of this material
'         may be restricted. The author disclaims any and all
'         liability arising from unauthorized use of this material.


DefInt A-Z
Public Const LeapFrogBlockLen = 8
Public Const Search$ = "ZIP*JPG*JPE*GIF*CAB*ARJ*ARC*LZH*PAK*" & _
                       ".GZ*TAR*ICE*ZOO*HPK*PGP*ENC"

Const LeapFrogRounds% = 8
Const CBC = 1
Public Const BUFFERSIZE = 4096  '* MUST be a multiple of BlockLen *
Const HEADERLEN = 8

Global SourcePath$, OutPutPath$, DrivePath$, DoFile$
Global EncInPath$, EncOutPath$, DecInPath$, DecOutPath$, SetPath$
Global filename$, fileSpec$, process%, CipherMode%, BlockLen%
Global ClipText As String, MemoText As String, MasterPwd(31) As Byte
Global verify%, Ppos%, password(31) As Byte, password2(31) As Byte
Global MasterPwdFlag As Integer, KeyArray() As Byte
Global CryptBuffer() As Byte, BufferPointer&, SelectKey As Integer
Global MemoFlag As Integer, FileCancel As Integer
Global FBR(1 To 16) As Integer, Pre_FBR(1 To 16) As Integer
Global Salt(LeapFrogBlockLen) As Byte, WithSalt%, Backup%
Global FontNameIndex%, FontPointsIndex%, KeyCount As Byte
Global KeysFound As Integer, AvoidVerify As Integer, MsgRet%
Global PwdBusy%, NotFlag%, PwdLocked%, PwdMark As Long

'* these global arrays hold the in/out data for Radix64
'* must include space for padding and EOL characters
Global ch() As Byte  '* ENcoded data buffer *
Global bin() As Byte  '* DEcoded data buffer *

'* these arrays are used by Compress.BAS
Global InBuffer() As Byte, OutBuffer() As Byte
Global DataLen&, CompFlag As Integer

Dim SK(LeapFrogRounds%, LeapFrogBlockLen - 1) As Integer
Dim A1%(255), A2%(255), A3%(255), A4%(255)
Dim A5%(255), A6%(255), A7%(255), A8%(255)
Dim SmallFilesFound%, ReadOnlyFound%
Dim initkey%(0 To 31), k%(0 To 23), LongKey%(0 To 255), ByteNumber&

Dim Sig1 As Long, Sig2 As Long


Sub Main()

    If App.PrevInstance = -1 Then
        MsgBox "Program already running!"
        End
    End If

    '* copyright notice
    Notice.Show 1

    InitFolderPaths

    For i% = 0 To 31: MasterPwd(i%) = 32: Next
    Ppos% = 0

    SelectKey = -1
    CipherMode% = CBC

    Sig1 = &H4F6A12C4
    Sig2 = &H5610FF45

    Open App.Path & "\KeyFile.DAT" For Binary Access _
                                        Read Write As #5
    KeysFound = 0
    If LOF(5) >= 72 Then
        KeysFound = -1
    End If
    Close
    Backup% = 0

    '* main menu
    PwdLocked% = -1
    MainForm.Show

End Sub 'Main


Sub CleanUp()

    Erase CryptBuffer
    Erase SK%, A1%, A2%, A3%, A4%, A5%, A6%, A7%, A8%
    For i% = 0 To 31: password(i%) = 32: Next
    For i% = 0 To 31: MasterPwd(i%) = 32: Next
    For i% = 0 To KeyCount - 1
        For j% = 0 To 71
            KeyArray(j%, i%) = 0
        Next
    Next

End Sub


Sub InitFolderPaths()

    On Local Error GoTo Ignore

    CurPath$ = CurDir$
    If Right$(CurPath$, 1) <> "\" Then
        CurPath$ = CurPath$ + "\"
    End If

    '* defaults
    EncInPath$ = CurPath$
    EncOutPath$ = CurPath$
    DecInPath$ = CurPath$
    DecOutPath$ = CurPath$
    FontNameIndex% = 1
    FontPointsIndex% = 2

    If Dir$(App.Path & "\Folders.DAT") <> "" Then
        fn% = FreeFile
        Open App.Path & "\Folders.DAT" For Input Access Read As fn%
        If LOF(fn%) <> 0 Then
            Input #fn%, EncInPath$
            Input #fn%, EncOutPath$
            Input #fn%, DecInPath$
            Input #fn%, DecOutPath$
            Input #fn%, FontNameIndex%
            Input #fn%, FontPointsIndex%
        End If
    End If
    Close
    Exit Sub

Ignore:
    Resume Next
End Sub


Static Sub DoProcess()

    On Error GoTo error_exit

    '* change mousepointer
    MainForm.Enabled = -1
    MainForm.MousePointer = 11
    DoEvents
    MainForm.Enabled = 0

    ReadOnlyError% = 0
    FoundSmallFiles% = 0
    ReadOnlyFound% = 0

    If process% > 0 Then

        IsFileError% = 0
        fileSpec$ = Dir$(SourcePath$ + DoFile$)
        Open SourcePath$ + fileSpec$ For Binary Access Read As #1
        If IsFileError% Then
            MsgBox1 "Path/File Access Error", 0, "Abort"
            GoTo Abort
        End If

        '* set length of data to process
        DataLen& = LOF(1)

        '* file size must be >= to block size
        If DataLen& < BlockLen% Then
            FoundSmallFiles% = -1
            GoTo SmallFilesExit
        End If

        If process% = 2 Then  '* If Decrypt *
            If Not GetHeader() Then
                MsgBox1 "File is Not StealthMail Encrypted", 0, "Abort"
                GoTo Abort
            End If
        End If

        GetFilename% = 0
        IsFileError% = 0
        If process% = 1 Then  '* If Encrypt *
            fileSpec2$ = DoFile$ & ".ENC"
            If Dir$(OutPutPath$ & fileSpec2$) <> "" Then
                If IsFileError% Then
                    GetFilename% = -1
                    GoTo GetFile
                End If
                Mv% = MsgBox2("Filename Already Exists, Continue?", _
                                                           260, "")
                If MasterPwdFlag = 0 Then GoTo Abort
                If Mv% <> 6 Then
                    GetFilename% = -1
                    GoTo GetFile
                Else
                    IsFileError% = 0
                    Kill (OutPutPath$ + fileSpec2$)
                    If ReadOnlyError% = -1 Then
                        ReadOnlyFound% = -1
                        GoTo ReadOnlyExit
                    ElseIf IsFileError% Then
                        GetFilename% = -1
                        GoTo GetFile
                    End If
                End If
            End If
        End If
        If process% = 2 Then  '* If Decrypt *
            If Right$(DoFile$, 4) = ".ENC" Then
                fileSpec2$ = Left$(DoFile$, Len(DoFile$) - 4)
                If Dir$(OutPutPath$ & fileSpec2$) <> "" Then
                    MsgBox1 "File Already Exists", 0, "Abort"
                    GoTo Abort
                End If
            Else
                GetFilename% = -1
                GoTo GetFile
            End If

            If IsFileError% Then
                GetFilename% = -1
                GoTo GetFile
            End If
        End If
GetFile:
        If GetFilename% Then
            fileSpec2$ = InputBox2$("Please Enter OutPut Filename:")

            If MasterPwdFlag = 0 Then GoTo Abort
            If fileSpec2$ = "" Then
                MsgBox1 "Invalid Filename", 0, "Abort"
                GoTo Abort
            End If
            If Dir$(OutPutPath$ & fileSpec2$) <> "" Then
                MsgBox1 "File Already Exists", 0, "Abort"
                GoTo Abort
            End If
        End If

        If MasterPwdFlag = 0 Then GoTo Abort
        IsFileError% = 0
        Open OutPutPath$ + fileSpec2$ For Binary Access Write As #2
        If IsFileError% Then
            MsgBox1 "Can't Use That Filename", 0, "Abort"
            GoTo Abort
        End If

        LockPwd
        Select Case process%
            Case 1
                EncryptFileCBC
            Case 2
                DecryptFileCBC
         End Select

        filesProcessed% = filesProcessed% + 1

        previousFile$ = SourcePath$ + DoFile$
        previousProcess% = process%

        UnlockPwd

ReadOnlyExit:

        If ReadOnlyFound% = -1 Then
            Beep
            MsgBox1 "Read-Only Target File", 0, "Abort"
            GoTo Abort
        End If

SmallFilesExit:

        If FoundSmallFiles% = -1 Then
            Beep
            MsgBox1 "File Too Small To Process", 0, "Warning"
            GoTo Abort
        End If

        MsgBox1 "File Processed OK", 0, "Report"
        filename$ = ""

Abort:
        process% = 0
        MainForm.MousePointer = 0
        '* close this file
        Close
        FileForm.FileList.Refresh

    End If  'process > 0

    Exit Sub 'DoProcess

error_exit:

    IsFileError% = -1

    If Err = 75 Then
        '* can't remove Read-Only file
        ReadOnlyError% = -1
        Resume Next

    Else
        Resume Next
    End If

End Sub 'DoProcess


Private Sub EncryptFileCBC()

    On Error GoTo 0

    ReDim SaveSalt(BlockLen% - 1) As Byte

    '* clear the feedback register
    For i% = 1 To BlockLen%: FBR(i%) = 0: Next

    '* calculate variables
    LastFullBuffer& = DataLen& \ BUFFERSIZE
    ShortBufferLen% = DataLen& Mod BUFFERSIZE
    ShortBlockLen% = DataLen& Mod BlockLen%

    '* get Salt from the data
    If DataLen& > 4096 Then
        SaltLen& = 4096
    Else
        SaltLen& = DataLen&
    End If
    ReDim CryptBuffer(SaltLen& - 1)
    Get #1, , CryptBuffer
    GetTS i1%, i2%, i3%, i4%, i5%, i6%
    CryptBuffer(0) = CryptBuffer(0) Xor i1%
    CryptBuffer(1) = CryptBuffer(1) Xor i2%
    GetSalt SaltLen&
    Salt(0) = Salt(0) Xor i1%
    Salt(1) = Salt(1) Xor i2%
    For i% = 0 To (BlockLen% - 1)
        SaveSalt(i%) = Salt(i%)
    Next
    '* use cipher as Hash Function
    ReSalt

    '* re-adjust the read/write buffer
    ReDim CryptBuffer(BUFFERSIZE - 1)
    Seek #1, 1

    WithSalt% = -1
    CryptInit

    For i% = 1 To BlockLen%: FBR(i%) = 0: Next

    If CompFlag Then
        LZCompFile 1, 2
    Else

    '* if there is a boundary condition, do this
    If ShortBufferLen% > 0 And ShortBufferLen% < BlockLen% Then
        LastFullBuffer& = LastFullBuffer& - 1
        ShortBufferLen% = ShortBlockLen% + BUFFERSIZE
    End If

    '* process chunks of data equal to BUFFERSIZE
    NumberOfBlocks% = (BUFFERSIZE \ BlockLen%)
    For BufferNumber& = 1 To LastFullBuffer&
        BufferPointer& = 0
        Get #1, , CryptBuffer
        SelectCipher (NumberOfBlocks%)
        Put #2, , CryptBuffer
    Next

    If ShortBufferLen% > 0 Then

        ReDim CryptBuffer(ShortBufferLen% - 1)
        Get #1, , CryptBuffer
        '* process the last buffer (less shortblock)
        BufferPointer& = 0
        NumberOfBlocks% = (ShortBufferLen% \ BlockLen%)
        SelectCipher (NumberOfBlocks%)

        If ShortBlockLen% > 0 Then
            '* process the shortblock
            BufferPointer& = ShortBufferLen% - BlockLen%
            For i% = 1 To BlockLen%: FBR(i%) = 0: Next
            SelectCipher (1)
        End If

        '* write the shortbuffer
        Put #2, , CryptBuffer

    End If

    End If 'CompFlag

    '* encrypt the Salt (no feedback)
    CryptInit
    For i% = 0 To (BlockLen% - 1)
        CryptBuffer(i%) = SaveSalt(i%)
    Next
    For i% = 1 To BlockLen%: FBR(i%) = 0: Next
    BufferPointer& = 0
    SelectCipher (1)
    For i% = 0 To (BlockLen% - 1)
        Salt(i%) = CryptBuffer(i%)
    Next

    '* write signature and Salt
    PutHeader

    MainForm.Enabled = -1

End Sub


Private Sub DecryptFileCBC()

    On Error GoTo 0

    ReDim SaveFBR(1 To BlockLen%) As Integer

    '* adjust the read/write buffer
    ReDim CryptBuffer(BUFFERSIZE - 1)

    '* decrypt the Salt
    For i% = 0 To (BlockLen% - 1)
        CryptBuffer(i%) = Salt(i%)
    Next
    For i% = 1 To BlockLen%: Pre_FBR(i%) = 0: Next
    BufferPointer& = 0
    CryptInit
    SelectCipher (1)
    For i% = 0 To (BlockLen% - 1)
        Salt(i%) = CryptBuffer(i%)
    Next
    ReSalt

    WithSalt% = -1
    CryptInit

    '* clear the feedback register
    For i% = 1 To BlockLen%: Pre_FBR(i%) = 0: Next

    '* reposition file
    Seek #1, 1
    DataLen& = DataLen& - HEADERLEN - 8

    If CompFlag Then
        LZDecompFile 1, 2
    Else

    '* calculate variables
    LastFullBuffer& = DataLen& \ BUFFERSIZE
    ShortBufferLen% = DataLen& Mod BUFFERSIZE
    ShortBlockLen% = DataLen& Mod BlockLen%

    '* if there is a boundary condition, do this
    If ShortBufferLen% > 0 And ShortBufferLen% < BlockLen% Then
        LastFullBuffer& = LastFullBuffer& - 1
        ShortBufferLen% = ShortBlockLen% + BUFFERSIZE
    End If

    '* process chunks of data equal to BUFFERSIZE
    NumberOfBlocks% = (BUFFERSIZE \ BlockLen%)
    For BufferNumber& = 1 To LastFullBuffer&
        BufferPointer& = 0
        Get #1, , CryptBuffer