Option Explicit
DefLng F, I, L, N: DefStr J, S
'
' © FelixMacintosh 2014
'
Const hlpMesage = "" & _
"Команды могут быть с большой или маленькой буквы" & vbCrLf & _
"Также можно вводить несколько команд" & vbCrLf & _
"Список команд:" & vbCrLf & _
"/s [путь к файлу] ; [путь для нового файла] ; [байтовый адрес]" & vbTab & "= Отделить файл" & vbCrLf & _
"/j [главный файл] ; [пришиваемый файл] " & vbTab & "= Объединить два файла" & vbCrLf & _
"/z [путь к zip архиву] ; [путь на диске] " & vbTab & "= Добавить в архив" & vbCrLf & _
"/uz [путь к zip архиву] ; [путь в архиве] ; [папка на диске] " & vbTab & "= Извлеч из архива" & vbCrLf & _
vbTab & "* Примечание папку на диске можно не указывать" & vbCrLf & _
vbTab & "в этом случае это будет текущая папка" & vbCrLf & _
"/r [путь к файлу]" & vbTab & "= Регистрация" & vbCrLf & _
"/u [путь к файлу]" & vbTab & "= Отмена регистрации" & vbCrLf & _
"/cmd [новая комманда отсюда]" & vbTab & "= Любая консольная команда" & vbCrLf & _
"/h или /help " & vbTab & "= Вызов этого сообщения" & vbCrLf & _
"Производство:" & vbCrLf & _
"© FelixMacintosh 2014" & vbTab & "http://vk.com/FelixMacintosh"
'
Private Const Infinite = -1&
Private Const Synchronize = &H100000
Private Const TH32CS_SNAPTHREAD = &H4
'
Private WshShell As Object 'As WshShell '
Private Fso As Object 'As FileSystemObject '
Private mArchive As Object
'
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 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 OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId 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 WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Function WaitShell(MyCommand$) As Long
'
'Вызов Shell и новой команды, с ожиданием её завершения
'
Dim hProc&
WaitShell = Shell(MyCommand)
hProc = OpenProcess(Synchronize, False, WaitShell)
WaitForSingleObject hProc, Infinite
CloseHandle hProc
End Function
Private Sub SS(ByVal Section$, ByVal Key$, Optional ByVal Setting$ = "0")
SaveSetting App.EXEName, Section, Key, Setting
End Sub
Private Function GS(ByVal Section$, ByVal Key$, Optional ByVal Setting$ = "0")
GS = GetSetting(App.EXEName, Section, Key, "")
End Function
Private Sub TrimArray(Arr() As String)
Dim i&
For i = 0 To UBound(Arr): Arr(i) = Trim(Arr(i)): Next
End Sub
Private Sub Main()
Const r = "/", p = " ", w = ";"
Dim f, j(), s, j1(), j2(), Start&
Set WshShell = CreateObject("Shell.Application")
Set Fso = CreateObject("Scripting.FileSystemObject")
s = Command$
j = Split(s, r)
On Error Resume Next: DeleteSetting App.EXEName
On Error GoTo EndProgramm
For f = 1 To UBound(j)
j1 = Split(Trim(j(f)), p, 2): TrimArray j1
'---------
Select Case LCase(j1(0))
Case "cmd"
SS j1(0), WaitShell(j1(1))
Case "s"
j2 = Split(j1(1), w): TrimArray j2
SS j1(0), "Len", WriteBytes(j2(1), ReadBytes(j2(0), CLng(j2(2))), , True)
Case "j"
j2 = Split(j1(1), w): TrimArray j2
Start = Fso.GetFile(j2(0)).Size + 1
SS j1(0), "Start", Start
SS j1(0), "Len", WriteBytes(j2(0), ReadBytes(j2(1)), Start) - 1
Case "uz"
j2 = Split(j1(1), w): TrimArray j2
If Fso.FileExists(j2(0)) And LCase(Fso.GetExtensionName(j2(0))) = "zip" Then
If UBound(j2) = 1 Then
ReDim Preserve j2(2): j2(2) = CurDir$
End If
Archive = Fso.GetAbsolutePathName(j2(0))
SS j1(0), UnZipFile(j2(1), j2(2))
End If
Case "z"
j2 = Split(j1(1), w): TrimArray j2
If Fso.FileExists(j2(0)) And LCase(Fso.GetExtensionName(j2(0))) = "zip" Then
'Используем архив
Archive = Fso.GetAbsolutePathName(j2(0))
SS j1(0), CopyPathToArchive(Fso.GetAbsolutePathName(j2(1)))
ElseIf LCase(Fso.GetExtensionName(j2(0))) = "zip" Then
'Создаём архив
CreateArchive Fso.GetAbsolutePathName(j2(0))
SS j1(0), CopyPathToArchive(Fso.GetAbsolutePathName(j2(1)))
End If
Case "r"
SS j1(0), RegSvr32(j1(1))
Case "u"
SS j1(0), RegSvr32(j1(1), True)
Case "h", "help"
SS j1(0), MsgBox(hlpMesage)
Case Else
'Не выполнена ни одна комманда
End Select
Next
EndProgramm:
'-------------------------Конец программы
Set WshShell = Nothing
Set Fso = Nothing
End Sub
Private Function CopyHere(Parent, vItem) As Boolean
'
'Функция копирования
'Аргументы: Папка (Zip-папка) // Копируемый объект
Dim f&, Key$, hnd&
Dim Trd(2) As Collection
Dim tid As Long, hTrd As Long
On Error Resume Next
'Получаем список потоков !
GetThreadsList Trd(0) 'Запомнить старые потоки
Call Parent.CopyHere((vItem)) 'Копирование >>>>>>>>>>>>
GetThreadsList Trd(1) 'Запомнить новые потоки
If vItem.Count > 0 Then If Err.Number = 0 Then GoTo 1 'В этом случае ждать не нужно
Err.Clear 'Сброс всех ошибок
Set Trd(2) = New Collection
For f = Trd(1).Count To 1 Step -1
Key = "C" & Trd(1).Item(f)
hnd = Trd(0)(Key)
If hnd = 0 Then Trd(2).Add CLng(Mid$(Key, 2))
Next
For f = 1 To Trd(2).Count 'Ожидание открытых потоков
tid = Trd(2).Item(f)
hTrd = OpenThread(Synchronize, False, tid)
WaitForSingleObject hTrd, Infinite
CloseHandle hTrd
Next
CopyHere = True
Exit Function
1
End Function
Private Sub GetThreadsList(List As Collection)
'
' Возвращает List с коллекцией потоков
'
Dim hSnap As Long, TE As THREADENTRY32, PID As Long
Set List = New Collection
hSnap = CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0)
If hSnap = -1 Then Exit Sub
TE.dwSize = Len(TE)
PID = GetCurrentProcessId()
If Thread32First(hSnap, TE) Then
Do
If TE.th32OwnerProcessID = PID Then List.Add TE.th32ThreadID, "C" & CStr(TE.th32ThreadID)
Loop While Thread32Next(hSnap, TE)
End If
CloseHandle hSnap
End Sub
Public Function UnZipFile(ByVal ParseName$, ByVal DestPath$) As Boolean
'
'Извлечение из архива
'Аргументы:
'DestPath - Путь к папке для распаковки архива
'ParseName - Путь в архиве
'Примечание: Имена файлов в архиве, должны быть полными !
'
Dim DestDir As Object, Parse As Object
If (mArchive Is Nothing) Then Exit Function 'Проверяем указан ли архив ?
On Error GoTo 1
If Not Fso.FolderExists(DestPath) Then 'Проверяем есть ли папка
Fso.CreateFolder (DestPath) 'Создаём папку для перемещаемых туда объектов
End If
Set DestDir = WshShell.NameSpace((DestPath))
Set Parse = mArchive.ParseName((ParseName))
UnZipFile = CopyHere(DestDir, Parse)
Exit Function
1
End Function
Public Function NameArchiveFiles$(Optional ByVal ind&, Optional ByVal NameOnly As Boolean)
'
'Возврат имени файла в архиве
'Аргументы:
'ZipName - имя архива
'Ind - номер файла в архиве (начало с 0), по умолчанию - 0
'NameOnly - Только имя, без расширения
'
If (mArchive Is Nothing) Then Exit Function 'Проверяем указан ли архив ?
On Error Resume Next
If NameOnly Then
NameArchiveFiles = mArchive.Items().Item((ind)).Рath
Else
NameArchiveFiles = mArchive.Items().Item((ind)).Name
End If
End Function
Public Function CopyPathToArchive(ByVal FilePath$) As Boolean
'
'Копирует файл / папку в архив
'Арг: полное имя
'
If (mArchive Is Nothing) Then Exit Function 'Проверяем указан ли архив ?
If Len(Dir(FilePath, vbDirectory)) > 0 And Len(Dir(FilePath)) = 0 Then
If WshShell.NameSpace((FilePath)).Items.Count = 0 Then
MsgBox ("Нельзя добавить пустую папку")
Exit Function
End If
End If
'mArchive.CopyHere (FilePath)
CopyPathToArchive = CopyHere(mArchive, FilePath) 'Копируем в архив
End Function
Public Function CreateArchive(ByVal Рath$) As Boolean
'
'Создаёт новый архив
'Возврат утверждения о создании
'
If Fso.FileExists(Рath) Then Kill Рath
Fso.CreateTextFile(Рath, True).Write "PK" & Chr(5) & Chr(6) & String(18, 0)
Set mArchive = WshShell.NameSpace((Рath))
CreateArchive = Not (mArchive Is Nothing) 'Возврат утверждения о создании
End Function
Public Property Get Archive() As Variant
'
'Возвращает объект архива
'
Set Archive = mArchive
End Property
Public Property Let Archive(ByVal vNewValue As Variant)
'
'Свойство: Archive = Файловый путь
'Арг: полное имя
'
If Fso.FileExists(vNewValue) Then
Set mArchive = WshShell.NameSpace((vNewValue))
End If
End Property
Private Function RegSvr32(Path$, Optional UnReg As Boolean) As Boolean
Dim hProc&, hShell&
If Fso.FileExists(Path) = False Then Exit Function
Select Case LCase(Fso.GetExtensionName(Path))
Case "dll", "ocx"
Case Else: Exit Function
End Select
If UnReg Then
hShell = WshShell("RegSvr32 /s /u " & Path)
Else
hShell = WshShell("RegSvr32 /s " & Path)
End If
hProc = OpenProcess(Synchronize, False, hShell)
WaitForSingleObject hProc, Infinite
CloseHandle hProc
RegSvr32 = True
End Function
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
If Err = 0 Then Start = Start + UBound(ReadBytes) + 1
End Function
Private Function WriteBytes&(FileName$, Bytes() As Byte, Optional ByVal 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 'Копируем !
If Err = 0 Then WriteBytes = Start + UBound(Bytes) + 1
End Function