FN2 = FreeFile

Open F_Name For Output As #FN2

Close #FN2

Dim i As Integer

Dim j As Integer

 

Dim f As Integer

Dim sz As Integer

Dim Buf As String

Dim key As String

Dim keylen As Integer

 

Dim a As String

Dim b As String

 

 

key = "xxx"

 

 

  f = FreeFile

    Open "A:\123.txt" For Binary As #f

    

    sz = LOF(f)

    

    Buf = Space(sz)

    

    Get #f, , Buf

    

    keylen = Len(key)

    j = 1

    

    For i = 1 To sz

        a = Mid(Buf, i, 1)

        b = Mid(key, j, 1)

        a = Chr(Asc(a) Xor Asc(b))

        Mid(Buf, i, 1) = a

        j = j + 1

        If j > keylen Then j = 1

    Next i

    

    Seek #f, 1

    Put #f, , Buf

    

    Close #f

Public Function Encrypt(ByVal Val4 As String, ByVal Val3 As String) As String

 

Dim a As String

Dim b As String

Dim c As String

Dim d As String

Dim lentext As Long

Dim lenpass As Long

Dim cn As Long

 

 

a = Val4

b = Val3

c = vbnullstring

 

lentext = Len(a)

lenpass = Len(b)

 

 

For cn = 1 To lentext

 

d = Trim(str(Asc(Mid(a, cn, 1)) Xor Asc(Mid(b, ((cn - 1) Mod lenpass) + 1, 1))))

 

 

Select Case Val(d)

 

Case 0 To 9

d = "00" + d

 

Case 10 To 99

d = "0" + d

 

End Select

 

 

c = c + d

Next cn

 

Encrypt = c

 

 

End Function

 

 

 

Public Function Decrypt(ByVal Val1 As String, ByVal Val2 As String) As String

 

Dim a As String

Dim b As String

Dim c As String

Dim lentext As Long

Dim lenpass As Long

Dim cn As Long

 

 

a = vbnullstring

b = Val2

c = Val1

 

lentext = Len(c)

lenpass = Len(b)

 

 

For cn = 1 To lentext Step 3

a = a + Chr(Val(Mid(c, cn, 3)) Xor Asc(Mid(b, (Int(cn / 3) Mod lenpass) + 1, 1)))

Next cn

 

 

Decrypt = a

 

End Function

Function XorEncryptDecrypt(ByVal Text As String, ByVal Pass As String)

  Dim i As Long

  Dim b() As Byte 'шифруемые данные

  Dim c() As Byte 'пароль, которым шифруется данные

  Dim TextLen As Long 'длина шифруемых данных

  Dim PassLen As Long 'длина пароля

  'Если текст или пароль пусто значить шифрация бесполезна

  If Len(Text) = 0 Then GoTo EXIT_LABEL

  If Len(Pass) = 0 Then Exit Function

  'Замеряем длину шифруемых данных

  TextLen = Len(Text)

  'Замеряем длину пароля

  PassLen = Len(Pass)

  'Создаем байтовый массив размера равного длине шифруемых данных

  ReDim b(TextLen * 2)

  'Создаем байтовый массив размера равного длине пароля

  ReDim c(PassLen * 2)

  'Копируем шифруемые данные в созданный байтовый массив

  'т.е. Переводим тип String в байтовый массив

  Call CopyMemory(b(0), ByVal Text, TextLen * 2)

  'Копируем пароль в созданный байтовый массив

  'т.е. Переводим тип String в байтовый массив

  Call CopyMemory(c(0), ByVal Pass, PassLen * 2)

  'непосредственно сама процедура шифрации данных переданным паролем

  'пароль блочно накладывается на шифруемые данные операцией XOR

  For i = 0 To UBound(b)

    b(i) = b(i) Xor c(i Mod PassLen)

  Next

  'Переводим байтовый массив в тип String

  Call CopyMemory(ByVal Text, b(0), TextLen * 2)

  'Очистка памяти

  Erase b

  Erase c

  'Сюда идет перенаправление, если текст или пароль пустые

EXIT_LABEL:

  'Возвращаем зашифрованные/дешифрованные данные

  XorEncryptDecrypt = Text

End Function

Option Explicit

 

Private Sub Form_Load()

    Dim bData() As Byte

    

    ' // Шифрование

    Open "C:\temp\EarthVB6.zip" For Binary As 1

    ReDim bData(LOF(1) - 1)

    Get 1, , bData

    Close 1

    

    CryptDecryptData bData, "Ключ Key"

    

    Open "C:\Temp\EarthVB6.crypt" For Binary As 1

    Put 1, , bData

    Close 1

    

    ' // Дешифрование

    Open "C:\temp\EarthVB6.crypt" For Binary As 1

    ReDim bData(LOF(1) - 1)

    Get 1, , bData

    Close 1

    

    CryptDecryptData bData, "Ключ Key"

    

    Open "C:\Temp\EarthVB6.zip" For Binary As 1

    Put 1, , bData

    Close 1

    

End Sub

 

Private Sub CryptDecryptData( _

            ByRef bData() As Byte, _

            ByRef sKey As String)

    Dim bKey()      As Byte

    Dim lIndex      As Long

    Dim lKeySize    As Long

    

    If Len(sKey) <= 0 Then Exit Sub

    

    bKey = sKey:    lKeySize = (UBound(bKey) - LBound(bData)) + 1

    

    For lIndex = LBound(bData) To UBound(bData)

        bData(lIndex) = bData(lIndex) Xor bKey(lIndex Mod lKeySize)

    Next

    

End Sub