megamail.bas

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

End Sub


Sub PackPassword()

  For i% = 0 To 31
      initkey%(i%) = password(i%) - 32
  Next

  '* pack 32 ASCII character password into real 192-bit key (24 bytes)
  k%(0) = initkey%(0) Or ((initkey%(1) And &H3) * 64)
  k%(1) = ((initkey%(1) And &H3C) \ 4) Or ((initkey%(2) And &HF) * 16)
  k%(2) = ((initkey%(2) And &H30) \ 16) Or (initkey%(3) * 4)
  k%(3) = initkey%(4) Or ((initkey%(5) And &H3) * 64)
  k%(4) = ((initkey%(5) And &H3C) \ 4) Or ((initkey%(6) And &HF) * 16)
  k%(5) = ((initkey%(6) And &H30) \ 16) Or (initkey%(7) * 4)
  k%(6) = initkey%(8) Or ((initkey%(9) And &H3) * 64)
  k%(7) = ((initkey%(9) And &H3C) \ 4) Or ((initkey%(10) And &HF) * 16)
  k%(8) = ((initkey%(10) And &H30) \ 16) Or (initkey%(11) * 4)
  k%(9) = initkey%(12) Or ((initkey%(13) And &H3) * 64)
  k%(10) = ((initkey%(13) And &H3C) \ 4) Or ((initkey%(14) And &HF) * 16)
  k%(11) = ((initkey%(14) And &H30) \ 16) Or (initkey%(15) * 4)
  k%(12) = initkey%(16) Or ((initkey%(17) And &H3) * 64)
  k%(13) = ((initkey%(17) And &H3C) \ 4) Or ((initkey%(18) And &HF) * 16)
  k%(14) = ((initkey%(18) And &H30) \ 16) Or (initkey%(19) * 4)
  k%(15) = initkey%(20) Or ((initkey%(21) And &H3) * 64)
  k%(16) = ((initkey%(21) And &H3C) \ 4) Or ((initkey%(22) And &HF) * 16)
  k%(17) = ((initkey%(22) And &H30) \ 16) Or (initkey%(23) * 4)
  k%(18) = initkey%(24) Or ((initkey%(25) And &H3) * 64)
  k%(19) = ((initkey%(25) And &H3C) \ 4) Or ((initkey%(26) And &HF) * 16)
  k%(20) = ((initkey%(26) And &H30) \ 16) Or (initkey%(27) * 4)
  k%(21) = initkey%(28) Or ((initkey%(29) And &H3) * 64)
  k%(22) = ((initkey%(29) And &H3C) \ 4) Or ((initkey%(30) And &HF) * 16)
  k%(23) = ((initkey%(30) And &H30) \ 16) Or (initkey%(31) * 4)

End Sub


Sub EncryptClip()

    ReDim SaveSalt(BlockLen% - 1) As Byte

    '* ClipText As String is GLOBAL

    ClipText = MemoText
    ClipTextLen& = Len(ClipText)
    ChkTextLen& = Len(MemoForm.MemoBox.Text)
    Unload MemoForm
    DoEvents

    If ChkTextLen& > 65535 Then
        MsgBox1 "Message Too Large, Send Graphics as Attachment", 0, ""
        MemoFlag = 0  '* correct the caller *
        Exit Sub
    End If
    If ChkTextLen& = 0 Then
        MsgBox1 "There is no TEXT to Encrypt", 0, ""
        MemoFlag = 0  '* correct the caller *
        Exit Sub
    ElseIf ClipTextLen& < BlockLen% Then
        ClipText = ClipText + Space$(BlockLen% - ClipTextLen&)
        ClipTextLen& = BlockLen%
    End If

    '* get Salt from the data
    If ClipTextLen& > 16384 Then
        SaltLen& = 16384
    Else
        SaltLen& = ClipTextLen&
    End If
    ReDim CryptBuffer(SaltLen& - 1)
    For p& = 0 To SaltLen& - 1
        CryptBuffer(p&) = Asc(Mid$(ClipText, p& + 1, 1))
    Next
    GetSalt SaltLen&
    For i% = 0 To (BlockLen% - 1)
        SaveSalt(i%) = Salt(i%)
    Next
    '* use cipher as Hash Function
    ReSalt

    MaxLen& = (ClipTextLen& + (ClipTextLen& \ 8)) + BlockLen%
    ReDim InBuffer(ClipTextLen& - 1)
    Margin% = BlockLen%
    ReDim OutBuffer(MaxLen& + Margin%)
    For p& = 0 To ClipTextLen& - 1
        InBuffer(p&) = Asc(Mid$(ClipText, p& + 1, 1))
    Next
    CompLen& = 0

    LZCompress ClipTextLen&, CompLen&
    If CompLen& < BlockLen% Then
        p& = CompLen&
        For i% = 0 To (BlockLen% - CompLen&) - 1
            OutBuffer(p& + i%) = 32
        Next
        CompLen& = CompLen& + BlockLen%
    End If

    For p& = 0 To ClipTextLen& - 1: InBuffer(p&) = 0: Next
    Erase InBuffer
    TextPlusIV& = CompLen& + BlockLen%  '* space for IV *
    ReDim CryptBuffer(TextPlusIV& - 1)

    For p& = 0 To CompLen& - 1
        CryptBuffer(p& + BlockLen%) = OutBuffer(p&)
        OutBuffer(p&) = 0
    Next
    Erase OutBuffer

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

    '* create pseudo-IV
    GetTS i1%, i2%, i3%, i4%, i5%, i6%
    GetVector v1%, v2%, v3%
    CryptBuffer(0) = i1%
    CryptBuffer(1) = i2%
    CryptBuffer(2) = i3%
    CryptBuffer(3) = i4%
    CryptBuffer(4) = i5%
    CryptBuffer(5) = i6%

    '* encrypt TS with fixed key
    For i% = 0 To 31: password2(i%) = password(i%): Next
    For i% = 0 To 31: password(i%) = i% + 32: Next
    CryptInit
    Blocks& = 1
    BufferPointer& = 0
    SelectCipher (Blocks&)
    '* clear the feedback register
    For i% = 1 To BlockLen%: FBR(i%) = 0: Next

    '* encrypt result with vector
    CryptBuffer(0) = CryptBuffer(0) Xor v1%
    CryptBuffer(1) = CryptBuffer(1) Xor v2%
    CryptBuffer(2) = CryptBuffer(2) Xor v3%
    CryptBuffer(3) = CryptBuffer(3) Xor v4%
    BufferPointer& = 0
    SelectCipher (Blocks&)

    '* encrypt the data
    For i% = 0 To 31: password(i%) = password2(i%): Next
    For i% = 0 To 31: password2(i%) = 32: Next
    WithSalt% = -1
    CryptInit
    Blocks& = (CompLen& \ BlockLen%)
    BufferPointer& = BlockLen%
    SelectCipher (Blocks&)
    ShortBlockLen% = CompLen& Mod BlockLen%
    If ShortBlockLen% > 0 Then
        '* process the shortblock
        BufferPointer& = TextPlusIV& - BlockLen%
        For i% = 1 To BlockLen%: FBR(i%) = 0: Next
        SelectCipher (1)
    End If

    TextPlusSalt& = TextPlusIV& + BlockLen%
    ReDim bin(TextPlusSalt& + 3)
    For p& = 0 To TextPlusIV& - 1: bin(p&) = CryptBuffer(p&): Next

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

    '* append the Encrypted Salt
    p& = TextPlusIV&
    For i% = 0 To BlockLen% - 1
        bin(p&) = CryptBuffer(i%)
        p& = p& + 1
    Next
    Erase CryptBuffer

    '* encode the data
    ReDim ch(((TextPlusSalt& * 4) \ 3) + ((TextPlusSalt& \ 48) * 2) + 5)
    EncodeData TextPlusSalt&, RetLen&

    ClipText = Space$(Len(ClipText))
    ClipText = Space$(RetLen&)
    For p& = 0 To RetLen& - 1
        Mid$(ClipText, p& + 1, 1) = Chr$(ch(p&))
    Next

    Erase ch, bin
    Clipboard.Clear
    Clipboard.SetText ClipText

End Sub


Sub DecryptClip()

    '* ClipText As String is GLOBAL

    ReDim SaveFBR(1 To BlockLen%) As Integer

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

    ClipText = Clipboard.GetText(vbCFText)

    '* replace the CRLF some programs remove
    If Right$(ClipText, 1) <> Chr$(10) Then
        ClipText = Space$(Len(ClipText))
        ClipText = Space$(Len(ClipText) + 2)
        ClipText = Clipboard.GetText(vbCFText) + Chr$(13) + Chr$(10)
    End If
    ClipTextLen& = Len(ClipText)

    '* if text is less than 1 block + IV & Salt then exit
    If ClipTextLen& < (BlockLen% * 3) Then
        MsgBox1 "There is not enough TEXT to Decrypt!", 0, ""
        Exit Sub
    End If

    '* decode the data
    ReDim ch(ClipTextLen& - 1)
    ReDim bin((ClipTextLen& \ 4) * 3)
    For p& = 0 To ClipTextLen& - 1
        ch(p&) = Asc(Mid$(ClipText, p& + 1, 1))
    Next
    If Not DecodeData(ClipTextLen&, RetLen&) Then
        MsgBox1 "Radix64 Decode Error", 0, "Abort"
        Exit Sub
    End If
    Erase ch

    SaltPointer& = (RetLen& - (BlockLen% - 1)) - 1
    IVPointer& = SaltPointer& - BlockLen%
    For i% = 0 To (BlockLen% - 1)
        Salt(i%) = bin(SaltPointer&)
        SaltPointer& = SaltPointer& + 1
    Next
    For i% = 0 To (BlockLen% - 1)
        Pre_FBR(i% + 1) = bin(IVPointer&)
        IVPointer& = IVPointer& + 1
    Next
    ReDim CryptBuffer(ClipTextLen& - 1)

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

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

    '* adjust for Salt
    RetLen& = RetLen& - BlockLen%
    WithSalt% = -1
    CryptInit

    '* decrypt the data
    For p& = 0 To RetLen& - 1: CryptBuffer(p&) = bin(p&): Next
    Erase bin
    BufferPointer& = 0
    ShortLen% = RetLen& Mod BlockLen%
    If ShortLen% > 0 Then SetShort% = 1 Else SetShort% = 0
    NumberOfBlocks& = RetLen& \ BlockLen% - SetShort%
    SelectCipher (NumberOfBlocks&)

    If ShortLen% > 0 Then
        '* process the blocks in reverse
        For i% = 1 To BlockLen%: SaveFBR(i%) = Pre_FBR(i%): Next
        For i% = 1 To BlockLen%: Pre_FBR(i%) = 0: Next
        BufferPointer& = RetLen& - BlockLen%
        SelectCipher (1)

        For i% = 1 To BlockLen%: Pre_FBR(i%) = SaveFBR(i%): Next
        Foffset% = BlockLen% + ShortLen%
        BufferPointer& = RetLen& - Foffset%
        SelectCipher (1)
    End If

    ReDim InBuffer(RetLen& - 1)
    For p& = 0 To RetLen& - 1
        InBuffer(p&) = CryptBuffer(p& + BlockLen%)
        CryptBuffer(p& + BlockLen%) = 0
    Next

    Erase CryptBuffer
    '* OutBuffer() is allocated on the fly in LZDecompress
    DecompLen& = 0
    LZDecompress (RetLen& - BlockLen%), DecompLen&

    ScanLen& = DecompLen& - 1
    For p& = 0 To ScanLen&
        If OutBuffer(ScanLen& - p&) <> 32 Then Exit For
    Next
    DecompLen& = DecompLen& - p&

    ClipText = Space$(Len(ClipText))
    ClipText = Space$(DecompLen&)
    For p& = 0 To DecompLen& - 1
        Mid$(ClipText, p& + 1, 1) = Chr$(OutBuffer(p&))
    Next
    For p& = 0 To RetLen& - 1: OutBuffer(p&) = 0: Next
    Erase InBuffer, OutBuffer

    MemoText = ClipText

End Sub


Function GetHeader()

    Seek #1, LOF(1) - (HEADERLEN - 1)
    Get #1, , Sig1
    Get #1, , Sig2

    '* simple signature test
    If (Sig1 = &H4F6A12C4) Then
        If (Sig2 = &H5610FF45) Or (Sig2 = &H5610FF46) Then
            GetHeader = -1

            Seek #1, LOF(1) - (HEADERLEN - 1) - BlockLen%
            For i% = 0 To (BlockLen% - 1)
                Get #1, , Salt(i%)
            Next
            If (Sig2 = &H5610FF46) Then
                CompFlag = -1
            Else
                CompFlag = 0
            End If
        End If
    Else
        GetHeader = 0
    End If


End Function


Sub PutHeader()

    For i% = 0 To (BlockLen% - 1)
        Put #2, , Salt(i%)
    Next

    Sig1 = &H4F6A12C4
    If CompFlag Then
        Sig2 = &H5610FF46
    Else
        Sig2 = &H5610FF45
    End If

    Put #2, , Sig1
    Put #2, , Sig2

End Sub


Private Sub GetSalt(SaltLen&)

    SaltBlocks& = SaltLen& \ BlockLen%

    '* clear registers
    For i% = 0 To BlockLen% - 1: Salt(i%) = 0: Next
    For i% = 1 To BlockLen%: FBR(i%) = 0: Next

    '* use a fixed key
    For i% = 0 To 31: password2(i%) = password(i%): Next
    For i% = 0 To 31: password(i%) = i% + 32: Next

    '* encrypt the header data to get CBC-MAC
    CryptInit
    BufferPointer& = 0
    SelectCipher (SaltBlocks&)

    '* save MAC for Salt
    For i% = 1 To BlockLen%: Salt(i% - 1) = FBR(i%): Next
    For i% = 0 To 31: password(i%) = password2(i%): Next

End Sub


Sub ReSalt()

    processX% = process%
    process% = 1
    For i% = 1 To BlockLen%: FBR(i%) = 0: Next
    For i% = 0 To (BlockLen% - 1)
        CryptBuffer(i%) = Salt(i%)
    Next
    BufferPointer& = 0
    WithSalt% = -1
    CryptInit
    SelectCipher (1)
    For i% = 0 To (BlockLen% - 1)
        Salt(i%) = CryptBuffer(i%)
    Next
    For i% = 1 To BlockLen%: FBR(i%) = 0: Next
    process% = processX%

End Sub


'* This code helps prevent residual password traces
Sub NotPassword()

    PwdBusy% = -1

    For i% = 0 To 31
        MasterPwd(i%) = Not MasterPwd(i%)
    Next

    For i% = 0 To 31
        password(i%) = Not password(i%)
    Next

    For i% = 0 To 255: A1%(i%) = Not A1%(i%): Next
    For i% = 0 To 255: A2%(i%) = Not A2%(i%): Next
    For i% = 0 To 255: A3%(i%) = Not A3%(i%): Next
    For i% = 0 To 255: A4%(i%) = Not A4%(i%): Next
    For i% = 0 To 255: A5%(i%) = Not A5%(i%): Next
    For i% = 0 To 255: A6%(i%) = Not A6%(i%): Next
    For i% = 0 To 255: A7%(i%) = Not A7%(i%): Next
    For i% = 0 To 255: A8%(i%) = Not A8%(i%): Next

    For i% = 0 To KeyCount - 1
        For j% = 0 To 71
            KeyArray(j%, i%) = Not KeyArray(j%, i%)
        Next
    Next

    For i% = 0 To LeapFrogRounds%
        For j% = 0 To 7
            SK(i%, j%) = Not SK(i%, j%)
        Next
    Next

    NotFlag% = NotFlag% Xor &HFFFF
    PwdBusy% = 0

End Sub

Sub LockPwd()

    If PwdLocked% Then Exit Sub
    PwdLocked% = -1
    Do
    Loop While PwdBusy%
    If NotFlag% Then
        NotPassword
    End If

End Sub

Sub UnlockPwd()

    If Not PwdLocked% Then Exit Sub
    If MasterPwdFlag = 0 Then Exit Sub
    For i% = 0 To 31: password2(i%) = 0: Next

    PwdMark = Int(Timer)
    PwdLocked% = 0

End Sub