Можно ли обменяться значениями между EXE файлами - VB
Формулировка задачи:
Вопрос у меня такой, я хочу изготовить
exe
-шник который бы принимал тот или иной параметр из командной строки и так-же мог передавать параметр по окончанию выполнения в командную строку как это сделать ?, и можно ли это сделать ? Конечно, я уже рассматривал такой вариант чтоб обмениваться параметрами в реестре но мне нужно сделать так чтобexe
-шник можно было запустить одной командной линией ...Решение задачи: «Можно ли обменяться значениями между EXE файлами»
textual
Листинг программы
Option Explicit DefLng F, I, L, N: DefStr J, S ' ' © FelixMacintosh 2014 ' Const hlpMesage = "" & _ "Команды могут быть с большой или маленькой буквы" & vbCrLf & _ "Также можно вводить несколько команд" & vbCrLf & _ "Список команд:" & vbCrLf & _ "/s [путь к файлу] ; [путь для нового файла] ; [байтовый адрес]= Разделить файл" & vbCrLf & _ "/j [главный файл] ; [пришиваемый файл] = Объединить два файла" & vbCrLf & _ "/z [путь к zip архиву] ; [путь на диске] = Добавить в архив" & vbCrLf & _ "/uz [путь к zip архиву] ; [путь в архиве] ; [папка на диске] = Извлеч из архива" & vbCrLf & _ vbTab & "* Примечание папку на диске можно не указывать" & vbCrLf & _ vbTab & "в этом случае это будет текущая папка" & vbCrLf & _ "/r [путь к файлу] = Регистрация" & vbCrLf & _ "/u [путь к файлу] = Отмена регистрации" & vbCrLf & _ "/h или /help вызов этого сообщения" & vbCrLf & _ "© FelixMacintosh 2014 http://www.cyberforum.ru/members/445967.html" Private Shell As Object 'As Shell ' 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 Const INFINITE = -1& Private Const SYNCHRONIZE = &H100000 Private Const TH32CS_SNAPTHREAD = &H4 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 Sub Main() Const r = "/", p = " ", w = ";" Dim f, i, j(), s, j1(), j2(), Start&, b() As Byte Set Shell = CreateObject("Shell.Application") Set Fso = CreateObject("Scripting.FileSystemObject") j = Split(Command$, r) s = Command$ On Error Resume Next: DeleteSetting App.EXEName On Error GoTo 1 For f = 1 To UBound(j) j1 = Split(Trim(j(f)), p, 2) For i = 0 To UBound(j1): j1(i) = Trim(j1(i)): Next '--------- Select Case LCase(j1(0)) Case "s" j2 = Split(j1(1), w) For i = 0 To UBound(j2): j2(i) = Trim(j2(i)): Next SS "s", "Len", WriteBytes(j2(1), ReadBytes(j2(0), CLng(j2(2)))) Case "j" j2 = Split(j1(1), w) For i = 0 To UBound(j2): j2(i) = Trim(j2(i)): Next Start = Fso.GetFile(j2(0)).Size + 1 SS "J", "Start", Start SS "J", "Len", WriteBytes(j2(0), ReadBytes(j2(1)), Start) - 1 Case "uz" j2 = Split(j1(1), w) For i = 0 To UBound(j2): j2(i) = Trim(j2(i)): Next 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 "uz", UnZipFile(j2(1), j2(2)) End If Case "z" j2 = Split(j1(1), w) For i = 0 To UBound(j2): j2(i) = Trim(j2(i)): Next If Fso.FileExists(j2(0)) And LCase(Fso.GetExtensionName(j2(0))) = "zip" Then 'Используем архив Archive = Fso.GetAbsolutePathName(j2(0)) SS "z", CopyPathToArchive(Fso.GetAbsolutePathName(j2(1))) ElseIf LCase(Fso.GetExtensionName(j2(0))) = "zip" Then 'Создаём архив CreateArchive Fso.GetAbsolutePathName(j2(0)) SS "z", CopyPathToArchive(Fso.GetAbsolutePathName(j2(1))) End If Case "r" SS "r", RegSvr32(j1(1)) Case "u" SS "u", RegSvr32(j1(1), True) Case "h", "help" SS "h", MsgBox(hlpMesage) Case Else 'Не выполнена ни одна комманда End Select Next '-------------------------Конец программы Set Shell = Nothing Set Fso = Nothing Exit Sub 1 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 = Shell.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 Shell.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 = Shell.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 = Shell.NameSpace((vNewValue)) End If End Property Private Function RegSvr32(Path$, Optional UnReg As Boolean) As Boolean Const INFINITE = -1&, SYNCHRONIZE = &H100000 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 = Shell("RegSvr32 /s /u " & Path) Else hShell = Shell("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
ИИ поможет Вам:
- решить любую задачу по программированию
- объяснить код
- расставить комментарии в коде
- и т.д