Архивирование RARом через CreateProcess - Полезные утилиты - Программирование в Access - Каталог статей - Отдел информационных технологий ГКБ №29
Пятница, 09.12.2016, 07:56
Приветствую Вас Гость | Регистрация | Вход

Отдел информационных технологий ГКБ №29 г.Новокузнецк

Меню сайта
Категории раздела
Полезные утилиты [5]
Поиск
Наш опрос
Как Вы оцениваете качество материалов?
Всего ответов: 28
Полезные ссылки
  • Официальный блог
  • Сообщество uCoz
  • Технологии программирования
  • Сайт о здоровье
  • Друзья сайта
  • КМИАЦ Новокузнецка
  • Интернет университет
  • Дистанционное обучение
  • Статистика
    Деловая сеть Кемерово и Кемеровская область. Жёлтые страницы, телефонный справочник и каталог компаний, товаров и услуг. Rambler's Top100
    Онлайн всего: 1
    Гостей: 1
    Пользователей: 0
    Погода
    Яндекс.Погода

    Каталог статей

    Главная » Статьи » Программирование в Access » Полезные утилиты

    Архивирование 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)
    Просмотров: 527 | Рейтинг: 0.0/0
    Всего комментариев: 0
    Добавлять комментарии могут только зарегистрированные пользователи.
    [ Регистрация | Вход ]