modencryption.bas

用VB写的一个代理服务器程序.rar复件 用VB写的一个代理服务器程序.rar

Attribute VB_Name = "modEncryption"
Option Explicit
'*** Got this piece from other contributor but i can't remember who, so thanks to someone that post this code

Public Function Base64encode(ByVal BinaryData As String) As String
    Dim retString As String
    Dim Byte1 As Byte
    Dim Byte2 As Byte
    Dim Byte3 As Byte
    Dim i As Integer
    Dim X As Integer

    Do While Len(BinaryData) > 0
        Byte1 = Asc(BinaryData)
        BinaryData = Mid(BinaryData, 2)
        X = 2
        If Len(BinaryData) >= 1 Then
            Byte2 = Asc(BinaryData)
            BinaryData = Mid(BinaryData, 2)
            X = 1
        End If
        If Len(BinaryData) >= 1 Then
            Byte3 = Asc(BinaryData)
            BinaryData = Mid(BinaryData, 2)
            X = 0
        End If
        
        retString = retString & Base64Char(Int(Byte1 / 4))
        retString = retString & Base64Char(((Byte1 And 3) * 16) + Int(Byte2 / 16))
        retString = retString & Base64Char(((Byte2 And 15) * 4) + Int(Byte3 / 64))
        retString = retString & Base64Char(Byte3 And 63)
    Loop
    If X = 1 Then
        retString = Left(retString, Len(retString) - 1) & "="
    ElseIf X = 2 Then
        retString = Left(retString, Len(retString) - 2) & "=="
    End If
    Base64encode = retString
End Function

Public Function Base64decode(AsciiData As String) As String
    Dim counter As Integer
    Dim Temp As String
    'For the dec. Tab
    Dim DecodeTable As Variant
    Dim Out(2) As Byte
    Dim inp(3) As Byte
    'DecodeTable holds the decode tab
    DecodeTable = Array("255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "62", "255", "255", "255", "63", "52", "53", "54", "55", "56", "57", "58", "59", "60", "61", "255", "255", "255", "64", "255", "255", "255", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", _
    "18", "19", "20", "21", "22", "23", "24", "25", "255", "255", "255", "255", "255", "255", "26", "27", "28", "29", "30", "31", "32", "33", "34", "35", "36", "37", "38", "39", "40", "41", "42", "43", "44", "45", "46", "47", "48", "49", "50", "51", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255" _
    , "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255")
    'Reads 4 Bytes in and decrypt them
    'Debug.Print AsciiData
    'AsciiData = StrConv(AsciiData, vbFromUnicode)
    'Debug.Print AsciiData
    For counter = 1 To Len(AsciiData) Step 4
        '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        '     !!!!!!!!!!!!!!!!!!!
        '!IF YOU WANT YOU CAN ADD AN ERRORCHECK:
        '     !
        '!If DecodeTable()=255 Then Error!!
        '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        '     !!!!!!!!!!!!!!!!!!!
        '4 Bytes in -> 3 Bytes out
        inp(0) = DecodeTable(Asc(Mid(AsciiData, counter, 1)))
        inp(1) = DecodeTable(Asc(Mid(AsciiData, counter + 1, 1)))
        inp(2) = DecodeTable(Asc(Mid(AsciiData, counter + 2, 1)))
        inp(3) = DecodeTable(Asc(Mid(AsciiData, counter + 3, 1)))
        
        Out(0) = (inp(0) * 4) Or ((inp(1) \ 16) And &H3)
        Out(1) = ((inp(1) And &HF) * 16) Or ((inp(2) \ 4) And &HF)
        Out(2) = ((inp(2) And &H3) * 64) Or inp(3)
        '* look for "=" symbols

        If inp(2) = 64 Then
            'If there are 2 characters left -> 1
            '     binary out
            Out(0) = (inp(0) * 4) Or ((inp(1) \ 16) And &H3)
            Temp = Temp & Chr(Out(0) And &HFF)
        ElseIf inp(3) = 64 Then
            'If there are 3 characters left -> 2
            '     binaries out
            Out(0) = (inp(0) * 4) Or ((inp(1) \ 16) And &H3)
            Out(1) = ((inp(1) And &HF) * 16) Or ((inp(2) \ 4) And &HF)
            Temp = Temp & Chr(Out(0) And &HFF) & Chr(Out(1) And &HFF)
        Else 'Return three Bytes
            Temp = Temp & Chr(Out(0) And &HFF) & Chr(Out(1) And &HFF) & Chr(Out(2) And &HFF)
        End If
    Next
    Base64decode = Temp
End Function

Private Function Base64Char(ByVal bit6Number As Byte) As String
    Select Case bit6Number
        Case 0 To 25   'A to Z
            Base64Char = Chr(65 + bit6Number)
        Case 26 To 51  'a to z
            Base64Char = Chr(97 + (bit6Number - 26))
        Case 52 To 61  '0 to 9
            Base64Char = Chr(48 + (bit6Number - 52))
        Case 62        '+
            Base64Char = "+"
        Case 63        '-
            Base64Char = "/"
        Case Else
            MsgBox "Error bit6Number > 63", vbOKOnly + vbCritical, "Base64Char"
    End Select
End Function

Public Function DoXOR(vData As String, Key As String) As String
    Dim lngCtr As Long, strtemp As String, strdata As String
    Dim ByteArray(3) As Byte, fl As Long, lngKey As Long
    
    lngKey = GenerateKey(Key)
    
    ByteArray(0) = lngKey And 255
    ByteArray(1) = (lngKey \ 2 ^ 8) And 255
    ByteArray(2) = (lngKey \ 2 ^ 16) And 255
    ByteArray(3) = (lngKey \ 2 ^ 24) And 255
    strdata = vData
    fl = Len(strdata)
    For lngCtr = 1 To fl
        strtemp = Chr(Asc(Mid(strdata, lngCtr, 1)) Xor ByteArray((lngCtr - 1) Mod UBound(ByteArray)))
        Mid(strdata, lngCtr, 1) = strtemp
    Next lngCtr
    DoXOR = strdata
End Function

Private Function GenerateKey(Key As String) As Long
Dim lngCtr As Long, lngTempKey As Long
    lngTempKey = 0
    For lngCtr = 1 To Len(Key)
        lngTempKey = lngTempKey + Asc(Mid(Key, lngCtr, 1))
    Next lngCtr
    GenerateKey = lngTempKey
End Function