|
Каталог статей
Архивирование RARом через CreateProcess
Архивирование RARом через CreateProcess
Option Compare Database Option Explicit ________________________________________
Public x_DestName$ 'имя архивируемого/разархивируемого файла
'путь к архиватору - в данном примере к RAR.exe :)) Public xPacker$ '******************************************************** ' ' Process Exexute ' Const INFINITE = &HFFFF 'StartupInfo constants Public Const STARTF_FORCEOFFFEEDBACK = &H80 Public Const STARTF_FORCEONFEEDBACK = &H40 Public Const STARTF_RUNFULLSCREEN = &H20 Public Const STARTF_USECOUNTCHARS = &H8 Public Const STARTF_USEFILLATTRIBUTE = &H10 Public Const STARTF_USEPOSITION = &H4 Public Const STARTF_USESHOWWINDOW = &H1 Public Const STARTF_USESIZE = &H2 Public Const STARTF_USESTDHANDLES = &H100 'ShowWindow constants Public Const SW_HIDE = 0 Public Const SW_SHOWNORMAL = 1 Public Const SW_SHOWMINIMIZED = 2 Public Const SW_MAXIMIZE = 3 Public Const SW_SHOWMAXIMIZED = 3 Public Const SW_SHOWNOACTIVATE = 4 Public Const SW_SHOW = 5 Public Const SW_MINIMIZE = 6 Public Const SW_SHOWMINNOACTIVE = 7 Public Const SW_SHOWNA = 8 Public Const SW_RESTORE = 9 Public Const SW_SHOWDEFAULT = 10
Public Type PROCESS_INFORMATION hProcess As Long hThread As Long dwProcessId As Long dwThreadId As Long End Type
Public Type STARTUPINFO cb As Long lpReserved As String lpDesktop As String lpTitle As String 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
Declare Function CreateProcess Lib "kernel32" Alias _ "CreateProcessA" (ByVal lpApplicationName As String, _ ByVal lpCommandLine As String, lpProcessAttributes As _ Any, lpThreadAttributes As Any, ByVal bInheritHandles _ As Long, ByVal dwCreationFlags As Long, lpEnvironment _ As Any, ByVal lpCurrentDriectory As String, _ lpStartupInfo As STARTUPINFO, lpProcessInformation As _ PROCESS_INFORMATION) As Long
Declare Function CloseHandle Lib "kernel32" (ByVal _ hObject As Long) As Long
Declare Function WaitForSingleObject Lib "kernel32" _ (ByVal hHandle As Long, ByVal dwMilliseconds As Long) _ As Long
Function ArxTest() 'Запустить для проверки xPacker = "c:\Arx\" PackFile "", "e:\test.mdb", "e:\test1.rar", 0 End Function ________________________________________
'так... одна фспомагательная ф-я :)) Public Function Ничего(v) On Error Resume Next If IsEmpty(v) Then Ничего = True: Exit Function If IsNull(v) Then Ничего = True: Exit Function If Len(v) <= 0 Then Ничего = True: Exit Function Ничего = False: Exit Function End Function ________________________________________
Function CW$(WS) Dim i% On Error GoTo CWEr i = InStr(WS, Chr(0)) If i > 0 Then CW = Left$(WS, i - 1) Else CW = WS Exit Function CWEr: MsgBox Err.Description: Exit Function End Function ________________________________________
' 'возвращает или имя без расширения (n) или просто расширение (e) 'или просто путь (p) ' Function PartFile$(flnm$, mode$) Dim i%, ix%, p$ On Error GoTo errPartFile PartFile = "" If Ничего(flnm) Then Exit Function Select Case mode Case "n" i = 0 Do: ix = i: i = InStr(i + 1, flnm, "\") Loop While i p = Right(flnm, Len(flnm) - ix) i = InStr(p, ".") If i Then p = Left(p, i - 1) PartFile = p Case "e" If Left(Right(flnm, 4), 1) = "." Then PartFile = _ Right(flnm, 3) Case "p" i = 0: Do: ix = i: i = InStr(i + 1, flnm, "\") Loop While i PartFile = Left(flnm, ix) End Select Exit Function errPartFile: MsgBox Err.Description Exit Function End Function ________________________________________
Public Function RunAndWait(ComLine As String, _ DefaultDir As String, ShowFlag&) As Boolean Dim si As STARTUPINFO Dim pi As PROCESS_INFORMATION si.wShowWindow = ShowFlag si.dwFlags = STARTF_USESHOWWINDOW If CreateProcess(vbNullString, ComLine, ByVal 0&, _ ByVal 0&, False, 0, ByVal 0&, DefaultDir, si, _ pi) Then WaitForSingleObject pi.hProcess, INFINITE CloseHandle pi.hProcess RunAndWait = True Exit Function End If RunAndWait = False End Function ________________________________________
'cap - сообщение; ff-файл откуда;ft-файл куда;mode=1 'после архивирования - удалить нах! :)) Function PackFile(CAP$, FF$, FT$, _ Optional mode As Byte = 1) Dim x_PackerDest$, hwnd&, DDir$, DF$ PackFile = 0 'вывести какуюнить заставку : (CAP + " ...", _ "Сжатие ...") x_PackerDest = Nz(xPacker, "") If Ничего(x_PackerDest) Then GoTo crerr If Ничего(FT) Then x_DestName = Left(FF, Len(FF) - 3) + "rar" Else x_DestName = FT End If If mode = 0 Then DF = " " Else DF = " -df " DDir = Nz(PartFile(FF, "p"), "C:\") If Not RunAndWait(Chr$(34) + x_PackerDest + _ "RAR.EXE" + Chr$(34) + " a -ep -m5 -o+" + DF + Chr$(34) +_ x_DestName + Chr$(34) + " " + Chr$(34) + FF + Chr$(34),_ DDir, SW_HIDE) Then GoTo crerr If Not Ничего(Dir(x_DestName)) Then PackFile = -1 x_DestName = Trim(CW(x_DestName)) 'конец заспаковки Exit Function crerr: 'конец заспаковки PackFile = False Exit Function End Function ________________________________________
Function UnPackFile(CAP$, FF$, FT$) Dim x_PackerDest$, hwnd&, DDir$, fo%, nf& 'cn(CAP + " ...", " Распаковка ...") x_PackerDest = Nz(xPacker, ""): If Ничего(x_PackerDest) Then UnPackFile = 0: GoTo cruer UnPackFile = 0: x_DestName = Left(FF, Len(FF) - 3) DDir = Nz(PartFile(FF, "p"), "C:\") If Not RunAndWait(Chr$(34) + x_PackerDest + "RAR.EXE" + Chr$(34) +_ " e -y " + Chr$(34)+ FF + Chr$(34) + " " + Chr$(34) + FT +_ Chr$(34), DDir, SW_HIDE) Then GoTo cruer If Not Ничего(Dir(x_DestName)) Then UnPackFile = -1 'конец распаковки Exit Function cruer: 'конец распаковки UnPackFile = False Exit Function End Function ________________________________________
Источник: http://www.hiprog.com |
Категория: Полезные утилиты | Добавил: AdminGkb29 (01.04.2010)
|
Просмотров: 1013
| Рейтинг: 0.0/0 |
Добавлять комментарии могут только зарегистрированные пользователи. [ Регистрация | Вход ]
|