' //
' // modSelfCleaning by The trick
' //
 
Option Explicit
 
Private Const STARTF_USESHOWWINDOW      As Long = &H1
Private Const SW_HIDE                   As Long = 0
Private Const CREATE_SUSPENDED          As Long = &H4
Private Const MEM_COMMIT                As Long = &H1000&
Private Const MEM_RESERVE               As Long = &H2000&
Private Const MEM_RELEASE               As Long = &H8000&
Private Const PAGE_EXECUTE_READWRITE    As Long = &H40&
Private Const DUPLICATE_SAME_ACCESS     As Long = &H2
Private Const DUPLICATE_CLOSE_SOURCE    As Long = &H1
Private Const INFINITE                  As Long = &HFFFFFFFF
Private Const WAIT_OBJECT_0             As Long = 0
 
Private Type tFunctionsTable
    pWaitForSingleObject    As Long
    pExitProcess            As Long
    pCloseHandle            As Long
    pDeleteFile             As Long
    plstrlen                As Long
End Type
 
Private Type tThreadData
    lNumberOfEntries        As Long            ' // Number of items in strings table
    pStringTable            As Long            ' // Pointer to strings table
    tFuncTable              As tFunctionsTable ' // Functions table
    hMainExe                As Long            ' // Handle of main exe
End Type
 
Private Type PROCESS_INFORMATION
    hProcess                As Long
    hThread                 As Long
    dwProcessId             As Long
    dwThreadId              As Long
End Type
 
Private Type STARTUPINFO
    cb                      As Long
    lpReserved              As Long
    lpDesktop               As Long
    lpTitle                 As Long
    dwX                     As Long
    dwY                     As Long
    dwXSize                 As Long
    dwYSize                 As Long
    dwXCountChars           As Long
    dwYCountChars           As Long
    dwFillAttribute         As Long
    dwFlags                 As Long
    wShowWindow             As Integer
    cbReserved2             As Integer
    lpReserved2             As Long
    hStdInput               As Long
    hStdOutput              As Long
    hStdError               As Long
End Type
 
Private Declare Function CreateProcess Lib "kernel32" _
                         Alias "CreateProcessW" ( _
                         ByVal lpApplicationName As Long, _
                         ByVal lpCommandLine As Long, _
                         lpProcessAttributes As Any, _
                         lpThreadAttributes As Any, _
                         ByVal bInheritHandles As Long, _
                         ByVal dwCreationFlags As Long, _
                         lpEnvironment As Any, _
                         ByVal lpCurrentDirectory As Long, _
                         lpStartupInfo As STARTUPINFO, _
                         lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
                         ByVal hObject As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" _
                         Alias "GetModuleHandleW" ( _
                         ByVal lpModuleName As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" ( _
                         ByVal hModule As Long, _
                         ByVal lpProcName As String) As Long
Private Declare Function VirtualAllocEx Lib "kernel32.dll" ( _
                         ByVal hProcess As Long, _
                         lpAddress As Any, _
                         ByVal dwSize As Long, _
                         ByVal flAllocationType As Long, _
                         ByVal flProtect As Long) As Long
Private Declare Function VirtualFreeEx Lib "kernel32.dll" ( _
                         ByVal hProcess As Long, _
                         lpAddress As Any, _
                         ByVal dwSize As Long, _
                         ByVal dwFreeType As Long) As Long
Private Declare Function DuplicateHandle Lib "kernel32" ( _
                         ByVal hSourceProcessHandle As Long, _
                         ByVal hSourceHandle As Long, _
                         ByVal hTargetProcessHandle As Long, _
                         ByRef lpTargetHandle As Any, _
                         ByVal dwDesiredAccess As Long, _
                         ByVal bInheritHandle As Long, _
                         ByVal dwOptions As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function WriteProcessMemory Lib "kernel32" ( _
                         ByVal hProcess As Long, _
                         ByVal lpBaseAddress As Long, _
                         lpBuffer As Any, _
                         ByVal nSize As Long, _
                         lpNumberOfBytesWritten As Long) As Long
Private Declare Function CreateRemoteThread Lib "kernel32" ( _
                         ByVal hProcess As Long, _
                         lpThreadAttributes As Any, _
                         ByVal dwStackSize As Long, _
                         ByVal lpStartAddress As Long, _
                         lpParameter As Any, _
                         ByVal dwCreationFlags As Long, _
                         lpThreadId As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" ( _
                         ByVal hProcess As Long, _
                         ByVal uExitCode As Long) As Long
 
Private Declare Sub CopyMemory Lib "kernel32" _
                    Alias "RtlMoveMemory" ( _
                    ByRef Destination As Any, _
                    ByRef Source As Any, _
                    ByVal Length As Long)
               
' // Wait for program termination and delete all passed files
Public Function CleanFiles( _
                ParamArray vFiles() As Variant) As Boolean
    Dim tdParam     As tThreadData
    Dim bStrTable() As Byte
    Dim hKernel32   As Long
    Dim hProcess    As Long
    Dim hThread     As Long
    Dim pData       As Long
    Dim pParam      As Long
    Dim pCode       As Long
    Dim lDataSize   As Long
    Dim lCodeSize   As Long
    Dim bRet        As Long
    Dim bInIDE      As Boolean
    
    ' // Check if code is in ide
    Debug.Assert MakeTrue(bInIDE)
    
    If bInIDE Then
        
        MsgBox "You should compile to Native code", vbExclamation
        CleanFiles = True
        Exit Function
        
    End If
    
    ' // Setup TrickCallPointers
    PatchFunc AddressOf CloseHandle_Proto
    PatchFunc AddressOf DeleteFileW_Proto
    PatchFunc AddressOf ExitProcess_Proto
    PatchFunc AddressOf lstrlenW_Proto
    PatchFunc AddressOf WaitForSingleObject_Proto
    
    hKernel32 = GetModuleHandle(StrPtr("kernel32"))
    If hKernel32 = 0 Then
        GoTo CleanUp
    End If
    
    ' // Fill functions table
    With tdParam.tFuncTable
    
        .pCloseHandle = GetProcAddress(hKernel32, "CloseHandle")
        .pDeleteFile = GetProcAddress(hKernel32, "DeleteFileW")
        .pExitProcess = GetProcAddress(hKernel32, "ExitProcess")
        .pWaitForSingleObject = GetProcAddress(hKernel32, "WaitForSingleObject")
        .plstrlen = GetProcAddress(hKernel32, "lstrlenW")
    
    End With
    
    ' // Make string table
    tdParam.lNumberOfEntries = StringTableToByteArray(bStrTable(), vFiles)
    If tdParam.lNumberOfEntries = 0 Then
        GoTo CleanUp
    End If
    
    ' // Run "Zombie" process
    hProcess = RunZombieProcess()
    If hProcess = 0 Then
        GoTo CleanUp
    End If
    
    ' // Place handle of main exe
    If DuplicateHandle(GetCurrentProcess(), GetCurrentProcess(), hProcess, _
                        tdParam.hMainExe, 0, False, DUPLICATE_SAME_ACCESS) = 0 Then
        GoTo CleanUp
    End If
    
    ' // Alloc memory in the EXE
    lCodeSize = GetAddress(AddressOf END_OF_SHELLCODE) - GetAddress(AddressOf BEGIN_OF_SHELLCODE)
    lDataSize = UBound(bStrTable) + 1 + LenB(tdParam) + lCodeSize
    
    pData = VirtualAllocEx(hProcess, ByVal 0&, lDataSize, _
                           MEM_COMMIT Or MEM_RESERVE, PAGE_EXECUTE_READWRITE)
    If pData = 0 Then
        GoTo CleanUp
    End If
    
    ' // Place string table
    If WriteProcessMemory(hProcess, pData, bStrTable(0), UBound(bStrTable) + 1, 0) = 0 Then
        GoTo CleanUp
    End If
    
    ' // Place param
    tdParam.pStringTable = pData
    
    pParam = pData + UBound(bStrTable) + 1
    
    If WriteProcessMemory(hProcess, pParam, tdParam, LenB(tdParam), 0) = 0 Then
        GoTo CleanUp
    End If
    
    ' // Place code
    pCode = pParam + LenB(tdParam)
    
    If WriteProcessMemory(hProcess, pCode, ByVal GetAddress(AddressOf ShellcodeProc), lCodeSize, 0) = 0 Then
        GoTo CleanUp
    End If
    
    ' // Run code
    hThread = CreateRemoteThread(hProcess, ByVal 0&, 0, pCode, ByVal pParam, 0, 0)
    If hThread = 0 Then
        GoTo CleanUp
    End If
    
    bRet = True
    
CleanUp:
    
    CloseHandle hThread
    
    If Not bRet Then
        
        If pData Then
            VirtualFreeEx hProcess, ByVal pData, 0, MEM_RELEASE
        End If
        
        If tdParam.hMainExe Then
            DuplicateHandle hProcess, tdParam.hMainExe, 0, 0, ByVal 0&, 0, DUPLICATE_CLOSE_SOURCE
        End If
        
        If hProcess Then
            TerminateProcess hProcess, 0
            CloseHandle (hProcess)
        End If
        
    End If
    
    CleanFiles = bRet
    
End Function
 
' // Run "Zombie" process
Private Function RunZombieProcess() As Long
    Dim pi  As PROCESS_INFORMATION
    Dim si  As STARTUPINFO
    
    si.cb = Len(si)
    si.dwFlags = STARTF_USESHOWWINDOW
    si.wShowWindow = SW_HIDE
    
    If CreateProcess(StrPtr(Environ("ComSpec")), 0, ByVal 0&, ByVal 0&, False, CREATE_SUSPENDED, ByVal 0, 0, si, pi) = 0 Then
        Exit Function
    End If
    
    CloseHandle pi.hThread
    
    RunZombieProcess = pi.hProcess
    
End Function
 
' // Serialize string table
Private Function StringTableToByteArray( _
                 ByRef bOutData() As Byte, _
                 ParamArray vStringTable() As Variant) As Long
    Dim bData()     As Byte:    Dim lDataCount      As Long
    Dim lIndex      As Long:    Dim sTmpString      As String
    Dim vVar        As Variant
    
    For Each vVar In vStringTable(0)
        
        If VarType(vVar) <> vbString Then GoTo continue
        
        sTmpString = vVar
 
        ReDim Preserve bData(lDataCount + LenB(sTmpString) + 2)
        
        ' // Copy string to buffer with null-terminating character
        CopyMemory bData(lDataCount), ByVal StrPtr(sTmpString), LenB(sTmpString) + 2
        
        lDataCount = lDataCount + LenB(sTmpString) + 2
        
        StringTableToByteArray = StringTableToByteArray + 1
        
continue:
        
    Next
    
    bOutData() = bData
 
End Function
                 
Private Function GetAddress( _
                 ByVal pAddress As Long) As Long
    GetAddress = pAddress
End Function
                 
Private Function BEGIN_OF_SHELLCODE() As Long
    BEGIN_OF_SHELLCODE = 1
End Function
 
Private Sub ShellcodeProc( _
            ByRef tdParam As tThreadData)
    Dim lIndex  As Long
    
    With tdParam
    
        ' // Wait process termination
        If WaitForSingleObject_Proto(.tFuncTable.pWaitForSingleObject, .hMainExe, INFINITE) <> WAIT_OBJECT_0 Then
            Exit Sub
        End If
        
        For lIndex = 0 To .lNumberOfEntries - 1
            
            DeleteFileW_Proto .tFuncTable.pDeleteFile, .pStringTable
            
            ' // Next string
            .pStringTable = .pStringTable + (lstrlenW_Proto(.tFuncTable.plstrlen, .pStringTable) + 1) * 2
            
        Next
        
        ' // Close handle
        CloseHandle_Proto .tFuncTable.pCloseHandle, .hMainExe
        
        ' // Exit process
        ExitProcess_Proto .tFuncTable.pExitProcess, 0
        
    End With
    
End Sub
 
Private Function WaitForSingleObject_Proto( _
                 ByVal pAddress As Long, _
                 ByVal hHandle As Long, _
                 ByVal dwMilliseconds As Long) As Long
End Function
 
Private Sub ExitProcess_Proto( _
            ByVal pAddress As Long, _
            ByVal uExitCode As Long)
End Sub
 
Private Function CloseHandle_Proto( _
                 ByVal pAddress As Long, _
                 ByVal hObject As Long) As Long
End Function
 
Private Function DeleteFileW_Proto( _
                 ByVal pAddress As Long, _
                 ByVal lpFileName As Long) As Long
End Function
 
Private Function lstrlenW_Proto( _
                 ByVal pAddress As Long, _
                 ByVal lpString As Long) As Long
End Function
 
Private Function END_OF_SHELLCODE() As Long
    END_OF_SHELLCODE = 2
End Function

Option Explicit
 
Private Type tagINITCOMMONCONTROLSEX
    dwSize  As Long
    dwICC   As Long
End Type
 
Private Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessId As Long
    dwThreadId As Long
End Type
 
Private Type STARTUPINFO
    cb As Long
    lpReserved As Long
    lpDesktop As Long
    lpTitle As Long
    dwX As Long
    dwY As Long
    dwXSize As Long
    dwYSize As Long
    dwXCountChars As Long
    dwYCountChars As Long
    dwFillAttribute As Long
    dwFlags As Long
    wShowWindow As Integer
    cbReserved2 As Integer
    lpReserved2 As Byte
    hStdInput As Long
    hStdOutput As Long
    hStdError As Long
End Type
 
Private Declare Function InitCommonControlsEx Lib "comctl32.dll" (lpInitCtrls As tagINITCOMMONCONTROLSEX) As Boolean
Private Declare Function GetCurrentProcessId Lib "kernel32.dll" () As Long
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function CreateProcess Lib "kernel32.dll" Alias "CreateProcessW" (ByVal lpApplicationName As Long, ByVal lpCommandLine As Long, lpProcessAttributes As Any, lpThreadAttributes As Any, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDirectory As Long, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function DeleteFileW Lib "kernel32.dll" (ByVal lpFileName As Long) As Long
Private Declare Sub GetStartupInfo Lib "kernel32" Alias "GetStartupInfoW" (lpStartupInfo As STARTUPINFO)
 
 
Sub Main()
    InitVisualStyles
    
    If InStr(1, Command(), "/release", 1) <> 0 Then
        'Если мы - клон, ожидать завершения PID, переданного через аргументы командной строки, после чего удалить файлы
        WatchForProcess
        Exit Sub
    End If
        
    'распаковать ocx, используемый формой
    UnpackResource 101, App.Path & "" & "MSComCtl.ocx"
    
    'Показать форму в синхронном режиме
    Form2.Show vbModal
    Set Form2 = Nothing
    
    ' запустить процесс-клон для слежения за завершением первичного процесса и последующим удалением остатков (OCX)
    Release
End Sub
 
Sub Release()
    On Error GoTo ErrorHandler
    
    Const STARTF_USESHOWWINDOW      As Long = 1
    Const NORMAL_PRIORITY_CLASS     As Long = &H20
    
    If True Then
        Dim si As STARTUPINFO
        Dim pi As PROCESS_INFORMATION
        Dim lret As Long
        
        si.cb = Len(si)
        GetStartupInfo si
        si.dwFlags = STARTF_USESHOWWINDOW
        si.wShowWindow = vbHide
    
        lret = CreateProcess(ByVal 0&, _
                       StrPtr("""" & App.Path & "" & App.EXEName & """" & " " & """" & "/release:" & GetCurrentProcessId() & """"), _
                       ByVal 0&, _
                       ByVal 0&, _
                       False, _
                       NORMAL_PRIORITY_CLASS, _
                       ByVal 0&, _
                       0&, _
                       si, _
                       pi)
        
        CloseHandle pi.hThread
        CloseHandle pi.hProcess
    End If
    Exit Sub
ErrorHandler:
    ErrorMsg Err, "Release"
End Sub
 
Sub WatchForProcess()
    On Error GoTo ErrorHandler
    Const INFINITE                  As Long = -1
    Const SYNCHRONIZE               As Long = &H100000
    Const PROCESS_QUERY_INFORMATION As Long = 1024&
    Const PROCESS_QUERY_LIMITED_INFORMATION As Long = &H1000
    
    Dim ProcessID As Long
    Dim hProc As Long
    Dim lret As Long
    
    ProcessID = Val(Mid$(Command(), InStr(1, Command(), "/release:", 1) + Len("/release:")))
    
    If ProcessID <> 0 Then
        
        hProc = OpenProcess(PROCESS_QUERY_INFORMATION Or SYNCHRONIZE, False, ProcessID)
    
        If hProc <> 0 Then
            Call WaitForSingleObject(hProc, INFINITE)
            CloseHandle hProc
        End If
            
        lret = DeleteFileW(StrPtr(App.Path & "" & "MSComCtl.ocx"))
    End If
    Exit Sub
ErrorHandler:
    ErrorMsg Err, "WatchForProcess"
End Sub
 
Sub InitVisualStyles()
    Dim ICC As tagINITCOMMONCONTROLSEX
    With ICC
        .dwSize = Len(ICC)
        .dwICC = &HFF&
    End With
    InitCommonControlsEx ICC
End Sub
 
Public Function UnpackResource(ResourceID As Long, DestinationPath As String) As Boolean
    On Error GoTo ErrorHandler:
    Dim ff      As Integer
    Dim b()     As Byte
    UnpackResource = True
    b = LoadResData(ResourceID, "CUSTOM")
    ff = FreeFile
    Open DestinationPath For Binary Access Write As #ff
        Put #ff, , b
    Close #ff
    Exit Function
ErrorHandler:
    ErrorMsg Err, "UnpackResource", "ID: " & ResourceID, "Destination path: " & DestinationPath
    UnpackResource = False
End Function
 
Sub ErrorMsg(ErrObj As ErrObject, sProcedure As String, ParamArray CodeModule())
    Dim Other$, sFormatted$, i&
    For i = 0 To UBound(CodeModule): Other = Other & CodeModule(i) & " ": Next
    sFormatted = " - " & sProcedure & " - #" & ErrObj.Number & " " & ErrObj.Description & ". LastDllError = " & ErrObj.LastDllError & IIf(Len(Other), "" & Other, "")
    Debug.Print sFormatted
End Sub

Option Explicit
Option Compare Text
 
Public Const Grid = 90
Dim ll&, tt&, ww&, hh&, mL&, mT&
 
Public Enum MoveAction
    [По умолчанию] = -3
    [Новые пункты] = -1
    [Сверху вниз] = 0
    [Слева направо] = 1
    [Продолжить вниз] = 2
    [Продолжить вправо] = 3
End Enum
 
 
Public Type SetCtr
    Move As Long
    GridWidth As Long
    GridHeight As Long
    StartLeft As Long
    StartTop As Long
    Gaps As Boolean
    Container As Object
End Type
 
Dim mDic As Object, mShellApp As Object
Dim SetCtr As SetCtr
 
Public Sub LoadAction( _
    Optional ByVal Move As MoveAction = -3, _
    Optional ByVal StartLeft&, _
    Optional ByVal StartTop&, _
    Optional ByVal GridWidth&, _
    Optional ByVal GridHeight&, _
    Optional ByVal Gaps& = -1, _
    Optional ByVal Container As Object, _
    Optional ByVal Ctrl As Object, _
    Optional ByVal Count&, _
    Optional ByVal Property$)
 
'Процедура для динамического создания контролов и назначения свойств всей группе
'Разделители: \\ для списков. //-для переменных в сходных свойствах. также будет загружен новый контрол
'пример аргументов:
'LoadAction GridWidth:=25, _
'    Ctrl:=Text1, _
'    Count:=3, _
'    Property:="Text="
'LoadAction GridHeight:=3, _
'    Gaps:=1, _
'    Ctrl:=Label1(1), _
'    Property:="Autosize=1,Caption=Заголовок//Адрес//Логин//Пароль//Телефон//Почта"
'------Ввод списков
'LoadAction Move:=[Слева направо], _
'    GridWidth:=20, _
'    Ctrl:=Combo1, _
'    Property:="list=Красный\\Желтый\\Зеленый//100руб\\200руб\\300руб\\400руб,listindex=0"
 
    Dim i&, ii&, j&, jj&, a$(), aa$(), ar(), o As Object, oo As Object
    Dim s$, ss$, ind&, g&, sl&, st&, iii&, v, prop$()
    
    On Error Resume Next
    With SetCtr
        
        If Move <> -3 Then .Move = (Move Mod 4)
        If .Move < 0 Then For i = Ctrl.Ubound To 0 Step -1: Unload Ctrl(i): Next
    
        If GridWidth > 0 Then .GridWidth = GridWidth
        If GridHeight > 0 Then .GridHeight = GridHeight
        If StartLeft > 0 Then .StartLeft = StartLeft
        If StartTop > 0 Then .StartTop = StartTop
        If Gaps > -1 Then .Gaps = Gaps
        If Not Container Is Nothing Then Set .Container = Container
    
        g = (Grid * Abs(.Gaps))
        Set o = Ctrl(Ctrl.Ubound)
        If Err Then
            Load Ctrl: Set o = Ctrl: Set Ctrl = Ctrl.Parent.Controls(Ctrl.Name)
            Dic(o.Name & o.Parent.hwnd) = o.Index - 1
        Else: ind = 0
        End If
 
        If Dic.Exists(o.Name & o.Parent.hwnd) Then
            ind = Dic(o.Name & o.Parent.hwnd) + 1
            Load Ctrl(ind)
            Set o = Ctrl(ind)
        End If
 
        Dic(o.Name & o.Parent.hwnd) = ind
        If Not .Container Is Nothing Then Set o.Container = .Container
        
        With o.Container
            If Not Dic.Exists(.hwnd) Then
                Dic(.hwnd) = Array(0, 0, 0, 0, 0, 0, 2, 2)
            End If
            ll = Dic(.hwnd)(0)
            tt = Dic(.hwnd)(1)
            ww = Dic(.hwnd)(2)
            hh = Dic(.hwnd)(3)
            mL = Dic(.hwnd)(4)
            mT = Dic(.hwnd)(5)
            SetCtr.StartLeft = IIf(SetCtr.StartLeft, SetCtr.StartLeft, Dic(.hwnd)(6))
            SetCtr.StartTop = IIf(SetCtr.StartTop, SetCtr.StartTop, Dic(.hwnd)(7))
        End With
    End With
    With o
        Select Case SetCtr.Move
        Case 0
            ll = mL + Grid: tt = Grid
        Case 1
            tt = mT + Grid: ll = Grid
        End Select
 
        With SetCtr
            sl = (.StartLeft * Grid): If ll < sl Then ll = ll + sl
            st = (.StartTop * Grid): If tt < st Then tt = tt + st
        End With
    End With
    With SetCtr
        If .GridWidth > 0 Then ww = Grid * .GridWidth
        If .GridHeight > 0 Then hh = Grid * .GridHeight
    End With
    '
    'Разбивка на комманды
    '
    prop = SplitSpec(Property, ",")
    For i = 0 To UBound(prop): ii = UBound(SplitSpec(prop(i))):  Do While ii > jj: jj = ii: Exit Do: Loop: Next
    ii = i - 1: If Count > 0 Then If (Count - 1) > jj Then jj = (Count - 1)
    
    ReDim Preserve ar(ii, jj)
    For i = 0 To UBound(prop)
        a = SplitSpec(prop(i), "=")
        aa = SplitSpec(a(1), "//")
        For j = 0 To jj
            s = aa(j): ar(i, j) = a(0) & "=" & s
        Next
    Next
 
    
    For j = 0 To jj
        Load Ctrl(ind + j)
        Set o = Ctrl(ind + j)
        With SetCtr
            If Not .Container Is Nothing Then Set o.Container = .Container
        End With
        
        With o
            .Move ll, tt: .Width = ww: .Height = hh: .Visible = 1
            For i = 0 To ii
                Set oo = o
                Do: a = SplitSpec(ar(i, j), "=", 2): iii = -1: iii = UBound(a)
                    If iii < 0 Then
                        Exit Do
                    ElseIf InStr(1, a(0), ".") Then
                        aa = SplitSpec(a(0), ".", 2)
                        Set oo = CallByName(oo, aa(0), VbGet)
                        ar(i, j) = aa(1) & "=" & a(1)
                    ElseIf a(0) = "List" Then
                        For Each v In SplitSpec(a(1), ""): oo.AddItem v: Next
                        Exit Do
                    Else: CallByName oo, a(0), VbLet, a(1): Exit Do
                    End If
                Loop
            Next
            If SetCtr.Move >= 0 Then
                If (ll + .Width) > mL Then mL = (ll + .Width)
                If (tt + .Height) > mT Then mT = (tt + .Height)
                With SetCtr
                    Select Case .Move Mod 2
                    Case 0: tt = tt + hh + g
                    Case 1: ll = ll + ww + g
                    End Select
                End With
            End If
            Dic(.Container.hwnd) = Array(ll, tt, ww, hh, mL, mT, SetCtr.StartLeft, SetCtr.StartTop)
            Dic(o.Name & o.Parent.hwnd) = ind + j
        End With
    Next
    SetCtr.StartLeft = 0: SetCtr.StartTop = 0
    
End Sub
 
 
Sub ControlsEnabled(Parent As Object, ByVal Enabled As Boolean, ParamArray Ctrls())
    'Включает/Отключает контролы
    'Примеры Ctrls:= Label1, "text1","text2(3 to 5,7)"
 
    Dim i&, ii&, j&, a1$(), a2$(), a3$(), a4$(), ctr As Object
    Dim ar$(), ind&, ubn&
 
    On Error Resume Next
    ReDim Preserve a1(UBound(Ctrls))
    For i = 0 To UBound(a1)
        If TypeName(Ctrls(i)) = "String" Then
            a1(i) = Ctrls(i)
        ElseIf IsObject(Ctrls(i)) Then
            a1(i) = Ctrls(i).Name
            a1(i) = a1(i) & "(" & Ctrls(i).Index & ")"
        End If
    Next
    For i = 0 To UBound(a1)
        a1(i) = Trim(a1(i))
        While InStr(1, a1(i), "  "): a1(i) = Replace(a1(i), "  ", " "): Wend
        If Len(a1(i)) Then a1(j) = a1(i): j = j + 1
    Next
    ReDim Preserve a1(j - 1)
    ubn = -1
    For i = 0 To UBound(a1)
        a2 = Split(a1(i), "("): a2(0) = Trim$(a2(0))
        If UBound(a2) > 0 Then
            a2(1) = Split(a2(1), ")")(0)
            a3 = Split(a2(1), ",")
            ReDim Preserve a2(UBound(a3) + 1)
            For ii = 1 To UBound(a2)
                a2(ii) = Trim$(a3(ii - 1))
                a4 = Split(a2(ii), "to", , 1)
                If UBound(a4) > 0 Then
                    For j = a4(0) To a4(1)
                        GoSub Preserve_ar
                        ar(ind) = a2(0) & "(" & j & ")": ind = ind + 1
                    Next
                Else: GoSub Preserve_ar
                    ar(ind) = a2(0) & "(" & a2(ii) & ")": ind = ind + 1
                End If
            Next
        Else: GoSub Preserve_ar: ar(ind) = a2(0): ind = ind + 1
        End If
    Next
    ReDim Preserve ar(ind - 1)
    For i = 0 To UBound(ar)
        If InStr(1, ar(i), "(") = 0 Then
            Set ctr = CallByName(Parent, ar(i), VbGet)
        Else
            a2 = Split(ar(i), "("): a2(1) = Split(a2(1), ")")(0)
            Set ctr = CallByName(Parent, a2(0), VbGet, a2(1))
        End If
        ctr.Enabled = Enabled
    Next
    
    Exit Sub
Preserve_ar:
    If ind > ubn Then ubn = (ind + 1) * 2: ReDim Preserve ar(ubn)
    Return
End Sub
Property Get ShellApp() As Object
    If mShellApp Is Nothing Then Set mShellApp = CreateObject("Shell.Application")
    Set ShellApp = mShellApp
End Property
 
Function NameIndex(ByVal ctr As Object) As String
    On Error Resume Next
    NameIndex = ctr.Name
    NameIndex = NameIndex & "(" & ctr.Index & ")"
End Function
 
Sub qSortList(ByVal List As Object, ByVal mn As Long, ByVal mx As Long)
    'Быстрая сортировка объектов List
    Dim i&, ii&, j$, jj$, id&
    With List
        i = mn: ii = mx: j = .List((i + ii) \ 2)
        Do Until i > ii: Do While .List(i) < j: i = i + 1: Loop: Do While .List(ii) > j: ii = ii - 1: Loop
            If (i <= ii) Then jj = .List(i): id = .ItemData(i): .List(i) = .List(ii): .ItemData(i) = .ItemData(ii): .List(ii) = jj: .ItemData(ii) = id: i = i + 1: ii = ii - 1
        Loop
    End With
    If mn < ii Then qSortList List, mn, ii
    If i < mx Then qSortList List, i, mx
End Sub
 
Sub qSort(Arr, ByVal mn As Long, ByVal mx As Long)
    'Быстрая сортировка
    Dim i As Long, l As Long, j As String, s As String
    i = mn: l = mx: j = Arr((i + l) \ 2)
    Do Until i > l: Do While Arr(i) < j: i = i + 1: Loop: Do While Arr(l) > j: l = l - 1: Loop
        If (i <= l) Then s = Arr(i): Arr(i) = Arr(l): Arr(l) = s: i = i + 1: l = l - 1
    Loop
    If mn < l Then qSort Arr, mn, l
    If i < mx Then qSort Arr, i, mx
End Sub
 
Sub ApplyFinalSize(ByVal obj As Object)
    'Применение конечного размера к форме или другому контейнеру
    Dim sW&, sH&
    On Error Resume Next
    With obj
        sW = .ScaleWidth
        sH = .ScaleHeight
        If sW > 0 Then sW = .Width - sW
        If sH > 0 Then sH = .Height - sH
        .Width = Dic(.hwnd)(4) + sW + Grid * 2
        .Height = Dic(.hwnd)(5) + sH + Grid * 2
    End With
End Sub
 
Property Get Dic() As Object
    If mDic Is Nothing Then Set mDic = CreateObject("scripting.dictionary"): mDic.CompareMode = 1
    Set Dic = mDic
End Property
 
Sub FrameRePaint(Parent As Object, Optional ByVal Frame As Object): Const ii = 9, ll = 45: Static i&, v, w, d As Object, j(ii) As Object: On Error GoTo g5: Do While j(ii) Is Nothing: Set j(ii) = Parent.Controls.Add("vb.label", "label_autosize"): j(ii).AutoSize = 1: Exit Do: Loop: Do While d Is Nothing: Set d = CreateObject("scripting.dictionary"): d.CompareMode = 1: Exit Do: Loop: Do Until Frame Is Nothing: Set v = Frame:  GoTo g1: Exit Do: Loop: For Each v In Parent.Controls
g1:     Do While TypeName(v) = "Frame": On d(v.hwnd) GoTo g2, g4: d(v.hwnd) = 1: Set j(0) = Parent.Controls.Add("vb.picturebox", "pic" & v.hwnd & 0, v): j(0).Visible = 1: j(0).BorderStyle = 0: For i = 1 To ii - 1: Do While i < 5: Set j(i) = Parent.Controls.Add("vb.picturebox", "pic" & v.hwnd & i, j(0)): j(i).Visible = 1: j(i).BorderStyle = 0: Exit Do: Loop: Do While i >= 5: Set j(i) = Parent.Controls.Add("vb.frame", "fra" & v.hwnd & i, j(i - 4)): j(i).Visible = 1: d(j(i).hwnd) = 2: Exit Do: Loop: Next: For Each w In Parent.Controls: Do While w.Container.hwnd = v.hwnd And w.Name <> j(0).Name: Set w.Container = j(0): Exit Do: Loop: Next: GoTo g3
g2:         For i = 0 To ii - 1: Do While i < 5: Set j(i) = Parent.Controls("pic" & v.hwnd & i): Exit Do: Loop: Do While i >= 5: Set j(i) = Parent.Controls("fra" & v.hwnd & i): Exit Do: Loop: Next
g3:         With v: Set j(ii).Font = .Font: j(ii).Caption = .Caption: For i = 0 To ii - 1: Select Case i
                        Case 0: j(i).Move 0, 0, .Width, .Height
                        Case 1: j(i).Move 0, 0, .Width, j(ii).Height
                        Case 2: j(i).Move 0, 0, ll, .Height
                        Case 3: j(i).Move .Width - ll, 0, ll, .Height
                        Case 4: j(i).Move 0, .Height - ll, .Width, ll
                        Case 5: j(i).Move 0, 0, .Width, .Height: Set j(i).Font = .Font: j(i).Caption = .Caption
                        Case 6: j(i).Move 0, 0, .Width, .Height
                        Case 7: j(i).Move -.Width + ll, 0, .Width, .Height
                        Case 8: j(i).Move 0, -.Height + ll, .Width, .Height
                    End Select: If i = 0 Or i > 4 Then j(i).BackColor = .BackColor
                Next: End With: Exit Do: Loop
g4: Next
g5: End Sub
 
 
Public Function SplitSpec(ByVal Str As String, Optional ByVal Delimiter$ = "//", _
Optional ByVal Limit& = -1, Optional ByVal Comp As VbCompareMethod) As String()
    Static i&, a$()
    a = Split(Str, Delimiter, Limit, Comp)
    For i = 0 To UBound(a): a(i) = Trim$(a(i)): Next
    SplitSpec = a
End Function

Option Explicit
Option Compare Text
 
Const fxPas& = 7 'Число знаков пароля
Private Type TRecord
    Title As String
    Address  As String
    Login As String
    Password As String
    Phone As StringA
    Mail As String
    id As Long
End Type
 
Private Type TRec
    Ubound As Long
    CurInd  As Long
    NewId  As Long
    Records() As TRecord
End Type
 
Private Const rr = vbLf & vbCrLf
 
Dim mRec As TRec, mRecNull As TRec, FileRec$, FileRecCopy$, v
Dim i&, j&, ff&, s$, DataChanges As Boolean
 
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
 
Private m_hMod As Long
 
Private Sub Form_Load()
 
    ''    s = ""
    ''    For i = 33 To 255
    ''        s = s & Chr(i)
    ''        If i Mod 32 = 0 Then s = s & vbLf
    ''    Next
    ''    Clipboard.Clear
    ''    Clipboard.SetText s
 
    On Error Resume Next
    FileRec = Environ("AppData") & "\Accounts"
    FileRecCopy = FileRec & "\Accounts.bak"
    MkDir FileRec
    FileRec = FileRec & "\Accounts.dat"
 
    
    Me.Caption = "Аккаунты"
    
    LoadAction GridHeight:=3, _
        Gaps:=1, _
        Ctrl:=Label1, _
        Property:="Autosize=1,Caption=Заголовок//Адрес//Логин//Пароль//Телефон//Почта"
    
    LoadAction GridWidth:=25, _
        Ctrl:=Text1, _
        Count:=Label1.Count, _
        Property:="Text="
    
    LoadAction GridWidth:=3, _
        GridHeight:=3, _
        Ctrl:=Command1(10), _
        Count:=Label1.Count, _
        Property:="caption=}//Ђ//},font.name=Wingdings 3,ToolTipText=Копировать//Выбрать//Копировать"
    
    LoadAction GridWidth:=25, _
        GridHeight:=3, _
        Ctrl:=Text1
    
    LoadAction Move:=[Продолжить вниз], _
        GridWidth:=25, _
        GridHeight:=(Label1.Count - 1) * 4, _
        Ctrl:=List1
 
    LoadAction Move:=[Сверху вниз], _
        GridWidth:=3, _
        GridHeight:=3, _
        Ctrl:=Command1, _
        Property:="caption=У,font.name=Wingdings 2,font.size=10,ToolTipText=Очистить поиск"
 
    LoadAction Move:=[Продолжить вниз], _
        GridWidth:=3, _
        GridHeight:=3, _
        Gaps:=0, _
        Ctrl:=Command1(20), _
        Property:="caption=З//И,font.name=Wingdings 3,ToolTipText=Переместить вверх//Переместить вниз"
    
    LoadAction Move:=[Слева направо], _
        GridWidth:=12, _
        GridHeight:=5, _
        Gaps:=1, _
        Ctrl:=Command1(30), _
        Property:="caption=Добавить запись//Удалить запись//Сортировать записи//Сохранить//Пере запуск"
    
    LoadAction Move:=[Продолжить вниз], _
        GridWidth:=3, _
        GridHeight:=3, _
        Ctrl:=Command1, _
        Property:="caption=Ђ,font.name=Wingdings 3,ToolTipText=Дополнительно"
    
''''    LoadAction Move:=[Слева направо], _
''''        GridWidth:=20, _
''''        Ctrl:=Combo1, _
''''        Property:="list=Красный\\Желтый\\Зеленый//100руб\\200руб\\300руб\\400руб,listindex=0//1"
    
    
    LoadAccounts
    Command1_Click -1
    '    FrameRePaint Me
End Sub
 
 
 
Private Sub SubMenu_Click(Index As Integer)
    Const ss = "AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUuVvWwXxYyZz0123456789"
 
    Select Case NameIndex(ActiveControl)
    Case "command1(11)"
        Select Case Index
        Case 0: With Clipboard: .Clear: .SetText (Text1(1).Text): End With
        Case 1: ShellApp.Open Text1(1).Text
        End Select
    Case "command1(35)"
        Select Case Index
        Case 0 'Создать резервную копию
            If Len(Dir(FileRecCopy)) > 0 Then
                If MsgBox("Копия уже существует переписать ?", 68) = vbNo Then Exit Sub
            End If
            Command1_Click 33
            FileCopy FileRec, FileRecCopy
            
        Case 1 'Восстановить из копии
            Kill FileRec
            FileCopy FileRecCopy, FileRec
            Command1_Click 34
        Case 2 'Генерация пароля
            s = Space$(fxPas): Randomize Timer
            Mid$(s, 1, 1) = Mid$(ss, Fix(Rnd * 52) + 1, 1)
            For i = 2 To fxPas
                Mid$(s, i, 1) = Mid$(ss, Fix(Rnd * 62) + 1, 1)
            Next
            Text1(3).Text = s
            mRec.Records(mRec.CurInd).Password = s
        End Select
    End Select
End Sub
 
Private Sub SavingAccounts()
    'Сохранение всех записей
    Dim Rec2() As TRecord, i&, j&
    If ActiveControl.Name = "Text1" Then Text1_Validate ActiveControl.Index, 0
    Rec2 = mRec.Records
    For i = 0 To List1(0).ListCount - 1: For j = 0 To UBound(Rec2)
        With Rec2(j)
            If .id = List1(0).ItemData(i) Then
                mRec.Records(i) = Rec2(j)
            End If
        End With
    Next: Next
    On Error Resume Next
    Kill FileRec
    ff = FreeFile
    Open FileRec For Binary As #ff
    Put #ff, 1, mRec
    Close #ff
    DataChanges = 0 ' Сброс изменений
End Sub
 
 
Private Sub Text1_Change(Index As Integer)
    Dim i&, j&, s$, a$(), fnd&
    Static ar$(), b As Boolean
    DataChanges = True 'Изменения в режиме выполнения
    With Text1(Index)
        Select Case Index
        Case 1
            s = Trim(.Text)
            .FontUnderline = IIf(Left$(s, 6) = "ftp://", 1, 0)
            .FontUnderline = IIf(Left$(s, 7) = "http://", 1, .FontUnderline)
            .FontUnderline = IIf(Left$(s, 8) = "https://", 1, .FontUnderline)
            .FontUnderline = IIf(InStr(1, s, " ") = 0, .FontUnderline, 0)
            .ForeColor = IIf(.FontUnderline, vbBlue, vbBlack)
        Case 6
            With List1(0)
                If b = False Then
                    b = True
                    ReDim Preserve ar(.ListCount - 1)
                    For i = 0 To UBound(ar)
                        ar(i) = .List(i) & rr & .ItemData(i)
                    Next
                End If
            End With
            ControlsEnabled Me, .Text = "", "Command1(20,21,30 to 33)"
            If .Text = "" Then b = False
            List1(0).Clear
            For i = 0 To UBound(ar)
                a = Split(ar(i), rr)
                If InStr(1, a(0), .Text, 1) > 0 Or .Text = "" Then
                    List1(0).AddItem a(0), j
                    List1(0).ItemData(j) = a(1)
                    If a(1) = mRec.Records(mRec.CurInd).id Then fnd& = j
                    j = j + 1
                End If
            Next
            With List1(0)
                ControlsEnabled Me, .ListCount > 0, "List1(0)", "Label1(0 to 5)", "Text1(0 to 5)", "Command1(10 to 15)"
                If .ListCount > 0 Then .ListIndex = fnd
            End With
        End Select
    End With
End Sub
 
 
Private Sub LoadAccounts()
    On Error Resume Next
    ff = FreeFile
    Open FileRec For Binary As #ff
    If LOF(ff) < 1 Then
        mRec.Ubound = -1
    Else
        Get #ff, 1, mRec
    End If
    Close #ff
    List1(0).Clear
    For i = 0 To mRec.Ubound
        With mRec.Records(i)
            List1(0).AddItem .Title, i
            List1(0).ItemData(i) = .id
        End With
    Next
    List1(0).ListIndex = 0
    DataChanges = 0 'Сброс изменений
End Sub
 
 
Private Sub Text1_Validate(Index As Integer, Cancel As Boolean)
    On Error Resume Next
    With mRec.Records(mRec.CurInd)
        
        Select Case Index
        Case 0
            If Trim(Text1(Index).Text) = "" Then
                MsgBox Label1(Index) & " не должен быть пустым", vbExclamation, Me.Caption
                Text1(Index).Text = .Title
                Cancel = 1: Exit Sub
            End If
            .Title = Text1(Index)
            With List1(0)
                .List(.ListIndex) = Text1(Index)
            End With
            
        Case 1
            .Address = Text1(Index)
        Case 2
            .Login = Text1(Index)
        Case 3
            .Password = Text1(Index)
        Case 4
            With Text1(Index)
                s = "" 'Форматируем номер телефона
                For i = 1 To Len(.Text): If Mid$(.Text, i, 1) Like "#" Then s = s & Mid$(.Text, i, 1)
                Next: s = Format(s, IIf(Len(s) < 8, "###-##-##", "# (###) ###-##-##"))
                While Left$(s, 1) = "-": s = Mid$(s, 2): Wend: .Text = s
            End With
            .Phone = Text1(Index)
        Case 5
            .Mail = Text1(Index)
        End Select
    End With
End Sub
 
Private Sub List1_Click(Index As Integer)
    Dim i&
    With mRec
        On Error Resume Next
        For i = 0 To mRec.Ubound
            With .Records(i)
                If .id = List1(Index).ItemData(List1(Index).ListIndex) Then
                    mRec.CurInd = i
                    Text1(0) = .Title
                    Text1(1) = .Address
                    Text1(2) = .Login
                    Text1(3) = .Password
                    Text1(4) = .Phone
                    Text1(5) = .Mail
                    Exit For
                End If
            End With
        Next
    End With
    DataChanges = False
End Sub
 
 
Private Sub Command1_Click(Index As Integer)
    Dim i&, j&, a$(), aa$()
    
    Select Case Index
    Case -1 'Если кнопка не выбранна, и нужно попасть в конец процедуры
    Case 35
        LoadAction Move:=[Новые пункты], _
            Ctrl:=SubMenu, _
            Property:="enabled=1//" & Abs(Len(Dir(FileRecCopy)) > 0) & ",caption=Создать резервную копию//Восстановить из копии//Сгенерировать пароль"
        With Command1(Index): PopupMenu Menu, , .Left, .Top: End With
        
    Case 34: 'Перезагрузка
        Command1_Click 16 'Стирание поля над списком
        mRec = mRecNull 'Полное Обнуление
        LoadAccounts
    Case 33:  SavingAccounts 'Сохранение всех записей
 
    Case 16: Text1(Index - 10).Text = "" 'Стирание поля над списком
    Case 14 'Копировать телефон
        With Text1(Index - 10): s = ""
            For i = 1 To Len(.Text): If Mid$(.Text, i, 1) Like "#" Then s = s & Mid$(.Text, i, 1)
        Next: End With: With Clipboard: .Clear: .SetText s: End With
    Case 11
        With Text1(1)
            LoadAction Move:=[Новые пункты], _
                Ctrl:=SubMenu, _
                Property:="enabled=1//" & Abs(.FontUnderline) & ",caption=Копировать//Перейти по ссылке"
        End With
        With Command1(Index): PopupMenu Menu, , .Left, .Top: End With
    Case 10 To 15 'Копировать поля
        With Clipboard: .Clear: .SetText (Text1(Index - 10).Text): End With
    Case 32 'Сортировка
        With List1(0)
            qSortList List1(0), 0, .ListCount - 1
            .ListIndex = 0
        End With
        DataChanges = 1
    Case 20, 21 'Перемещение в списке
        With List1(0)
            i = IIf(Index = 20, -1, 1)
            j = i + .ListIndex
            If j >= .ListCount Or j < 0 Then Exit Sub
            v = Array(.List(j), .ItemData(j))
            .RemoveItem (.ListIndex + i)
            j = .ListIndex + Abs(i < 0)
            .AddItem v(0), (j)
            .ItemData(j) = v(1)
        End With
        DataChanges = 1
    Case 31 'Удалить
        With mRec
            .Ubound = .Ubound - 1
            If .Ubound < 0 Then
                Erase .Records
                List1(0).Clear
                For i = 0 To Text1.Count - 1: Text1(i).Text = "": Next
                .Ubound = -1
                .NewId = 0
            Else
                ReDim Rec2(.Ubound) As TRecord
                For i = 0 To .Ubound
                    With .Records(i)
                        If .id <> List1(0).ItemData(List1(0).ListIndex) Then
                            Rec2(j) = mRec.Records(i): j = j + 1
                        End If
                    End With
                Next
                .Records = Rec2
                With List1(0)
                    j = .ListIndex
                    .RemoveItem .ListIndex
                    .ListIndex = j - Abs(j = .ListCount)
                End With
            End If
        End With
    Case 30 'Добавить
        With mRec
            .Ubound = .Ubound + 1
            ReDim Preserve .Records(.Ubound)
            With .Records(.Ubound)
                mRec.NewId = mRec.NewId + 1
                .id = mRec.NewId
                .Title = "Новая запись " & .id
                List1(0).AddItem .Title, 0
                List1(0).ItemData(0) = .id
            End With
            List1(0).ListIndex = 0
        End With
    Case Else 'Если это непроработанная кнопка выход здесь
        Exit Sub
    End Select
    
    ControlsEnabled Me, List1(0).ListCount > 0, "List1(0)", "Label1(0 to 5)", "Text1(0 to 6)", "Command1(10 to 16, 20,21 , 31 to 32)"
    
End Sub
 
 
 
 
Private Sub Form_Resize()
    If Me.WindowState <> 1 Then Me.WindowState = 0
    ApplyFinalSize Me
End Sub
 
Private Sub Form_Paint()
    'Поверх всех окон
    SetWindowPos Me.hwnd, -1, 0, 0, 0, 0, &H10 Or &H1 Or &H2
End Sub
 
Private Sub Form_Initialize()
    m_hMod = LoadLibrary("shell32.dll")
    InitCommonControls
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    If DataChanges Then
        If MsgBox("Сохранить изменения ?", 68, Me.Caption) = vbYes Then SavingAccounts
    End If
    FreeLibrary m_hMod
End Sub

Option Explicit
 
Const r = 123 'Старт генерации подставных знаков
Const tt = 100 'Число различных знаков в массиве
 
Dim WithEvents tx As TextBox, s$, i&, l&, b(tt) As Byte
Dim fso
 
Private Sub Form_Load()
    Set tx = Controls.Add("vb.Textbox", "tx"):  tx.Visible = 1
    Caption = "Хранение секретной записи"
    ChDir App.Path
    
    Set fso = CreateObject("scripting.filesystemobject")
    
    'Создаём байтовую запись из множества (tt) различных символов со стартом генерации значения (r)
    
    Randomize r
    For i = 0 To UBound(b): b(i Mod tt) = Fix(Rnd * 256): Next
    With fso
        If .FileExists("1.txt") Then
            With .OpenTextFile("1.txt")
                s = .ReadAll
                'Дешифруем заданный текст
                For i = 1 To Len(s): Mid$(s, i, 1) = Chr((Asc(Mid$(s, i, 1)) + b(i Mod tt)) Mod 256): Next
                tx = s
            End With
        Else: tx = "Здесь вы можете хранить секретики ))"
        End If
    End With
End Sub
 
Private Sub Form_Resize()
    tx.Move 0, 0, ScaleWidth
    With Me
        .Height = (.Height - .ScaleHeight) + tx.Height
    End With
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    With fso.CreateTextFile("1.txt")
        s = tx
        For i = 1 To Len(s) 'шифруем заданный текст и сохраняем его в засекреченном виде
            l = Asc(Mid$(s, i, 1)) - b(i Mod tt)
            If l < 0 Then l = (l + 512) Mod 256
            Mid$(s, i, 1) = Chr(l)
        Next
        .Write s
    End With
End Sub

Sub main()
  n = Val(InputBox("n"))
  If n < 2 Then
    n = 2
  End If
  ReDim A(n, n)
  For i = 1 To n
    For j = 1 To n
      A(i, j) = Val(InputBox("Enter A" & i & j))
    Next
  Next
  r = DetA(n, A)
  MsgBox r
End Sub
Function DetA(n, A())
If n = 2 Then
  S = A(1, 1) * A(2, 2) - A(1, 2) * A(2, 1)
Else
  ReDim B(n - 1, n - 1)
  For i = 1 To n
    Call Minor(i, n, A, B)
    S = S + (-1) ^ (i + 1) * A(1, i) * DetA(n - 1, B)
  Next
End If
DetA = S
End Function
Function Minor(m, n, A(), B())
  For i = 2 To n
    For j = 1 To n
      If j < m Then
        B(i - 1, j) = A(i, j)
      Else
        If j > m Then
          B(i - 1, j - 1) = A(i, j)
        End If
      End If
    Next
  Next
End Function