| Вопрос: рар архивация | Добавлено: 17.04.07 15:39 |
Автор вопроса:  Champion | Web-сайт: afhelp.in.ua | ICQ: 461506481 |
|
слышал что есть, где-то в сети, но не могу почему-то найти
именно реализацию данного алгоритма на VB может, если кто знает, где такое счастие есть? или альтернативу нужно сжать средствами VB текстовый файл (1-2МБ) до 200-400КБ rar.exe не предлагать), в данный момент он и юзается) но на разных машинах данный код ведёт себя с ошибками, а имеено, не успевают срабатывать проверки на выполнение операций Dim Filename$, txtF, FileBytes() As Byte Filename = Mid(fso.GetFileName(FilePathTarget), 1, Len(fso.GetFileName(FilePathTarget)) - 4) & ".rar" SetCurrentDirectory direct fso.MoveFile FilePathTarget, Filename Call sapiSleep(3000): Do While fso.fileexists(Filename) = False: DoEvents: Loop: txtF = Shell("rar.exe e -p" & pass & " " & Filename & " " & fso.GetFileName(FilePathTarget), 0) Call sapiSleep(3000): Do While fso.fileexists(FilePathTarget) = False: DoEvents: Loop: ReDim FileBytes(FileLen(FilePathTarget) - 1) As Byte Open FilePathTarget For Binary Access Read As #1: Get #1, , FileBytes: Close #1: FileDeCompress = BYTES_TO_STRING(FileBytes): Kill FilePathTarget: fso.MoveFile Filename, FilePathTarget fso - файл систем обджект |
| Ответы | Всего ответов: 11 |
|
Номер ответа: 1 Автор ответа:  Arseny ICQ: 298826769 Вопросов: 53 Ответов: 1732 |
Профиль | | #1 | Добавлено: 17.04.07 15:57 |
| по ZIP'у дофигища всего везде | ||
|
Номер ответа: 2 Автор ответа: Champion ICQ: 461506481 Вопросов: 38 Ответов: 88 |
Web-сайт: Профиль | | #2 | Добавлено: 17.04.07 18:34 |
|
зип уступает при сжатии данного файла на 5-10%
мне размер именно критично |
||
|
Номер ответа: 3 Автор ответа: ArsenyICQ: 298826769 Вопросов: 53 Ответов: 1732 |
Профиль | | #3 | Добавлено: 17.04.07 19:56 |
| Так там по-моему степень сжатия можно юзать... | ||
|
Номер ответа: 4 Автор ответа: SharpЛидер форума ICQ: 216865379 Вопросов: 106 Ответов: 9979 |
Web-сайт: Профиль | | #4 | Добавлено: 17.04.07 21:59 |
| поищи в Инете алгоритмы 7z, lzma, bzip2, они открытые и жмут примерно наравне с rar | ||
|
Номер ответа: 5 Автор ответа: HACKERРазработчик Offline Client Вопросов: 236 Ответов: 8362 |
Профиль | | #5 | Добавлено: 18.04.07 02:37 |
|
аффтару знакомы эти слова?
- Dinamic Link Library - WaitForSingleObject Как насчёт того чтобы заюзать dll винраровскую? Как насчёт того чтобы запустить rar.exe и дождаться его завершения? |
||
|
Номер ответа: 6 Автор ответа: SharpЛидер форума ICQ: 216865379 Вопросов: 106 Ответов: 9979 |
Web-сайт: Профиль | | #6 | Добавлено: 18.04.07 02:48 |
| Использовать чужую закрытую библиотеку - не труъ | ||
|
Номер ответа: 7 Автор ответа: HACKERРазработчик Offline Client Вопросов: 236 Ответов: 8362 |
Профиль | | #7 | Добавлено: 18.04.07 03:23 |
| Ну да кому как... Если не критично к скорости, можно и алгоритмом на вб сжать... | ||
|
Номер ответа: 8 Автор ответа: ChampionICQ: 461506481 Вопросов: 38 Ответов: 88 |
Web-сайт: Профиль | | #8 | Добавлено: 18.04.07 05:48 |
|
Sharp
не совсем понял конечно последнее слово, но если по смыслу, то) ... програмки на ВБ, никогда не считал коммерческим занятием) HACKER аффтору слова знакомы, но никогда не юзал подобные обороты и не откажусь от примера) не суди строго, но программирование на ВБ, я считаю всего лишь продвинутым юзерством или около того, хотя и слышал, что на нём писались продукты для рынка не помню какой биржи), поэтому вникать в тонкости .. не всегда хватало времени, а обходился топоровыми вариантами, по типу кода, что привёл выше п.с. за последние лет 8 самодельства, у меня возникало только две проблемы, которые не разрешались силами поиска) ... это id3-tag v2 и быстрый алгоритм сжатия(заодно и и шифрования) иногда спасает хафман и RC4, но не панацея |
||
|
Номер ответа: 9 Автор ответа: HACKERРазработчик Offline Client Вопросов: 236 Ответов: 8362 |
Профиль | | #9 | Добавлено: 18.04.07 06:27 |
|
п.с. за последние лет 8 самодельства, у меня возникало только две проблемы, которые не разрешались силами поиска) Отлично, значит эта тоже решится поиском, темболее ключевые слова я дал...
Ладно, ок... Attribute VB_Name = "ArhiveFile"
'===========================================================| ' <МОДУЛЬ ДЛЯ C RARom, КОТОРЫЙ УСТАНОВЛЕН В СИСТЕМЕ. >| ' | ' = = = = = = = M A D E B Y H A C K E R = = = = = = | ' icq: 334479038, mail: visualbasic@xaker.ru | '===========================================================| 'Нужны функции работы с реестром (модуль reg.bas) 'Поддерживает только WinRar, степень сжатия - максимальная 'Возможность установить на архив пароль Public Sub ArhiveToWinRar(file$, Password$, RarFile$) 'Находим в компе архиватор Arhive$ = RegGetValue(HKEY_CLASSES_ROOT, ".rar\ShellNew", "FileName" 
If Arhive$ <> "" Then ' Если есть на компе архиватор... Arhive$ = Left(Arhive$, Len(Arhive$) - Len(Spliting(Arhive$, "\" )) 'берём его путь
'Смотрим какой архиватор... If InStr(1, LCase(Arhive$), "winrar", vbTextCompare) > 0 Then 'Если WinRar 'Формируем коммандную строку для архивации If RarFile$ = "" Then RarFile$ = Replace(file$, Spliting(file$, "." , "rar"
Arhive$ = Chr(34) & Arhive$ & "Rar.exe" & Chr(34) & " a -m5 -inul -ep -ep1 -idp -p" & Password$ & " " & Chr(34) & RarFile$ & Chr(34) & " " & Chr(34) & file$ & Chr(34) End If End If Shell Arhive$, vbHide End Sub Public Sub ExtractWinRar(RarFile$, Password$, sDir$) 'Находим в компе архиватор Arhive$ = RegGetValue(HKEY_CLASSES_ROOT, ".rar\ShellNew", "FileName"
If Arhive$ <> "" Then ' Если есть на компе архиватор... Arhive$ = Left(Arhive$, Len(Arhive$) - Len(Spliting(Arhive$, "\" )) 'берём его путь
'Смотрим какой архиватор... If InStr(1, LCase(Arhive$), "winrar", vbTextCompare) > 0 Then 'Если WinRar 'Формируем коммандную строку для архивации If RarFile$ = "" Then RarFile$ = Replace(file$, Spliting(file$, "." , "rar"
If Password$ = "" Then Arhive$ = Chr(34) & Arhive$ & "unrar.exe" & Chr(34) & " e -idb -o+ -y" & " " & Chr(34) & RarFile$ & Chr(34) & " " & Chr(34) & sDir$ & Chr(34) Else Arhive$ = Chr(34) & Arhive$ & "unrar.exe" & Chr(34) & " e -idb -o+ -y -p" & Password & " " & Chr(34) & RarFile$ & Chr(34) & " " & Chr(34) & sDir$ & Chr(34) End If End If End If Shell Arhive$, vbHide End Sub Option Explicit
Const INFINITE = &HFFFF Const STARTF_USESHOWWINDOW = &H1 Private Enum enSW SW_HIDE = 0 SW_NORMAL = 1 SW_MAXIMIZE = 3 SW_MINIMIZE = 6 End Enum Private Type PROCESS_INFORMATION hProcess As Long hThread As Long dwProcessId As Long dwThreadId As Long End Type Private 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 Byte hStdInput As Long hStdOutput As Long hStdError As Long End Type Private Type SECURITY_ATTRIBUTES nLength As Long lpSecurityDescriptor As Long bInheritHandle As Long End Type Private Enum enPriority_Class NORMAL_PRIORITY_CLASS = &H20 IDLE_PRIORITY_CLASS = &H40 HIGH_PRIORITY_CLASS = &H80 End Enum Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As String, ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long Private Function SuperShell(ByVal App As String, ByVal WorkDir As String, dwMilliseconds As Long, ByVal start_size As enSW, ByVal Priority_Class As enPriority_Class) As Boolean Dim pclass As Long Dim sinfo As STARTUPINFO Dim pinfo As PROCESS_INFORMATION sinfo.cb = Len(sinfo) 'Set the flags 'sinfo.dwFlags = STARTF_USESHOWWINDOW 'Set the window's startup position 'sinfo.wShowWindow = vbNormal 'Set the priority class 'pclass = Priority_Class 'Start the program If CreateProcess(vbNullString, App, 0, 0, 0, 0, vbNullString, WorkDir, sinfo, pinfo) Then 'Wait WaitForSingleObject pinfo.hProcess, dwMilliseconds SuperShell = True Else SuperShell = False End If End Function Private Sub Form_Load() 'Execute the program SuperShell "notepad.exe", vbNullString, 0, SW_NORMAL, HIGH_PRIORITY_CLASS End Sub |
||
|
Номер ответа: 10 Автор ответа: ChampionICQ: 461506481 Вопросов: 38 Ответов: 88 |
Web-сайт: Профиль | | #10 | Добавлено: 18.04.07 18:25 |
|
HACKER
даже не думал использовать ВинРар) спасиба за хороший пример |
||
|
Номер ответа: 11 Автор ответа: HACKERРазработчик Offline Client Вопросов: 236 Ответов: 8362 |
Профиль | | #11 | Добавлено: 20.04.07 19:21 |
|
Лови ещё пример с unrar.dll
'***************************************************************
'Windows API/Global Declarations for :UnRAR (RAR Extract) '*************************************************************** ' Title: UnRAR VB6 BAS Module ' Requires: UnRAR.DLL (supplied) ' Open Mode Constants Public Declare Function RAROpen Lib "UnRAR.dll" Alias "RAROpenArchive" (ByRef RAROpenData As RAROpenArchiveData) As Long Public Declare Function RARClose Lib "UnRAR.dll" Alias "RARCloseArchive" (ByVal HandleToArchive As Long) As Long Public Declare Function RARReadHdr Lib "UnRAR.dll" Alias "RARReadHeader" (ByVal HandleToArcRecord As Long, ByRef rcHeaderRead As RARHeaderData) As Long Public Declare Function RARProcFile Lib "UnRAR.dll" Alias "RARProcessFile" (ByVal HandleToArcHeader As Long, ByVal Operation As Long, ByVal DestPath As String, ByVal DestName As String) As Long Public Declare Sub RARSetChangeVolProc Lib "UnRAR.dll" (ByVal HandleToArchive As Long, ByVal Mode As Long) Public Declare Sub RARSetPassword Lib "UnRAR.dll" (ByVal HandleToArchive As Long, ByVal Password As String) Private Const RAR_OM_LIST As Byte = 0 Private Const RAR_OM_EXTRACT As Byte = 1 ' Error Constants Private Const ERAR_NO_MEMORY As Byte = 11 Private Const ERAR_BAD_DATA As Byte = 12 Private Const ERAR_BAD_ARCHIVE As Byte = 13 Private Const ERAR_EOPEN As Byte = 15 Private Const ERAR_UNKNOWN_FORMAT As Byte = 14 Private Const ERAR_SMALL_BUF As Byte = 20 Private Const ERAR_ECLOSE As Byte = 17 Private Const ERAR_END_ARCHIVE As Byte = 10 Private Const ERAR_ECREATE As Byte = 16 Private Const ERAR_EREAD As Byte = 18 Private Const ERAR_EWRITE As Byte = 19 ' Operation Constants Private Const RAR_SKIP As Byte = 0 Private Const RAR_TEST As Byte = 1 Private Const RAR_EXTRACT As Byte = 2 ' Volume Constants Private Const RAR_VOL_ASK As Byte = 0 Private Const RAR_VOL_NOTIFY As Byte = 1 ' User Defined Types Private Type RARHeaderData ArcName As String * 260 FileName As String * 260 Flags As Long PackSize As Long UnpSize As Long HostOS As Long FileCRC As Long FileTime As Long UnpVer As Long Method As Long FileAttr As Long CmtBuf As String ' Pointer (char *CmtBuf in C) CmtBufSize As Long CmtSize As Long CmtState As Long End Type Private Type RAROpenArchiveData ArcName As String ' Pointer (char *ArcName in C) OpenMode As Long OpenResult As Long CmtBuf As String ' Pointer (char *CmtBuf in C) CmtBufSize As Long CmtSize As Long CmtState As Long End Type ' RAR DLL Declares ' Source Code: '*************************************************************** ' Name: UnRAR (RAR Extract) ' Description:This BAS module enables you to extract files from compressed 'RAR archives. ' It also handles password protected RAR archives via an optional parameter. ' ' Inputs:None ' Returns:None 'Assumes:None 'Side Effects:None '*************************************************************** Function RARExtract(ByVal sRARArchive As String, ByVal sDestPath As String, Optional ByVal sPassword As String) As Integer ' Description:- ' Exrtact file(s) from RAR archive. ' Parameters:- ' sRARArchive = RAR Archive filename ' sDestPath = Destination path for extracted file(s) ' sPassword = Password [OPTIONAL] ' Returns:- ' Integer = 0 Failed (no files, incorrect PW etc) '-1 Failed to open RAR archive '>0 Number of files extracted Dim lHandle As Long Dim iStatus As Integer Dim uRAR As RAROpenArchiveData Dim uHeader As RARHeaderData Dim iFileCount As Integer RARExtract = -1 ' Open the RAR uRAR.ArcName = sRARArchive uRAR.OpenMode = RAR_OM_EXTRACT lHandle = RAROpen(uRAR) ' Failed to open RAR ? If uRAR.OpenResult <> 0 Then Exit Function ' Password ? If sPassword <> "" Then RARSetPassword lHandle, sPassword End If ' Extract file(s)... iFileCount = 0 ' Is there at lease one archived file to extract ? iStatus = RARReadHdr(lHandle, uHeader) Do Until iStatus <> 0 ' Process (extract) the current file within the archive If RARProcFile(lHandle, RAR_EXTRACT, "", sDestPath + uHeader.FileName) = 0 Then iFileCount = iFileCount + 1 End If ' Is there another archived file in this RAR ? iStatus = RARReadHdr(lHandle, uHeader) Loop ' Close the RAR RARClose lHandle ' Return RARExtract = iFileCount End Function |
||
Страница: 1 |