Скрытие (шифрование) данных программы

Const TH32CS_SNAPTHREAD = &H4
Const SYNCHRONIZE = &H100000
Const lenNow = 21
Const WM_KEYDOWN = &H100
Const GW_CHILD = 5, GW_HWNDNEXT = 2, cc = 100
'
Private Type THREADENTRY32
    dwSize As Long
    cntUsage As Long
    th32ThreadID As Long
    th32OwnerProcessID As Long
    tpBasePri As Long
    tpDeltaPri As Long
    dwFlags As Long
End Type
Private Type tActCTL
    ForegroundWindow As Long
    ClassName As String
    Child As Long
    ChildClassName As String
    ChildText As String
End Type
'
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function OpenThread Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwThreadId As Long) As Long
Private Declare Function Thread32First Lib "kernel32" (ByVal hSnapshot As Long, ByRef lpte As THREADENTRY32) As Long
Private Declare Function Thread32Next Lib "kernel32" (ByVal hSnapshot As Long, ByRef lpte As THREADENTRY32) As Long
Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal dwFlags As Long, ByVal th32ProcessID As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
'
Dim FSO As FileSystemObject ' Object
Dim ShellApp As Shell, LogStream As TextStream, dicParsers As Dictionary
'
Dim FileVB6_EXE$, m_OutDir$, m_ZipName$, m_InitDir$, m_OldDir$, m_DelImport As Boolean
Dim LogPath As String, mParsers()
 
 
Property Let DelImport(ByVal vNewValue As Boolean)
    m_DelImport = vNewValue
    LogWriteLine "DelImport", m_DelImport
End Property
 
Private Sub LogWriteLine(ByVal ProcName$, Optional ByVal Text$)
    Dim s As String * lenNow
    LSet s = Now: LogStream.WriteLine s & "[" & ProcName & "]" & Text$
End Sub
 
Private Function ErrorFO(ByVal ProcName$)
    'Откат созданных файлов и папок
    '
    Dim s$, j$(), f&, vEach
    j = Split(FSO.OpenTextFile(LogPath).ReadAll, vbCrLf)
    LogWriteLine "ErrorFO", ProcName
    On Error Resume Next
    For f = UBound(j) To 0 Step -1
        For Each vEach In Array("CreateFolder", "CreateFile", ProcName)
            If InStr(1, j(f), "[" & vEach & "]") = lenNow + 1 Then
                s = Trim(Mid$(j(f), Len(vEach) + lenNow + 3))
                Select Case vEach
                Case "CreateFolder": FSO.DeleteFolder s: LogWriteLine "DeleteFolder", s
                Case "CreateFile": FSO.DeleteFile s: LogWriteLine "DeleteFile", s
                Case ProcName: Exit Function
                End Select
            End If
    Next: Next
End Function
 
Private Function CreateFile(ByVal AbsPath$, Optional Text) As Boolean
    'Проверяет путь и при не обходимости создаёт недостающие папки и файл
    '
    CreateFile = FSO.FileExists(AbsPath)
    If CreateFile Then Exit Function
    '---------------
    If CreateFolder(FSO.GetParentFolderName(AbsPath)) Then
        On Error Resume Next
        FSO.CreateTextFile(AbsPath).Write Text
        If Err = 0 Then LogWriteLine "CreateFile", AbsPath
    End If
    CreateFile = FSO.FileExists(AbsPath)
End Function
 
Private Function apn$(Path$)
    apn = FSO.GetAbsolutePathName(Path)
End Function
 
Private Function CreateFolder(ByVal AbsPath$) As Boolean
    'Проверяет путь и при не обходимости создаёт недостающие папки
    '
    Dim f&, j$(), s$, LS$
    CreateFolder = FSO.FolderExists(AbsPath)
    If CreateFolder Then Exit Function
    '---------------
    j = Split(AbsPath, k)
    On Error Resume Next
    For f = 0 To UBound(j)
        s = s & j(f) & k
        If Not FSO.FolderExists(s) And f = 0 Then
            Exit Function 'Драйвер указан не верно
        ElseIf Not FSO.FolderExists(s) Then Call FSO.CreateFolder(s)
            If FSO.FolderExists(s) Then LogWriteLine "CreateFolder", apn(s)
        End If
    Next
    CreateFolder = FSO.FolderExists(AbsPath)
End Function
 
Public Property Let InitDir(ByVal vNewValue As String)
    If FSO.FolderExists(vNewValue) Then
        m_InitDir = FSO.GetAbsolutePathName(vNewValue)
        ChDir m_InitDir: LogWriteLine "InitDir", m_InitDir
    End If
End Property
 
Public Property Let ZipName(ByVal vNewValue As String)
    If LCase(FSO.GetExtensionName(vNewValue)) = "zip" Then
        m_ZipName = FSO.GetAbsolutePathName(vNewValue)
        LogWriteLine "ZipName", m_ZipName
    End If
End Property
 
Public Property Let OutDir(ByVal vNewValue As String)
    m_OutDir = FSO.GetAbsolutePathName(vNewValue)
    LogWriteLine "OutDir", m_OutDir
End Property
 
Private Function GetThreadsList() As Long()
    'Возвращает список потоков
    '
    Dim hSnap&, TE As THREADENTRY32, PID&, Lst&(), u&, i&
    hSnap = CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0)
    If hSnap = -1 Then Exit Function
    u = 10: i = -1: ReDim Preserve Lst(u)
    TE.dwSize = Len(TE)
    PID = GetCurrentProcessId()
    If Thread32First(hSnap, TE) Then
        Do
            If TE.th32OwnerProcessID = PID Then
                i = i + 1: Lst(i) = TE.th32ThreadID
                If i > u Then u = i * 2: ReDim Preserve Lst(u)
            End If
        Loop While Thread32Next(hSnap, TE)
        ReDim Preserve Lst(i)
    End If
    CloseHandle hSnap
    GetThreadsList = Lst
End Function
 
Public Function UnZip(Parsers()) As Long
    'Извлекает папки/файлы из архива с полной структурой *!
    'совподающие пути заменяются без диалогов
    '
    Dim Zip As Folder3, f&, vEach, oldThreads&(), newThreads&(), hTrd&, DestDir As Object
    Dim j$(), ParserObj As Object, bp$
    LogWriteLine "UnZip"
    On Error Resume Next
    If Not FSO.FileExists(m_ZipName) Then ErrorFO "UnZip": Exit Function
    If Not CreateFolder(m_OutDir) Then ErrorFO "UnZip": Exit Function
    Set Zip = ShellApp.NameSpace(ByVal FSO.GetAbsolutePathName(m_ZipName))
    For Each vEach In Parsers
        j = Split(vEach, k): TrimArrStr (j)
        bp = m_OutDir
        Set ParserObj = Zip
        Set DestDir = ShellApp.NameSpace(ByVal bp)
        For f = 0 To UBound(j)
            Set ParserObj = ParserObj.ParseName(j(f))
            bp = FSO.BuildPath(bp, j(f))
            If ParserObj.IsFolder Then
                If Not CreateFolder(bp) Then GoTo NextEach
                Set ParserObj = ParserObj.GetFolder
                Set DestDir = ShellApp.NameSpace(ByVal bp)
            End If
        Next
        Debug.Print bp
        If FSO.FileExists(bp) Then FSO.DeleteFile (bp)
        If Len(ParserObj.Name) = 0 Then GoTo NextEach
        oldThreads = GetThreadsList
        DestDir.CopyHere ParserObj
        newThreads = GetThreadsList
        If UBound(newThreads) > UBound(oldThreads) Then
            hTrd = OpenThread(SYNCHRONIZE, False, newThreads(UBound(newThreads)))
            Call WaitForSingleObject(hTrd, -1): 'Ждать завершения операции распаковки
        End If
        CloseHandle hTrd
        LogWriteLine "UnZip", vEach: UnZip = UnZip + 1
NextEach:
    Next
    If UnZip = 0 Then ErrorFO "UnZip": Exit Function
End Function
 
Public Function ToZip(Paths()) As Long
    'Создает/добавляет файлы в архив
    '
    Const LenRandName = 10
    Dim Zip As Folder3, f&, oldThreads&(), newThreads&(), hTrd&
    LogWriteLine "ToZip"
    On Error Resume Next
    If Len(m_ZipName) = 0 Then
        Randomize Timer: m_ZipName = Space$(LenRandName)
        For f = 1 To LenRandName: Mid$(m_ZipName, f, 1) = Chr$(97 + Fix(Rnd * 26))
        Next: m_ZipName = m_OutDir & k & m_ZipName & ".zip": GoTo NewZip
    Else
NewZip:
        If Not CreateFile(m_ZipName, "PK" & Chr(5) & Chr(6) & String(18, 0)) Then
            ErrorFO "ToZip": Exit Function
        End If
    End If
    Set Zip = ShellApp.NameSpace(FSO.GetAbsolutePathName(m_ZipName))
    For f = 0 To UBound(Paths)
        Paths(f) = FSO.GetAbsolutePathName(Paths(f))
        If FSO.FileExists(Paths(f)) Or FSO.FolderExists(Paths(f)) Then Else GoTo Next_F
        If GetAttr(Paths(f)) And vbDirectory Then _
        If ShellApp.NameSpace((Paths(f))).Items.Count = 0 Then GoTo Next_F 'Пропускать пустые папки
        'Сравнение старых и новых потоков
        oldThreads = GetThreadsList: Zip.CopyHere ByVal Paths(f): newThreads = GetThreadsList
        If UBound(newThreads) > UBound(oldThreads) Then
            hTrd = OpenThread(SYNCHRONIZE, False, newThreads(UBound(newThreads)))
            Do While WaitForSingleObject(hTrd, 100)  'Ждать завершения операции сжатия
                With ForeGrWinInfo(1)
                    If (.ClassName & .ChildClassName) = "#32770Button" And Len(.ChildText) Then
                        Debug.Print .ChildText, .ClassName, .ChildClassName
                        PostMessage .Child, WM_KEYDOWN, 13, 1
                        Call WaitForSingleObject(hTrd, -1): Exit Do
            End If: End With: Loop
            CloseHandle hTrd
        End If
        LogWriteLine "ToZip", Paths(f): ToZip = ToZip + 1
Next_F:
    Next
    If ToZip = 0 Then ErrorFO "ToZip": Exit Function
End Function
Private Function RelativePath(ByVal Path$) As String
    RelativePath = Replace(Path, m_InitDir & k, "")
End Function
 
Private Function ForeGrWinInfo(Optional ChildID&) As tActCTL
    Dim f&
    With ForeGrWinInfo
        .ForegroundWindow = GetForegroundWindow
        .Child = GetWindow(.ForegroundWindow, GW_CHILD)
        For f = 1 To ChildID: .Child = GetWindow(.Child, GW_HWNDNEXT): Next
        .ClassName = Space$(cc): GetClassName .ForegroundWindow, .ClassName, cc
        .ClassName = Trim$(Left$(.ClassName, InStr(1, .ClassName, vbNullChar) - 1))
        .ChildText = Space$(cc): GetWindowText .Child, .ChildText, cc
        .ChildText = Trim$(Left$(.ChildText, InStr(1, .ChildText, vbNullChar) - 1))
        .ChildClassName = Space$(cc): GetClassName .Child, .ChildClassName, cc
        .ChildClassName = Trim$(Left$(.ChildClassName, InStr(1, .ChildClassName, vbNullChar) - 1))
    End With
End Function
 
 
Public Function Make(Files()) As Long
    'Автокомпиляция проекта
    'Files = Список компилируемых файлов
    Dim FileName$, mDir$, ShellNum&, hProc&, f&
    LogWriteLine "Make"
    If Not CreateFolder(m_OutDir) Then ErrorFO "Make": Exit Function
    mDir = """" & m_OutDir & """"
    For f = 0 To UBound(Files)
        Files(f) = FSO.GetAbsolutePathName(Files(f))
        If Not FSO.FileExists(Files(f)) Then GoTo Next_F
        Select Case LCase(FSO.GetExtensionName(Files(f)))
        Case "vbp", "vbg": Case Else: GoTo Next_F
        End Select: FileName = """" & Files(f) & """"
        ShellNum = Shell(FileVB6_EXE & " /Make " & FileName & " /OutDir " & mDir)
        hProc = OpenProcess(SYNCHRONIZE, False, ShellNum)
        Call WaitForSingleObject(hProc, -1)
        CloseHandle hProc
        Make = Make + 1
Next_F:
    Next
End Function
 
Private Sub Class_Initialize()
    Set FSO = CreateObject("Scripting.FileSystemObject"): LogPath = App.Path & "\LogStream.txt"
    Set LogStream = FSO.CreateTextFile(LogPath)
    LogWriteLine "Initialize" 'Начало ведение лога
    Set ShellApp = CreateObject("Shell.Application")
    FileVB6_EXE = """" & Environ("ProgramFiles") & "\Microsoft Visual Studio\VB98\VB6.EXE" & """"
    m_OldDir = CurDir$: m_OutDir = m_OldDir: m_InitDir = m_OldDir
End Sub
 
Private Sub Class_Terminate()
    ChDir m_OldDir
    LogStream.Close 'Закрытие потока записи лога
End Sub

Attribute VB_Name = "modSInst"
Option Explicit
Global Const r = "/", z = ",", k = "\", NameFilter = "[!0-9!a-z!A-Z!а-я!А-Я!Ё!ё!_]"
Dim clsSInst As New clsSInst
 
Sub CallArg(ByVal ArgLine As String)
    Dim f&, j$(1), Arg(), Result As Variant
    On Error Resume Next
    For f = 1 To Len(ArgLine):  If Mid$(ArgLine, f, 1) Like NameFilter Then Exit For
        j(0) = j(0) & Mid$(ArgLine, f, 1)
    Next: j(1) = Trim(Mid$(ArgLine, f))
    If Asc(j(1)) = Asc("=") Then
        Result = CallByName(clsSInst, j(0), VbLet, Trim$(Mid$(j(1), 2)))
    Else
        Arg = TrimArrVar(Split(j(1), z))
        Result = CallByName(clsSInst, j(0), VbMethod, Arg)
        If Err.Number = 450 Then
            Result = CallByName(clsSInst, j(0), VbLet, Arg(0))
            Exit Sub
        End If
    End If
End Sub
 
Sub Main()
    Dim Arg() As Variant, j$(), f&, u&
    
    Dim Command$ 'Тэстовая часть
    Command$ = "/InitDir=C:\Documents and Settings\All Users\Документы\Моя музыка\Mp3" & _
    "/ZipName=C:\Documents and Settings\User32\Рабочий стол\Новая папка (5)\Новая--папка\Сжатая ZIP-папка.zip" & _
    "/OutDir=C:\Documents and Settings\User32\Рабочий стол\Новая папка (99)" & _
    "/ToZip " & _
    "2 Eivissa - Uh La La La (DJ Nejtrino & DJ Baur Summer Ready Mix).mp3," & _
    "Настройки [2г].zip," & _
    "Новая папка\2014-06-08_065236.jpg," & _
    "03 - Мировые инструментальные хиты  (audiopoisk.com).mp3"
    
    '
    '----------------------------------
    On Error Resume Next: DeleteSetting App.Path
    On Error GoTo 0
    j = TrimArrStr(Split(Command$, r))
    For f = 0 To UBound(j):  If Len(j(f)) Then CallArg j(f)
    Next
 
End Sub
 
Function TrimArrVar(Arr) As Variant()
    'Удаляет передние и задние пробелы в массиве
    '
    Dim f&: ReDim v(UBound(Arr)): For f = 0 To UBound(Arr): v(f) = Trim(Arr(f)): Next: TrimArrVar = v
    TrimArrVar = v
End Function
 
Function TrimArrStr(Arr) As String()
    'Удаляет передние и задние пробелы в списке
    '
    Dim f&, j$(): j = Arr: For f = 0 To UBound(Arr): j(f) = Trim(Arr(f)): Next: TrimArrStr = j
End Function