' Код класса CIPHER
Option Explicit

Private msKeyString As String
Private msText As String

'~~~.KeyString
Public Property Let KeyString(sKeyString As String)
    msKeyString = sKeyString
    Initialize
End Property

'~~~.Text
Public Property Let Text(sText As String)
    msText = sText
End Property
Public Property Get Text() As String
    Text = msText
End Property

'~~~.DoXor
Public Sub DoXor()
    Dim intC As Integer
    Dim intB As Integer
    Dim lngI As Long
    For lngI = 1 To Len(msText)
        intC = Asc(Mid(msText, lngI, 1))
        intB = Int(Rnd * 256)
        Mid(msText, lngI, 1) = Chr(intC Xor intB)
    Next lngI
End Sub

'~~~.Stretch
Public Sub Stretch()
    Dim intC As Integer
    Dim lngI As Long
    Dim lngJ As Long
    Dim intK As Integer
    Dim lngA As Long
    Dim sB As String
    lngA = Len(msText)
    sB = Space(lngA + (lngA + 2) \ 3)
    For lngI = 1 To lngA
        intC = Asc(Mid(msText, lngI, 1))
        lngJ = lngJ + 1
        Mid(sB, lngJ, 1) = Chr((intC And 63) + 59)
        Select Case lngI Mod 3
        Case 1
            intK = intK Or ((intC \ 64) * 16)
        Case 2
            intK = intK Or ((intC \ 64) * 4)
        Case 0
            intK = intK Or (intC \ 64)
            lngJ = lngJ + 1
            Mid(sB, lngJ, 1) = Chr(intK + 59)
            intK = 0
        End Select
    Next lngI
    If lngA Mod 3 Then
        lngJ = lngJ + 1
        Mid(sB, lngJ, 1) = Chr(intK + 59)
    End If
    msText = sB
End Sub

'~~~.Shrink
Public Sub Shrink()
    Dim intC As Integer
    Dim intD As Integer
    Dim intE As Integer
    Dim lngA As Long
    Dim lngB As Long
    Dim lngI As Long
    Dim lngJ As Long
    Dim lngK As Long
    Dim sB As String
    lngA = Len(msText)
    lngB = lngA - 1 - (lngA - 1) \ 4
    sB = Space(lngB)
    For lngI = 1 To lngB
        lngJ = lngJ + 1
        intC = Asc(Mid(msText, lngJ, 1)) - 59
        Select Case lngI Mod 3
        Case 1
            lngK = lngK + 4
            If lngK > lngA Then lngK = lngA
            intE = Asc(Mid(msText, lngK, 1)) - 59
            intD = ((intE \ 16) And 3) * 64
        Case 2
            intD = ((intE \ 4) And 3) * 64
        Case 0
            intD = (intE And 3) * 64
            lngJ = lngJ + 1
        End Select
        Mid(sB, lngI, 1) = Chr(intC Or intD)
    Next lngI
    msText = sB
End Sub

Private Sub Initialize()
    Dim intI As Integer
    Randomize Rnd(-1)
    For intI = 1 To Len(msKeyString)
        Randomize Rnd(-Rnd * Asc(Mid(msKeyString, intI, 1)))
    Next intI
End Sub

' Код формы Admin
Option Explicit

Private Sub Form_Load()
' Вставляем в txtFile путь к файлу настроек
txtFile.Text = App.Path + "\" + "options.ini"
End Sub

Private Sub txtFile_Change()
    Dim lFileLen As Long
    Dim sHead As String
    ' Проверяем наличие файла
    On Error Resume Next
    lFileLen = Len(Dir(txtFile.Text))
    ' Проверяем на наличие ошибок в имени файла
    If Err <> 0 Or lFileLen = 0 Or Len(txtFile.Text) = 0 Then
        Exit Sub
    End If
    ' Проверяем по строке [Secret] в начале файла,
    ' что он зашифрован нашим классом
    Open txtFile.Text For Binary As #1
    sHead = Space(8)
    Get #1, , sHead
    Close #1
End Sub

Sub Encrypt()
    Dim sHead As String
    Dim sT As String
    Dim sA As String
    Dim cphX As New Cipher
    Dim n As Long
    Open txtFile.Text For Binary As #1
    'Load entire file into sA
    sA = Space$(LOF(1))
    Get #1, , sA
    Close #1
    ' Подготовка к шифрованию через функцию Hash
    sT = Hash(Date & Str(Timer))
    sHead = "[Secret]" & sT & Hash(sT & txtPassword1.Text)
    ' Шифрование
    cphX.KeyString = sHead
    cphX.Text = sA
    cphX.DoXor
    cphX.Stretch
    sA = cphX.Text
    ' Запись результатов
    Open txtFile.Text For Output As #1
    Print #1, sHead
    ' Окончание
    n = 1
    Do
        Print #1, Mid(sA, n, 70)
        n = n + 70
    Loop Until n > Len(sA)
    Close #1
End Sub

Sub Decrypt()
    Dim sHead As String
    Dim sA As String
    Dim sT As String
    Dim cphX As New Cipher
    Dim n As Long
    ' Проверяем по строке [Secret] в начале файла,
    ' что он зашифрован нашим классом
    Open txtFile.Text For Input As #1
    Line Input #1, sHead
    Close #1
    ' Проверяем пароль
    sT = Mid(sHead, 9, 8)
    If InStr(sHead, Hash(sT & txtPassword1.Text)) <> 17 Then
    Beep
        Exit Sub
    End If
    ' Открываем файл
    Open txtFile.Text For Input As #1
    Line Input #1, sHead
    Do Until EOF(1)
        Line Input #1, sT
        sA = sA & sT
    Loop
    Close #1
    ' Дешифрование
    cphX.KeyString = sHead
    cphX.Text = sA
    cphX.Shrink
    cphX.DoXor
    sA = cphX.Text
    ' Удаляем файл
    Kill txtFile.Text
    Open txtFile.Text For Binary As #1
    Put #1, , sA
    Close #1
End Sub

Function Hash(sA As String) As String
    Dim cphHash As New Cipher
    cphHash.KeyString = sA & "123456"
    cphHash.Text = sA & "123456"
    cphHash.DoXor
    cphHash.Stretch
    cphHash.KeyString = cphHash.Text
    cphHash.Text = "123456"
    cphHash.DoXor
    cphHash.Stretch
    Hash = cphHash.Text
End Function

Public Function Code()
    Refresh
    Encrypt
    txtFile_Change
End Function

Public Function DeCode()
    Refresh
    Decrypt
    txtFile_Change
End Function

' Код модуля modINI
' Чтение и запись строк в файлы инициализации
Declare Function GetPrivateProfileString& Lib _
"kernel32" Alias "GetPrivateProfileStringA" (ByVal _
lpszSection$, ByVal lpszKey$, ByVal lpszDefault$, _
ByVal lpszReturnBuffer$, ByVal cchReturnBuffer&, _
ByVal lpszFile$)
Declare Function WritePrivateProfileString Lib _
"kernel32" Alias "WritePrivateProfileStringA" (ByVal _
lpApplicationName As String, ByVal lpKeyName As String, _
ByVal lpString As String, ByVal lplFileName As String) As Long

' Чтение из файла инициализации
Public Function GetINI(INIfile As String, Section As String, _
Key As String, Default As String)
' Дешифруем
Call Admin.DeCode
' Читаем данные
Dim temp As String * 256
Dim length As Integer
temp = Space$(256)
length = GetPrivateProfileString(Section, Key, _
Default, temp, 255, INIfile)
GetINI = Left$(temp, length)
' Шифруем
Call Admin.Code
End Function

' Запись в файл инициализации
Public Sub SetINI(INIfile As String, Section As String, _
Key As String, Value As String)
' Дешифруем
Call Admin.DeCode
' Записываем данные
Dim n As Integer
Dim temp As String
temp = Value
For n = 1 To Len(Value)
If Mid$(Value, n, 1) = vbCr Or Mid$(Value, n, 1) = vbLf _
Then Mid$(Value, n) = ""
Next n
n = WritePrivateProfileString(Section, Key, temp, INIfile)
' Шифруем
Call Admin.Code
End Sub

SetINI Admin.txtFile.text, "Option", "Thing", Object
' Пример: SetINI Admin.txtFile.text, "SETUP", "Check1", Check1.Value

Object = GetINI(Admin.txtFile.text, "Option", "Thing", "Off")
' Где "Off" это вывод по умолчанию, если данной строки в файле нет
' Пример: Check1.Value = GetINI(Admin.txtFile.text, "SETUP", "Check1", "0")

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Dim lFileLen As Long
Dim sHead As String
On Error Resume Next
lFileLen = Len(Dir(Admin.txtFile.Text))
If Err <> 0 Or lFileLen = 0 Or Len(Admin.txtFile.Text) = 0 Then
Exit Sub
End If
Open Admin.txtFile.Text For Binary As #1
sHead = Space(8)
Get #1, , sHead
Close #1

If KeyCode = vbKeyF12 Then
' Тут мы выключаем все, что записывает информацию
Call Admin.DeCode
Beep
ElseIf KeyCode = vbKeyF11 Then
If sHead <> "[Secret]" Then
' Тут мы обратно включаем запись настроект и шифруем
Call Admin.Code
Beep
End If