' Process List by Alex Dragokas
 
Option Explicit
 
Const MAX_PATH As Long = 260&
 
Private Declare Function NtQuerySystemInformation Lib "ntdll.dll" (ByVal infoClass As Long, Buffer As Any, ByVal BufferSize As Long, ret As Long) As Long
Private Declare Sub memcpy Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExW" (lpVersionInformation As Any) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetModuleFileNameEx Lib "psapi.dll" Alias "GetModuleFileNameExW" (ByVal hProcess As Long, ByVal hModule As Long, ByVal lpFileName As Long, ByVal nSize As Long) As Long
Private Declare Function GetProcessImageFileName Lib "psapi.dll" Alias "GetProcessImageFileNameW" (ByVal hProcess As Long, ByVal lpImageFileName As Long, ByVal nSize As Long) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryW" (ByVal lpBuffer As Long, ByVal nSize As Long) As Long
Private Declare Function ExpandEnvironmentStrings Lib "kernel32" Alias "ExpandEnvironmentStringsW" (ByVal lpSrc As Long, ByVal lpDst As Long, ByVal nSize As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function LookupPrivilegeValue Lib "advapi32" Alias "LookupPrivilegeValueW" (ByVal lpSystemName As Long, ByVal lpName As Long, lpLuid As Long) As Long
Private Declare Function OpenProcessToken Lib "advapi32" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function AdjustTokenPrivileges Lib "advapi32" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, ByVal PreviousState As Long, ByVal ReturnLength As Long) As Long
Private Declare Function GetFullPathName Lib "kernel32.dll" Alias "GetFullPathNameW" (ByVal lpFileName As Long, ByVal nBufferLength As Long, ByVal lpBuffer As Long, lpFilePart As Long) As Long
Private Declare Function QueryFullProcessImageName Lib "kernel32.dll" Alias "QueryFullProcessImageNameW" (ByVal hProcess As Long, ByVal dwFlags As Long, ByVal lpExeName As Long, ByVal lpdwSize As Long) As Long
Private Declare Function GetLogicalDriveStrings Lib "kernel32.dll" Alias "GetLogicalDriveStringsW" (ByVal nBufferLength As Long, ByVal lpBuffer As Long) As Long
Private Declare Function QueryDosDevice Lib "kernel32.dll" Alias "QueryDosDeviceW" (ByVal lpDeviceName As Long, ByVal lpTargetPath As Long, ByVal ucchMax As Long) As Long
 
Private Type TOKEN_PRIVILEGES
    PrivilegeCount  As Long
    LuidLowPart     As Long
    LuidHighPart    As Long
    Attributes      As Long
End Type
 
Private Type LARGE_INTEGER
    LowPart     As Long
    HighPart    As Long
End Type
 
Private Type CLIENT_ID
    UniqueProcess   As Long  ' HANDLE
    UniqueThread    As Long  ' HANDLE
End Type
 
Private Type UNICODE_STRING
    Length      As Integer
    MaxLength   As Integer
    lpBuffer    As Long
End Type
 
Private Type VM_COUNTERS
    PeakVirtualSize             As Long
    VirtualSize                 As Long
    PageFaultCount              As Long
    PeakWorkingSetSize          As Long
    WorkingSetSize              As Long
    QuotaPeakPagedPoolUsage     As Long
    QuotaPagedPoolUsage         As Long
    QuotaPeakNonPagedPoolUsage  As Long
    QuotaNonPagedPoolUsage      As Long
    PagefileUsage               As Long
    PeakPagefileUsage           As Long
End Type
 
Private Type IO_COUNTERS
    ReadOperationCount      As Currency 'ULONGLONG
    WriteOperationCount     As Currency
    OtherOperationCount     As Currency
    ReadTransferCount       As Currency
    WriteTransferCount      As Currency
    OtherTransferCount      As Currency
End Type
 
Private Type SYSTEM_THREAD
    KernelTime          As LARGE_INTEGER
    UserTime            As LARGE_INTEGER
    CreateTime          As LARGE_INTEGER
    WaitTime            As Long
    StartAddress        As Long
    ClientId            As CLIENT_ID
    Priority            As Long
    BasePriority        As Long
    ContextSwitchCount  As Long
    State               As Long 'enum KTHREAD_STATE
    WaitReason          As Long 'enum KWAIT_REASON
    dReserved01         As Long
End Type
 
Private Type SYSTEM_PROCESS_INFORMATION
    NextEntryOffset         As Long
    NumberOfThreads         As Long
    SpareLi1                As LARGE_INTEGER
    SpareLi2                As LARGE_INTEGER
    SpareLi3                As LARGE_INTEGER
    CreateTime              As LARGE_INTEGER
    UserTime                As LARGE_INTEGER
    KernelTime              As LARGE_INTEGER
    ImageName               As UNICODE_STRING
    BasePriority            As Long
    ProcessId               As Long
    InheritedFromProcessId  As Long
    HandleCount             As Long
    SessionId               As Long
    pPageDirectoryBase      As Long '_PTR
    VirtualMemoryCounters   As VM_COUNTERS
    PrivatePageCount        As Long
    IoCounters              As IO_COUNTERS
    Threads()               As SYSTEM_THREAD
End Type
 
Const SystemProcessInformation      As Long = &H5&
Const STATUS_INFO_LENGTH_MISMATCH   As Long = &HC0000004
Const STATUS_SUCCESS                As Long = 0&
Const ERROR_PARTIAL_COPY            As Long = 299&
 
Dim sWinDir             As String
Dim bIsWinVistaOrLater  As Boolean
 
 
Private Sub Form_Load()
    Const SPI_SIZE      As Long = &HB8&
    Const THREAD_SIZE   As Long = &H40&
    
    Dim i           As Long
    Dim ret         As Long
    Dim buf()       As Byte
    Dim Offset      As Long
    Dim Process     As SYSTEM_PROCESS_INFORMATION
    Dim ProcName    As String
    Dim ProcPath    As String
    
    Dim inf(68) As Long
    inf(0) = 276: GetVersionEx inf(0): bIsWinVistaOrLater = (inf(1) >= 6)
    sWinDir = GetWinDir()
    
    SetCurrentProcessPrivileges "SeDebugPrivilege"
    
    If NtQuerySystemInformation(SystemProcessInformation, ByVal 0&, 0&, ret) = STATUS_INFO_LENGTH_MISMATCH Then
    
        ReDim buf(ret - 1)
        
        If NtQuerySystemInformation(SystemProcessInformation, buf(0), ret, ret) = STATUS_SUCCESS Then
        
            With Process
            
                Do
                    memcpy Process, buf(Offset), SPI_SIZE
                    
                    ReDim .Threads(0 To .NumberOfThreads - 1)
                    
                    For i = 0 To .NumberOfThreads - 1
                        memcpy .Threads(i), buf(Offset + SPI_SIZE + i * THREAD_SIZE), THREAD_SIZE
                    Next
                    
                    If .ProcessId = 0 Then
                        ProcName = "System Idle Process"
                    Else
                        ProcName = Space$(.ImageName.Length \ 2)
                        memcpy ByVal StrPtr(ProcName), ByVal .ImageName.lpBuffer, .ImageName.Length
                        ProcPath = GetFilePathByPID(.ProcessId)
                    End If
                    
                    Debug.Print Right$("00000" & .ProcessId, 6) & " - " & ProcName & " - " & ProcPath
                    
                    Offset = Offset + .NextEntryOffset
                    
                Loop While .NextEntryOffset
                
            End With
            
        End If
        
    End If
    
    End
    
End Sub
 
Function GetFilePathByPID(PID As Long) As String
    Const MAX_PATH_W                        As Long = 32767&
    Const PROCESS_VM_READ                   As Long = 16&
    Const PROCESS_QUERY_INFORMATION         As Long = 1024&
    Const PROCESS_QUERY_LIMITED_INFORMATION As Long = &H1000&
    
    Dim ProcPath    As String
    Dim hProc       As Long
    Dim cnt         As Long
    Dim pos         As Long
    Dim FullPath    As String
    Dim SizeOfPath  As Long
    Dim lpFilePart  As Long
 
    hProc = OpenProcess(IIf(bIsWinVistaOrLater, PROCESS_QUERY_LIMITED_INFORMATION, PROCESS_QUERY_INFORMATION) Or PROCESS_VM_READ, 0, PID)
    If hProc <> 0 Then
    
        If bIsWinVistaOrLater Then
            cnt = MAX_PATH_W + 1
            ProcPath = Space$(cnt)
            Call QueryFullProcessImageName(hProc, 0&, StrPtr(ProcPath), VarPtr(cnt))
        End If
        
        If 0 <> Err.LastDllError Or Not bIsWinVistaOrLater Then     'Win 2008 Server (x64) can cause Error 128 if path contains space characters
        
            ProcPath = Space$(MAX_PATH)
            cnt = GetModuleFileNameEx(hProc, 0&, StrPtr(ProcPath), Len(ProcPath))
        
            If cnt = MAX_PATH Then 'Path > MAX_PATH -> realloc
                ProcPath = Space$(MAX_PATH_W)
                cnt = GetModuleFileNameEx(hProc, 0&, StrPtr(ProcPath), Len(ProcPath))
            End If
        End If
        
        If cnt <> 0 Then                          'clear path
            ProcPath = Left$(ProcPath, cnt)
            If StrComp("\SystemRoot\", Left$(ProcPath, 12), 1) = 0 Then ProcPath = sWinDir & Mid$(ProcPath, 12)
            If "\??\" = Left$(ProcPath, 4) Then ProcPath = Mid$(ProcPath, 5)
        End If
        
        If ERROR_PARTIAL_COPY = Err.LastDllError Then       'because GetModuleFileNameEx cannot access to that information for 64-bit processes on WOW64
            ProcPath = Space$(MAX_PATH)
            cnt = GetProcessImageFileName(hProc, StrPtr(ProcPath), Len(ProcPath))
            
            If cnt <> 0 Then
                ProcPath = Left$(ProcPath, cnt)
                
                ' Convert DosDevice format to Disk drive format
                If StrComp(Left$(ProcPath, 8), "\Device\", 1) = 0 Then
                    pos = InStr(9, ProcPath, "\")
                    If pos <> 0 Then
                        FullPath = ConvertDosDeviceToDriveName(Left$(ProcPath, pos - 1))
                        If Len(FullPath) <> 0 Then
                            ProcPath = FullPath & Mid$(ProcPath, pos + 1)
                        End If
                    End If
                End If
                
            End If
            
        End If
        
        If cnt <> 0 Then    'if process ran with 8.3 style, GetModuleFileNameEx will return 8.3 style on x64 and full pathname on x86
                            'so wee need to expand it ourself
        
            FullPath = Space$(MAX_PATH)
            SizeOfPath = GetFullPathName(StrPtr(ProcPath), MAX_PATH, StrPtr(FullPath), lpFilePart)
            If SizeOfPath <> 0& Then
                GetFilePathByPID = Left$(FullPath, SizeOfPath)
            Else
                GetFilePathByPID = ProcPath
            End If
            
        End If
        
        CloseHandle hProc
    End If
End Function
 
Function GetWinDir() As String
    Dim ret&, sWinDir$
    sWinDir = Space$(MAX_PATH)
    ret = GetWindowsDirectory(StrPtr(sWinDir), MAX_PATH)
    If ret Then
        sWinDir = Left$(sWinDir, ret)
    Else
        ret = ExpandEnvironmentStrings(StrPtr("%SystemRoot%"), StrPtr(sWinDir), MAX_PATH + 1)
        If ret Then sWinDir = Left$(sWinDir, ret - 1)
    End If
    GetWinDir = sWinDir
End Function
 
Public Function SetCurrentProcessPrivileges(PrivilegeName As String) As Boolean
    Const TOKEN_ADJUST_PRIVILEGES   As Long = &H20
    Const SE_PRIVILEGE_ENABLED      As Long = &H2
    Dim tp As TOKEN_PRIVILEGES, hToken&
    If LookupPrivilegeValue(0&, StrPtr(PrivilegeName), tp.LuidLowPart) Then   'i.e. "SeDebugPrivilege"
        If OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES, hToken) Then
            tp.PrivilegeCount = 1
            tp.Attributes = SE_PRIVILEGE_ENABLED
            SetCurrentProcessPrivileges = AdjustTokenPrivileges(hToken, 0&, tp, Len(tp), 0&, 0&)
            CloseHandle hToken
        End If
    End If
End Function
 
Public Function ConvertDosDeviceToDriveName(inDosDeviceName As String) As String
    On Error Resume Next
 
    Static DosDevices   As New Collection
    
    If DosDevices.Count Then
        ConvertDosDeviceToDriveName = DosDevices(inDosDeviceName)
        Exit Function
    End If
    
    Dim aDrive()        As String
    Dim sDrives         As String
    Dim cnt             As Long
    Dim i               As Long
    Dim DosDeviceName   As String
    
    cnt = GetLogicalDriveStrings(0&, StrPtr(sDrives))
    
    sDrives = Space(cnt)
    
    cnt = GetLogicalDriveStrings(Len(sDrives), StrPtr(sDrives))
 
    If 0 = Err.LastDllError Then
    
        aDrive = Split(Left$(sDrives, cnt - 1), vbNullChar)
    
        For i = 0 To UBound(aDrive)
            
            DosDeviceName = Space(MAX_PATH)
            
            cnt = QueryDosDevice(StrPtr(Left$(aDrive(i), 2)), StrPtr(DosDeviceName), Len(DosDeviceName))
            
            If cnt <> 0 Then
            
                DosDeviceName = Left$(DosDeviceName, InStr(DosDeviceName, vbNullChar) - 1)
 
                DosDevices.Add aDrive(i), DosDeviceName
 
            End If
            
        Next
    
    End If
    
    ConvertDosDeviceToDriveName = DosDevices(inDosDeviceName)
    
End Function

' Создает раздел
Public Function RegCreateKey(lHive As REG_HIVES, ByVal sKey$, Optional bUseWow64 As WOW_64_TYPE) As Boolean
' Читает значение параметра любого из этих типов: REG_SZ, REG_MULTI_SZ, REG_EXPAND_SZ, REG_DWORD, REG_DWORDLittleEndian, REG_DWORDBigEndian, REG_BINARY
Public Function GetRegData(hHive As REG_HIVES, ByVal KeyName As String, ByVal ValueName As String, Optional bUseWow64 As WOW_64_TYPE) As Variant
' Записывает значение параметра типа REG_SZ
Public Function RegSetStringVal(lHive As REG_HIVES, ByVal sKey$, sValue$, sData$, Optional bUseWow64 As WOW_64_TYPE) As Boolean
' Записывает значение параметра типа REG_EXPAND_SZ
Public Function RegSetExpandStringVal(lHive As REG_HIVES, ByVal sKey$, sValue$, sData$, Optional bUseWow64 As WOW_64_TYPE) As Boolean
' Записывает значение параметра типа REG_DWORD
Public Function RegSetDwordVal(lHive As REG_HIVES, ByVal sKey$, sValue$, lData&, Optional bUseWow64 As WOW_64_TYPE) As Boolean
' Удаляет параметр
Public Function RegDelVal(lHive As REG_HIVES, ByVal sKey$, sValue$, Optional bUseWow64 As WOW_64_TYPE) As Boolean
' Удаляет раздел (рекурсивно с подразделами)
Public Function RegDelKey(lHive As REG_HIVES, ByVal sKey$, Optional bUseWow64 As WOW_64_TYPE) As Boolean
' Проверяет, существует ли раздел
Public Function RegKeyExists(lHive As REG_HIVES, ByVal sKey$, Optional bUseWow64 As WOW_64_TYPE) As Boolean
' Проверяет, существует ли параметр
Public Function RegValueExists(lHive As REG_HIVES, ByVal sKey$, sValue$, Optional bUseWow64 As WOW_64_TYPE) As Boolean
' Проверяет, существует ли в разделе другие подразделы
Public Function RegKeyHasSubKeys(lHive As REG_HIVES, ByVal sKey$, Optional bUseWow64 As WOW_64_TYPE) As Boolean
' Проверяет, существуют ли в разделе параметры
Public Function RegKeyHasValues(lHive As REG_HIVES, ByVal sKey$, Optional bUseWow64 As WOW_64_TYPE) As Boolean
' Читает имя первого попавшегося подраздела в указанном разделе
Public Function RegGetFirstSubKey(lHive As REG_HIVES, ByVal sKey$, Optional bUseWow64 As WOW_64_TYPE) As String
' Возвращает все имена подразделов в указанном разделе. Результат - 1 строка (разделитель - знак "|".
Public Function RegEnumSubkeys(lHive As REG_HIVES, ByVal sKey$, Optional bUseWow64 As WOW_64_TYPE) As String
' Возвращает все имена параметров в указанном разделе. Результат - 1 строка (разделитель - знак "|".
Public Function GetEnumValues(lHive As REG_HIVES, ByVal KeyName$, Optional bUseWow64 As WOW_64_TYPE) As String
' Получить время модификации раздела
Public Function GetRegKeyTime(lHive As REG_HIVES, ByVal KeyName$, Optional bUseWow64 As WOW_64_TYPE) As Date
' Экспортировать раздел в бинарный файл ( для этого потребуются повышенные привилегии ! )
Public Function KeyExportToBinary(lHive As REG_HIVES, ByVal KeyName$, destFile As String, Optional bUseWow64 As WOW_64_TYPE) As Boolean     'Save key to binary .hiv file
' Узнать тип параметра
Public Function ValueType(lHive As REG_HIVES, ByVal KeyName$, ByVal ValueName As String, Optional bUseWow64 As WOW_64_TYPE) As REG_TYPE
' Находит подраздел реестра по началу имени, указанному в аргументе "Mask"
Public Function FindSubKey(lHive As REG_HIVES, ByVal KeyName As String, Mask As String, Optional bUseWow64 As WOW_64_TYPE) As String

Option Explicit
 
Dim Reg As clsRegistry
 
Private Sub Form_Load()
    Dim Key
    Set Reg = New clsRegistry
      
    ' Поиск первого попавшегося имени раздела по части имени
    Debug.Print Reg.FindSubKey(HKEY_LOCAL_MACHINE, "Software", Mask:="Mi")
    
    ' Создание раздела в обычном и альтернативном представлениях реестра
    Reg.RegCreateKey 0, "HKLM\Software\1_Test", WOW_64_OFF
    Reg.RegCreateKey 0, "HKLM\Software\1_Test", WOW_64_ON
    
    ' Создание структуры веток
    If Reg.RegCreateKey(0, "HKLM\Software\1_Test\1\2\3\4\5") Then Debug.Print "Успешно создан 1_Test\1\2\3\4\5"
    If Not Reg.RegCreateKey(0, "HKLM\SYSTEM\CurrentControlSet\Enum\Test") Then Debug.Print "Ошибка создания защищенного LS - Enum\Test."
    
    ' Запись значения параметра типа REG_SZ
    Reg.RegSetStringVal 0, "HKLM\Software\1_Test", "Bit", "x64", WOW_64_OFF
    Reg.RegSetStringVal 0, "HKLM\Software\1_Test", "Bit", "x32", WOW_64_ON
    
    ' Чтение значения параметра
    Debug.Print Reg.GetRegData(0, "HKLM\Software\1_Test", "Bit", WOW_64_OFF)
    Debug.Print Reg.GetRegData(0, "HKLM\Software\1_Test", "Bit", WOW_64_ON)
    
    ' Удаление раздела с контролем успешности операции
    If Reg.RegDelKey(0, "HKLM\Software\1_Test", WOW_64_OFF) Then Debug.Print "Успешное удаление x64"
    If Reg.RegDelKey(0, "HKLM\Software\1_Test", WOW_64_ON) Then Debug.Print "Успешное удаление x32"
    
    ' Перечисление имен параметров указанного раздела + их значения
    For Each Key In Split(Reg.GetEnumValues(0, "HKEY_CURRENT_USER\Environment"), "|")
        Debug.Print CStr(Key); " = "; Reg.GetRegData(0, "HKEY_CURRENT_USER\Environment", CStr(Key))
    Next
    
    ' Экспорт в бинарный файл
    Reg.KeyExportToBinary 0, "HKCU\Environment", "c:\temp\env.hiv"
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    Set Reg = Nothing
End Sub

Option Explicit
 
Private Declare Function SystemTimeToVariantTime Lib "oleaut32.dll" (ByVal lpSystemTime As Any, vtime As Date) As Long
Private Declare Function VariantTimeToSystemTime Lib "oleaut32.dll" (ByVal vtime As Date, ByVal lpSystemTime As Any) As Long
Private Declare Function SystemTimeToTzSpecificLocalTime Lib "kernel32.dll" (ByVal lpTimeZone As Any, ByVal lpUniversalTime As Any, ByVal lpLocalTime As Any) As Long
 
Private Sub Form_Load()
    Debug.Print ConvertUnixTimeToLocalDate(1380558746)
End Sub
 
Public Function ConvertUnixTimeToLocalDate(Seconds As Long) As Date
    Dim stime(15) As Byte 'SYSTEMTIME
    Dim DateTime  As Date
    
    DateTime = DateAdd("s", Seconds, #1/1/1970#)                           ' time_t -> Date
    VariantTimeToSystemTime DateTime, VarPtr(stime(0))                     ' Date -> SYSTEMTIME
    SystemTimeToTzSpecificLocalTime 0&, VarPtr(stime(0)), VarPtr(stime(0)) ' tz can be 0, if tz is current
    SystemTimeToVariantTime VarPtr(stime(0)), ConvertUnixTimeToLocalDate   ' SYSTEMTIME -> Date
End Function

Option Explicit
 
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
 
Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type
 
Private Declare Function FileTimeToSystemTime Lib "kernel32.dll" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32.dll" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
Private Declare Function SystemTimeToFileTime Lib "kernel32.dll" (lpSystemTime As SYSTEMTIME, lpFileTime As FILETIME) As Long
Private Declare Function SystemTimeToVariantTime Lib "oleaut32.dll" (lpSystemTime As SYSTEMTIME, vtime As Date) As Long
Private Declare Function VariantTimeToSystemTime Lib "oleaut32.dll" (ByVal vtime As Date, lpSystemTime As SYSTEMTIME) As Long
Private Declare Function GetTimeZoneInformation Lib "kernel32.dll" (ByVal lpTimeZoneInformation As Long) As Long
Private Declare Function SystemTimeToTzSpecificLocalTime Lib "kernel32.dll" (ByVal lpTimeZone As Any, lpUniversalTime As SYSTEMTIME, lpLocalTime As SYSTEMTIME) As Long
 
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExW" (ByVal hKey As Long, ByVal lpSubKey As Long, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExW" (ByVal hKey As Long, ByVal lpValueName As Long, ByVal lpReserved As Long, lpType As Long, szData As Long, lpcbData As Long) As Long
 
Public Function ConvertUnixTimeToLocalDate(Seconds As Long) As Date
    On Error GoTo ErrorHandler
    Dim ftime               As FILETIME
    Dim stime               As SYSTEMTIME
    Dim DateTime            As Date
    Dim TimeZoneInfo(171)   As Byte
    
    DateTime = DateAdd("s", Seconds, #1/1/1970#)    ' time_t -> Date
    VariantTimeToSystemTime DateTime, stime         ' Date -> SYSTEMTIME
    
    'SystemTimeToFileTime stime, ftime               ' SYSTEMTIME -> FILETIME
    'FileTimeToLocalFileTime ftime, ftime            ' учитываем смещение согласно текущим региональным настройкам в системе
    'FileTimeToSystemTime ftime, stime               ' FILETIME -> SYSTEMTIME
    
    'alternate:
    'GetTimeZoneInformation VarPtr(TimeZoneInfo(0))
    'SystemTimeToTzSpecificLocalTime VarPtr(TimeZoneInfo(0)), stime, stime
    
    SystemTimeToTzSpecificLocalTime 0&, stime, stime    'tz can be 0, if tz is current
    
    SystemTimeToVariantTime stime, DateTime         ' SYSTEMTIME -> Date
    ConvertUnixTimeToLocalDate = DateTime
ErrorHandler:
End Function
 
Private Sub Form_Load()
    On Error GoTo ErrorHandler
 
    Const HKEY_LOCAL_MACHINE    As Long = &H80000002
    Const KEY_QUERY_VALUE       As Long = &H1&
    Const KEY_WOW64_64KEY       As Long = &H100&
 
    Dim hKey    As Long
    Dim ordType As Long
    Dim cData   As Long
    Dim lData   As Long
 
    RegOpenKeyEx HKEY_LOCAL_MACHINE, StrPtr("SOFTWARE\Microsoft\Windows NT\CurrentVersion"), 0&, KEY_QUERY_VALUE Or KEY_WOW64_64KEY, hKey
    
    If hKey <> 0 Then
        If (0 = RegQueryValueExLong(hKey, StrPtr("InstallDate"), 0&, 0&, lData, LenB(lData))) Then
            Debug.Print "Install Date is: " & ConvertUnixTimeToLocalDate(lData)
        End If
        RegCloseKey hKey
    End If
    
    Exit Sub
ErrorHandler:
    If hKey <> 0 Then RegCloseKey hKey
End Sub

    ' SV_CheckHoleChain = 1       ' - проверять всю цепочку доверия ( потребуется подключение к сети )
    ' SV_DoNotUseHashChecking = 2 ' - не использовать проверку по хешу
    ' SV_DisableCatalogVerify = 4 ' - не использовать проверку по каталогу безопасности
    ' SV_isDriver = 8             ' - выполнить проверку драйвера на соответствие стандарту WHQL

Private Const MAX_SIZE = 60000  '::: максимальный размер буфера
Private Const EXT = 1000        '::: начальный размер и приращение
 
Private Buff() As Byte      '::: буфер
Private ptr    As Long      '::: номер свободного байта
Private Size   As Long      '::: размер буфера
Private finp   As Integer   '::: номер входного файла
Private fout   As Integer   '::: номер выходного файла
 
'::: Поместить с копий байта b в буфер
 
Sub PutInBuff(b As Byte, c As Long)
 
    For i& = 1 To c
    
        '::: Если очередной байт еще умещается в буфере...
    
        If ptr < Size Then
        
           Buff(ptr) = b
           ptr = ptr + 1
           
        Else
        
           '::: Очередной байт уже не умещается
        
           If Size + EXT < MAX_SIZE Then
           
              '::: Если буфер еще можно расширить - расширим
           
              Size = Size + EXT
              
              ReDim Preserve Buff(1 To Size) As Byte
              
              Buff(ptr) = b
              ptr = ptr + 1
              
           Else
           
              Put #fout, , Chr$(255) '::: сигнатура "блок не сжат"
              Put #fout, , Size&     '::: размер буфера
              For j& = 1 To Size&
                  Put #fout, , Buff(i&)
              Next j&
                
              '::: Выделяем память для нового буфера
                
              Size = EXT
                
              ReDim Buff(1 To Size) As Byte
              
              ptr = 1
              
              Buff(ptr) = b
              ptr = ptr + 1
           
           End If
                      
        End If
 
    Next i&
 
End Sub
 
'::: Опустошить буфер
 
Sub FlushBuff()
 
    If ptr > 1 Then '::: если в буфере что-то накоплено...
             
       Put #fout, , Chr$(255) '::: сигнатура "блок не сжат"
       Put #fout, , (ptr - 1) '::: размер буфера
       
       For i& = 1 To (ptr - 1)
           Put #fout, , Buff(i&)
       Next i&
                                 
       ptr = 1
                          
    End If
 
End Sub
 
Sub Action(Count As Long, prev As Byte)
 
    '::: Сейчас Count& содержит количество одинаковых байтов
 
    If Count > 6 Then '::: сжимать имеет смысл
          
       '::: сначала - сброс несжатого блока
          
       FlushBuff
             
       '::: а теперь - сжатые данные
                    
       Put #fout, , Chr$(0)  '::: сигнатура "блок сжат"
       Put #fout, , Count    '::: счетчик
       Put #fout, , prev     '::: символ
             
    Else               '::: сжимать смысла нет
          
       PutInBuff prev, Count  '::: сбросим накопленные в буфер
          
    End If
 
End Sub
 
'::: Упаковка
 
Sub PackRLE()
 
Dim curr   As Byte
Dim prev   As Byte
 
    Size = EXT
 
    ReDim Buff(1 To Size) As Byte
    
    Count& = 1         '::: Счетчик
    
    Get #finp, , prev  '::: читаем первый байт
    
    ptr& = 1
    
    LI& = LOF(finp)    '::: длина исходного файла
    
    Do
           
       If Loc(finp) = LI& Then Exit Do '::: Если вышли за пределы файла...
    
       Get #finp, , curr       '::: Читаем очередной байт
       
       If curr = prev Then     '::: Если прочитан такой же байт
       
          Count& = Count& + 1  '::: копим количество
          
       Else                    '::: Обработаем предыдущий байт
          
          Action Count&, prev
             
          Count& = 1
             
       End If
    
       prev = curr             '::: Предыдущий = Текущему
    
    Loop
    
    '::: Финишные действия
    
    Action Count&, prev
    
    FlushBuff
 
    Close finp
    Close fout
 
End Sub
 
'::: Распаковка файла
 
Sub UnPackRLE()
 
Dim b As Byte
 
    LI& = LOF(finp)  '::: Длина файла
    
    Do
           
       If Loc(finp) = LI& Then Exit Do  '::: Если вышли за файл - выход
    
       Get #finp, , b
       
       If b = 0 Then '::: Сжатый блок
       
          Get #finp, , Count&
          Get #finp, , b
          
          For i& = 1 To Count&
              Put #fout, , b
          Next i&
              
       Else          '::: Несжатый блок
       
          Get #finp, , Sz&
          ReDim Buff(1 To Sz&) As Byte
          Get #finp, , Buff
          Put #fout, , Buff
       
       End If
    
    Loop
 
    Close finp
    Close fout
 
End Sub
 
Sub Main()
 
    HomeDir$ = ThisWorkbook.Path
    
    finp = FreeFile
    
    Open HomeDir$ + "\finp.tst" For Binary Access Read As #finp
    
    fout = FreeFile
    
    Open HomeDir$ + "\fout.pac" For Output As #fout
    
    Close fout
    
    fout = FreeFile
    
    Open HomeDir$ + "\fout.pac" For Binary Access Write As #fout
    
    
    PackRLE
       
       
    finp = FreeFile
    
    Open HomeDir$ + "\fout.pac" For Binary Access Read As #finp
    
    fout = FreeFile
    
    Open HomeDir$ + "\finp.new" For Output As #fout
    
    Close fout
    
    fout = FreeFile
    
    Open HomeDir$ + "\finp.new" For Binary Access Write As #fout
    
    
    UnPackRLE
 
    MsgBox "OK!"
 
End Sub
 
'::: Построение тестового файла
 
Sub MakeTest()
 
    Randomize
    
    HomeDir$ = ThisWorkbook.Path
    
    fo% = FreeFile
    
    Open HomeDir$ + "\finp.tst" For Output As #fo%
    
    Close fo%
    
    fo% = FreeFile
    
    Open HomeDir$ + "\finp.tst" For Binary Access Write As #fo%
    
    For i% = 1 To 20
    
        m% = Rnd * 100
        
        If m% Mod 2 = 0 Then
        
           '::: Повторение
        
           p& = Rnd * 255
           l& = Rnd * 1000
           
           If l& > 0 Then
              Buf$ = String$(l&, Chr$(p&))
              Put #fo%, , Buf$
           End If
        
        Else
        
           '::: Каша
           
           l& = Rnd * 1000
           
           Buf$ = String$(l&, Chr$(0))
           
           For j& = 1 To l&
           
               Mid$(Buf$, j&, 1) = Chr$(Rnd * 255)
               
           Next j&
               
           Put #fo%, , Buf$
                   
        End If
        
    Next i%
    
    Close #fo%
 
End Sub

Option Explicit
 
' Windows Scheduled Tasks Enumerator/Killer by Alex Dragokas
 
' You must add reference to c:\windows\system32 (SysWow64) \taskschd.dll
' Otherwise, specify variables with Object type instead of exact types of ITask group interfaces.
' Current decision - extracted Microsoft Type Library. You should register it first.
' Type Library registration tool by Steve McMahon may help.
 
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
 
' Action type constants
Private Const TASK_ACTION_EXEC          As Long = 0
Private Const TASK_ACTION_COM_HANDLER   As Long = 5&
Private Const TASK_ACTION_SEND_EMAIL    As Long = 6&
Private Const TASK_ACTION_SHOW_MESSAGE  As Long = 7&
 
' Task state
Private Const TASK_STATE_RUNNING        As Long = 4&
Private Const TASK_STATE_QUEUED         As Long = 2&
 
' Include hidden tasks enumeration
Private Const TASK_ENUM_HIDDEN          As Long = 1&
 
Private Const CLSCTX_INPROC_SERVER      As Long = 1&
 
Private Declare Function CLSIDFromString Lib "ole32.dll" (ByVal lpszGuid As Long, pGuid As GUID) As Long
Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, lpiid As Any) As Long
Private Declare Function CoCreateInstance Lib "ole32.dll" (rclsid As Any, ByVal pUnkOuter As Long, ByVal dwClsContext As Long, riid As Any, pvarResult As Object) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
Private CLSID_TaskScheduler As GUID
Private IID_ITaskService    As GUID
 
 
Public Sub EnumTasks()
    On Error GoTo ErrorHandler
 
    'Compatibility: Vista+
 
    ' Create the TaskService object.
    Dim Service As Object
    
    'Set Service = CreateObject("Schedule.Service")     '// VBScript
    
    CLSIDFromString StrPtr("{0F87369F-A4E5-4CFC-BD3E-73E6154572DD}"), CLSID_TaskScheduler      'или так (в принципе без разницы)
    IIDFromString StrPtr("{2FABA4C7-4DA9-4013-9697-20CC3FD40F85}"), IID_ITaskService
    CoCreateInstance CLSID_TaskScheduler, 0&, CLSCTX_INPROC_SERVER, IID_ITaskService, Service
    
    Service.Connect
 
    ' Get the root task folder that contains the tasks.
    Dim rootFolder As ITaskFolder
    Set rootFolder = Service.GetFolder("")
    
    ' Recursively call for enumeration of current folder and all subfolders
    EnumTasksInITaskFolder rootFolder
    
    Set rootFolder = Nothing
    Set Service = Nothing
 
    Exit Sub
 
ErrorHandler:
    Debug.Print "EnumTasks. Error: #" & Err.Number & " - " & Err.Description
End Sub
 
Sub EnumTasksInITaskFolder(rootFolder As ITaskFolder)
    On Error GoTo ErrorHandler
    
    Dim taskState   As String
    Dim taskFolder  As ITaskFolder
    
    Debug.Print "Folder Name: " & rootFolder.Name
    Debug.Print "Folder Path: " & rootFolder.Path
 
    Dim taskCollection As Object
    Set taskCollection = rootFolder.GetTasks(TASK_ENUM_HIDDEN)
 
    Dim numberOfTasks As Long
    numberOfTasks = taskCollection.Count
 
    Dim registeredTask  As IRegisteredTask
    Dim taskDefinition  As ITaskDefinition
    Dim taskAction      As IAction
    Dim taskActionExec  As IExecAction
    Dim taskActionEmail As IEmailAction
    Dim taskActionMsg   As IShowMessageAction
    Dim taskActionCOM   As IComHandlerAction
    
    If numberOfTasks = 0 Then
        Debug.Print "No tasks are registered."
    Else
        Debug.Print "Number of tasks registered: " & numberOfTasks
    
        For Each registeredTask In taskCollection
            With registeredTask
                Debug.Print "Task Name: " & .Name
                Debug.Print "Task Path: " & .Path
                
                Set taskDefinition = .Definition
                
                For Each taskAction In taskDefinition.Actions
                    Select Case taskAction.Type
                    
                        Case TASK_ACTION_EXEC
                            Set taskActionExec = taskAction
                            Debug.Print " Type: Executable"
                            Debug.Print "  Exec Path: " & taskActionExec.Path
                            Debug.Print "  Exec Args: " & taskActionExec.Arguments
                            Debug.Print "  Exec Type: " & taskActionExec.Type
                            
                        Case TASK_ACTION_SEND_EMAIL
                            Debug.Print " Type: Email"
                            Set taskActionEmail = taskAction
                            Debug.Print "  Recepient: " & taskActionEmail.To
                            Debug.Print "  Subject:   " & taskActionEmail.Subject
                        
                        Case TASK_ACTION_SHOW_MESSAGE
                            Debug.Print " Type: Message Box"
                            Set taskActionMsg = taskAction
                            Debug.Print "  Title: " & taskActionMsg.Title
                            
                        Case TASK_ACTION_COM_HANDLER
                            Debug.Print " Type: COM Handler"
                            Set taskActionCOM = taskAction
                            Debug.Print "  ClassID: " & taskActionCOM.ClassId
                            Debug.Print "  Data:    " & taskActionCOM.Data
 
                    End Select
                    
                Next
                
            End With
            
            Select Case registeredTask.State
                Case "0"
                    taskState = "Unknown"
                Case "1"
                    taskState = "Disabled"
                Case "2"
                    taskState = "Queued"
                Case "3"
                    taskState = "Ready"
                Case "4"
                    taskState = "Running"
            End Select
            
            If registeredTask.State <> TASK_STATE_DISABLED And registeredTask.Enabled = False Then taskState = taskState & " (Disabled)"
 
            Debug.Print "    Task State: " & taskState
            Stop
        Next
    End If
    
    Set taskActionExec = Nothing
    Set taskActionEmail = Nothing
    Set taskActionMsg = Nothing
    Set taskActionCOM = Nothing
    Set taskAction = Nothing
    Set taskDefinition = Nothing
    Set registeredTask = Nothing
    Set taskCollection = Nothing
    
    Dim taskFolderCollection As ITaskFolderCollection
    Set taskFolderCollection = rootFolder.GetFolders(0&)
 
    For Each taskFolder In taskFolderCollection 'deep to subfolders
        EnumTasksInITaskFolder taskFolder
    Next
    
    Set taskFolder = Nothing
    Set taskFolderCollection = Nothing
    
ErrorHandler:
    Debug.Print "EnumTasksInITaskFolder. Error: #" & Err.Number & " - " & Err.Description
End Sub
 
Public Function KillTask(TaskFullPath As String) As Boolean
    On Error GoTo ErrorHandler
    Dim TaskPath As String
    Dim TaskName As String
    Dim pos As Long
    
    'Compatibility: Vista+
    
    pos = InStrRev(TaskFullPath, "")
    If pos <> 0 Then
        TaskPath = Left$(TaskFullPath, pos)
        If Len(TaskPath) > 1 Then TaskPath = Left$(TaskPath, Len(TaskPath) - 1) 'trim last backslash
        TaskName = Mid$(TaskFullPath, pos + 1)
    Else
        Exit Function
    End If
 
    ' Create the TaskService object.
    Dim Service As Object
    Set Service = CreateObject("Schedule.Service")
    Service.Connect
 
    ' Get the root task folder that contains the tasks.
    Dim rootFolder As ITaskFolder
    Set rootFolder = Service.GetFolder(TaskPath)
    
    Dim registeredTask  As IRegisteredTask
    Set registeredTask = rootFolder.GetTask(TaskName)
    
    'Dim taskCollection As Object
    'Set taskCollection = rootFolder.GetTasks(TASK_ENUM_HIDDEN)
    '
    '    For Each registeredTask In taskCollection
    '        With registeredTask
    '          If InStr(1, .Path, TaskName, 1) <> 0 Then
    '            Debug.Print "Task Name: " & .Name
    '            Debug.Print "Task Path: " & .Path
    '          End If
    '
    '        End With
    '    Next
    'Stop
    
    ' Stop the task
    If registeredTask.State = TASK_STATE_RUNNING Or registeredTask.State = TASK_STATE_QUEUED Then
        registeredTask.Stop 0&
        Sleep 2000&                 ' Async. call. Must wait a little.
                                    ' Maybe it is much better to track for threads
    End If
    
    If registeredTask.Enabled Then registeredTask.Enabled = False
    
    Dim taskDefinition  As ITaskDefinition
    Dim taskAction      As IAction
    Dim taskActionExec  As IExecAction
    
    ' Kill process
    Set taskDefinition = registeredTask.Definition
    
    For Each taskAction In taskDefinition.Actions
        If TASK_ACTION_EXEC = taskAction.Type Then
            Set taskActionExec = taskAction
            Debug.Print taskActionExec.Path
            'If fileexists(taskActionExec.Path) Then
            '    KillProcessByFile taskActionExec.Path
            'End If
        End If
    Next
    
    ' Remove the Job
    rootFolder.DeleteTask TaskName, 0&
    Sleep 1000&
    
    KillTask = True
    
    Set taskActionExec = Nothing
    Set taskAction = Nothing
    Set taskDefinition = Nothing
    Set registeredTask = Nothing
    Set rootFolder = Nothing
    Set Service = Nothing
    Exit Function
ErrorHandler:
    Debug.Print "KillTask. Error: #" & Err.Number & " - " & Err.Description
End Function

Option Explicit
Option Compare Text
'
'Программа для разделения и сборки файлов
'© by the Fever Brain 2016
'
Const r& = 90, gen$ = "prt", stic$ = "cut.ico", jpg = "W.jpg", sl$ = "", t$ = ".", s1$ = "(", s2$ = ")", mxprt& = 100
 
Dim WithEvents cbx1 As ComboBox, WithEvents cbx2 As ComboBox
Dim WithEvents l1 As Label, WithEvents l2 As Label
Dim WithEvents cm1 As CommandButton, WithEvents cm2 As CommandButton
Dim WithEvents ch1 As CheckBox, WithEvents ch2 As CheckBox
Dim WithEvents cm3 As CommandButton, WithEvents ch3 As CheckBox
Dim WithEvents im As Image
Dim m_hMod&, fldr$, oldD$, sz&, ll&, tt&, w&, hh&, i&, v
Dim mfso As Object, mshapp As Object, dic As Object
 
Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
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 Sub Form_Initialize()
    m_hMod = LoadLibrary("shell32.dll")
    InitCommonControls
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    'Заходим в первоначальную папку, и сохраняем настройки
    ChDir oldD
    SaveSetting "Divisor", "Check", "1", ch1.Value
    SaveSetting "Divisor", "Check", "2", ch2.Value
    SaveSetting "Divisor", "Check", "3", ch3.Value
    FreeLibrary m_hMod
End Sub
 
 
Private Sub cbx1_Click()
    Dim ge As Boolean, fe As Boolean, sys As Boolean
    On Error Resume Next
    With fso
        cbx2Ref
        fe = .fileexists(cbx1.Text)
        ge = .GetExtensionName(cbx1.Text) = gen
        sys = .GetFile(cbx1.Text).Attributes And 4 'Если системный
        cm2.Enabled = fe And ge
        cm3.Enabled = fe And (Not cm2.Enabled) And cbx2.ListCount > 0
        cbx2.Enabled = Not (cm2.Enabled)
        ch1.Enabled = fe And (Not ge) And (Not sys)
        ch2.Enabled = fe And ge
    End With
End Sub
 
Private Sub cm3_Click()
    Dim del&, s$, part&, os&, b() As Byte, i&, n&
    'Разбиение
    s = Split(cbx2.Text)(0): If IsNumeric(s) Then del = s
    
    s = ""
    part = sz \ del
    os = sz Mod del
    For i = 1 To sz Step part
        b = ReadBytes(cbx1.Text, (i), part)
        n = n + 1: WriteBytes cbx1.Text & s1 & n & ").prt", b, , 1
    Next
    If i <= sz Then
         b = ReadBytes(cbx1.Text, (i), os)
        n = n + 1: WriteBytes cbx1.Text & s1 & n & ").prt", b, , 1
    End If
    For n = n + 1 To mxprt + 1
        'Удаление частей с высшей нумерацией
        s = cbx1.Text & s1 & n & s2 & t & gen
        If fso.fileexists(s) Then fso.DeleteFile s, 1
    Next
    If ch1.Value > 0 And ch1.Enabled = True Then
         'Удаление родительского файла
         On Error Resume Next
         fso.DeleteFile cbx1.Text, 1
    End If
    s = cbx1.Text & s1 & 1 & s2 & t & gen
    If fso.fileexists(s) Then cbx1.Text = s
    fldrRef
    If ch3.Value > 0 Then PlaySound "Windows Vista Notify.wav", 0, &H1 Or &H20000
End Sub
 
 
Private Sub cm2_Click()
    'Сборка
    Dim s$(4), ss$, j$(), i&, ii&, start&, b() As Byte
    dic.RemoveAll
    With fso
        s(0) = sss(cbx1.Text, s(1), s(2), s(3), s(4))
        ss = s(4)
        For i = 0 To cbx1.ListCount - 1
            On Error Resume Next
            Erase s
            s(0) = sss(cbx1.List(i), s(1), s(2), s(3), s(4))
            If s(4) = ss And IsNumeric(s(3)) Then dic.Add i, s(0)
        Next
        ii = dic.Count - 1: ReDim j(ii)
        For i = mxprt + 1 To 1 Step -1
            s(0) = ss & s1 & i & s2 & "." & gen
            If .fileexists(s(0)) Then j(ii) = s(0): ii = ii - 1
        Next
    End With
 
    For i = 0 To UBound(j)
        b = ReadBytes(j(i))
        start = WriteBytes(ss, b, (start), i = 0)
         'Удаление
        If ch2.Value = 1 And ch2.Enabled = True Then
            fso.DeleteFile j(i), 1
        End If
    Next
 
    cbx1.Text = ss
    fldrRef
    If ch3.Value > 0 Then PlaySound "Windows Vista Notify.wav", 0, &H1 Or &H20000
End Sub
 
Function sss(ss0$, ss1$, ss2$, ss3$, ss4$) As String
    'Фильтрация
    With fso
        sss = ss0
        ss1 = .GetExtensionName(ss0)
        ss2 = StrReverse(.GetBaseName(ss0))
        ss3 = Split(Split(ss2, s1, 2)(0), s2, 2)(1)
        ss4 = StrReverse(Split(ss2, s1, 2)(1))
    End With
End Function
 
Sub cbx2Ref()
    With cbx2
        On Error GoTo er:
        sz = fso.GetFile(cbx1.Text).Size
        cbx1.ToolTipText = "Файл: " & fso.GetAbsolutePathName(cbx1.Text) & "    Размер: " & sz
er:
        .Clear
        For i = mxprt To 2 Step -1
            If (sz \ i) > 0 Then .AddItem i & IIf(i > 4, " Частей", " Части"), 0
        Next
        If .ListCount Then
            .ListIndex = 0
        Else
            .Text = "Разбить нельзя"
        End If
    End With
End Sub
 
Private Sub Form_Resize()
    Me.WindowState = 0
    Me.Width = cm3.Left + cm3.Width + (Me.Width - Me.ScaleWidth) + r * 2
    Me.Height = cm3.Top + cm3.Height + (Me.Height - Me.ScaleHeight) + r * 2
End Sub
 
Private Sub cm1_Click()
    On Error GoTo ext
    sz = 0: cbx1.ToolTipText = ""
    fldr = shapp.BrowseForFolder(0, "Текущая, установленная  папка " & vbLf & fldr, 100, "").self.Path
    fldrRef
ext:
    cbx1_Click
End Sub
 
 
Sub fldrRef()
    'Обновление папки
    Dim v, s$
    ChDir fldr
    s = cbx1.Text
    With fso.GetFolder(fldr)
        cbx1.Clear
        For Each v In .Files
            cbx1.AddItem v.Name
        Next
        If fso.fileexists(s) Then cbx1.Text = s: cbx1_Click Else cbx1.ListIndex = 0
    End With
End Sub
 
 
Private Property Get shapp() As Object
    If mshapp Is Nothing Then Set mshapp = CreateObject("Shell.Application")
    Set shapp = mshapp
End Property
 
Private Property Get fso() As Object
    If mfso Is Nothing Then Set mfso = CreateObject("scripting.filesystemobject")
    Set fso = mfso
End Property
 
Private Sub cbx1_KeyPress(KeyAscii As Integer): KeyAscii = 0: End Sub
Private Sub cbx2_KeyPress(KeyAscii As Integer): KeyAscii = 0: End Sub
 
Private Sub Form_Load()
    ll = r: tt = r: w = r * 10: hh = r * 2
    oldD = CurDir$
    ChDir App.Path
    
    For Each v In Controls: v.Visible = 0: Next
    If fso.fileexists(jpg) Then
        Set im = Controls.Add("vb.image", "im")
        With im
            .Move ll, tt, w, r * 23
            .Stretch = 1
            .Picture = LoadPicture(jpg)
            .Visible = 1
        End With
        ll = ll + w + r
    End If
    Set l1 = Controls.Add("vb.Label", "l1")
    With l1
        .Move ll, tt, w, hh
        .Caption = "Файл:"
        .Visible = 1
    End With
    Set cbx1 = Controls.Add("vb.ComboBox", "cbx1")
    With cbx1
        .Move ll + l1.Width + r, tt, r * 30 ', hh
        .Visible = 1
    End With
    tt = tt + l1.Height + r * 2
    Set l2 = Controls.Add("vb.Label", "l2")
    With l2
        .Move ll, tt, w, hh
        .Caption = "Разбить на:"
        .Visible = 1
    End With
    Set cbx2 = Controls.Add("vb.ComboBox", "cbx2")
    With cbx2
        .Move ll + l1.Width + r, tt, r * 30 ', hh
        .ToolTipText = "Максимум на сколько частей можно разбить этот файл"
        .Visible = 1
    End With
    tt = tt + l2.Height + r * 2
    
    Set ch1 = Controls.Add("vb.CheckBox", "ch1")
    With ch1
        .Move ll, tt, r * 40, r * 3
        .Caption = "Удалить родительский файл"
        .Visible = 1
    End With
    tt = tt + l2.Height + r * 2
    Set ch2 = Controls.Add("vb.CheckBox", "ch2")
    With ch2
        .Move ll, tt, r * 40, r * 3
        .Caption = "Удалить части"
        .Visible = 1
    End With
    tt = tt + l2.Height + r * 2
    Set ch3 = Controls.Add("vb.CheckBox", "ch3")
    With ch3
        .Move ll, tt, r * 40, r * 3
        .Caption = "Звуки"
        .Visible = 1
    End With
    tt = tt + l2.Height + r * 2
    Set cm1 = Controls.Add("vb.CommandButton", "cm1")
    With cm1
        .Move ll, tt, r * 13, r * 3
        .Caption = "Папка .."
        .Visible = 1
    End With
    Set cm2 = Controls.Add("vb.CommandButton", "cm2")
    With cm2
        .Move ll + r * 14, tt, r * 13, r * 3
        .Caption = "Собрать"
        .Visible = 1
    End With
    Set cm3 = Controls.Add("vb.CommandButton", "cm3")
    With cm3
        .Move ll + r * 28, tt, r * 13, r * 3
        .Caption = "Разбить"
        .Visible = 1
    End With
    Set dic = CreateObject("scripting.dictionary")
    dic.CompareMode = 1
    ch1.Value = GetSetting("Divisor", "Check", "1", 0)
    ch2.Value = GetSetting("Divisor", "Check", "2", 0)
    ch3.Value = GetSetting("Divisor", "Check", "3", 1)
    fldr = App.Path
    fldrRef
    cbx1_Click
    On Error Resume Next
    With Me
        .Icon = LoadPicture(stic)
        .Caption = "Разбиение файлов"
        Me.Left = (Screen.Width - Me.Left) / 3
        Me.Top = (Screen.Height - Me.Top) / 3
    End With
End Sub
 
Private Function ReadBytes(FileName$, Optional ByRef start&, Optional ByVal dln&) As Byte()
    'Чтение байт из файла
    'Арг: Путь // Старт // Длина по умолчанию всего файла
    'Возврат: Массив байт и следующая позиция чтения
    Dim n, f: On Error Resume Next
    f = FreeFile
    Open FileName For Binary As #f
    If start Then Else start = 1
    n = LOF(f) - start + 1
    If dln = 0 Or dln > n Then dln = n
    ReDim Preserve ReadBytes(dln - 1)
    Get #f, start, ReadBytes: Close #f
    start = start + UBound(ReadBytes) + 1
End Function
 
Private Function WriteBytes(FileName$, Bytes() As Byte, Optional ByRef start&, _
Optional Overwrite As Boolean)
    'Запись байт в файл
    'Арг: Путь // Массив байт // Старт // Флаг перезаписи
    'Возврат: Следующая позиция записи (при успешном выполнении)
    Dim n, f: On Error Resume Next
    If start Then Else start = 1
    f = FreeFile 'Определяем номер свободного файла
    If Overwrite Then Kill FileName
    Open FileName$ For Binary As #f: Put #f, start, Bytes: Close #f 'Копируем !
    WriteBytes = start + UBound(Bytes) + 1
End Function