VB中如何用rar算法实现压缩文件?

[sunnykong]

如何在VB中调用RAR的压缩算法进行文件的压缩呢？
如果需要RAR的DLL文件去哪里下载？是用那一个方法进行压缩的？参数怎么样设置？
请高手指教~~~~~

[sunnykong]

有没有高手有源码呀？？？？？

[龙华]

-a 压缩
-r 包含路径
-x 解压缩
-sfx 生成exe文件。

[vbangle]

备份：

Option Explicit

Private index As Integer
Private bckupPath As String
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long

Private Sub bckupBegin_Click()
On Error GoTo hdError
Const Process_Query_Information = &H400
Const Still_Active = &H103
Dim pIdRAR, hProcess, lngExitCode As Long

Dim EnvString, tmpPathA, TmpPathB, fiName As String '' 声明变量。
Dim flNum, frI As Integer
If Dir(App.Path & "\RES\LoadWait.AVI") = "" Then
MsgBox "没有找到 LoadWait.AVI 文件 !"
Unload Me
End If

EnvString = Environ("TEMP") '' 取得环境变量。
If Right(EnvString, 1) <> "\" Then
EnvString = EnvString & "\"
End If

If Dir(EnvString & "_ZFBCKUP.D*") <> "" Then
Kill EnvString & "_ZFBCKUP.D*"
End If

tmpPathA = "RAR A -S -K -EP -V1435K " & EnvString & "_ZFBCKUP.D01 " & App.Path & "\" & Trim(Str(pCurryear)) & "\UDate.mdb"
pIdRAR = Shell(tmpPathA, vbHide)
hProcess = OpenProcess(Process_Query_Information, False, pIdRAR)
Me.Hide
frmDateLoading.Show
Do
GetExitCodeProcess hProcess, lngExitCode
DoEvents
Loop While lngExitCode = Still_Active

File1.Path = EnvString
File1.Pattern = "_ZFBCKUP.D??"
flNum = File1.ListCount
If flNum = 0 Then
MsgBox "对不起，备份出错，请检查!", vbExclamation, "错误"
Exit Sub
End If

For frI = 1 To flNum
frmDateLoading.Hide
If MsgBox("复制第" & Str(frI) & "张盘，共" & Str(flNum) & "张盘", vbOKOnly + vbInformation, "提示") = vbOK Then
frmDateLoading.Show
frmDateLoading.Refresh
TmpPathB = "_ZFBCKUP.D" & IIf(frI < 10, "0" & Trim(Str(frI)), Trim(Str(frI)))
If Dir(bckupPath & "NUL") <> "" Then
If frI = 1 Then
Open bckupPath & "_ZFBCKUP.LOG" For Output As #1
Print #1, flNum
Print #1, "备份年份：" & Trim(Str(pCurryear))
Print #1, "备份月份：" & Trim(Str(iMonther))
Print #1, "单位编号：" & pDwid
Print #1, "单位名称：" & pDwmc
Close #1
End If
FileCopy EnvString & TmpPathB, bckupPath & TmpPathB
End If
End If
Next frI
If Dir(EnvString & "_ZFBCKUP.D*") <> "" Then
Kill EnvString & "_ZFBCKUP.D*"
End If
Screen.MousePointer = vbDefault
Unload frmDateLoading
MsgBox "恭喜你，数据备份完毕！", vbInformation, "请确定"
Unload Me
Exit Sub
hdError:
Dim sTmp As String
If Err <> 0 Then
frmDateLoading.Hide
sTmp = "不期望的错误：" & vbCrLf & vbCrLf & Err.Description & vbCrLf & "错误号：" & Err
If MsgBox(sTmp, vbYesNo + vbQuestion + vbDefaultButton2, App.Title) = vbYes Then
Resume
Else
Unload frmDateLoading
If Dir(EnvString & "SendDate.*") <> "" Then
Kill EnvString & "SendDate.*"
End If
Exit Sub
End If
End If
End Sub

Private Sub dir1_change()
bckupPath = Dir1.Path
If Right(Dir1.Path, 1) <> "\" Then
bckupPath = Dir1.Path & "\"
End If
End Sub

Private Sub Drive1_Change()
On Error GoTo hdError
Dir1.Path = Left(Drive1.Drive, 2) & "\"
Exit Sub
hdError:
Dim sTmp As String
If Err <> 0 Then
sTmp = "不期望的错误：" & vbCrLf & vbCrLf & Err.Description & vbCrLf & "错误号：" & Err
MsgBox sTmp, vbInformation, App.Title
Resume
End If
End Sub

Private Sub Combo1_Click()
Dim erh As Integer, label As String, tmp As String
On Error GoTo errorh
ChDrive Left(Combo1.Text, InStr(Combo1.Text, ":")) ''改变当前驱动器
label = Dir("\*.*", 8) ''获取当前磁盘卷标
''显示格式处理
If Len(label) = 0 Then
tmp = Combo1.List(Combo1.ListIndex)
Combo1.List(Combo1.ListIndex) = Left(Left(tmp, 2) & " [None] ", 12) & "盘"
Else
tmp = Combo1.List(Combo1.ListIndex)
Combo1.List(Combo1.ListIndex) = Left(tmp, 3) & "[" & Left(label, 11) & "] " & " 盘"
End If
Dir1.Path = CurDir ''获取当前目录
Dir1.Refresh: File1.Refresh ''更新目录列表框和文件列表框
''此两句非常关键,不可缺省
''否则目录列表框不会变动
Exit Sub
''出错处理
errorh:
''显示惊叹号图标和 RETRY ,CANCLE按钮
erh = MsgBox(" " & Error(Err), 48 Or 5, "错误")
If erh = 2 Then ''按下CANCLE按钮
Combo1.ListIndex = index
Resume Next
Else
Resume
End If
Exit Sub
End Sub

Private Sub Combo1_DropDown()
index = Combo1.ListIndex '' 记录当前选项下标
End Sub

''将驱动器更表框中的内容加入到组合框中
Private Sub Form_Load()
Dim i As Integer, tmp As String
For i = 0 To Drive1.ListCount - 1
If Len(Drive1.List(i)) = 2 Then
tmp = Left(Drive1.List(i) & " [None] ", 12) & "盘"
End If
If InStr(Drive1.List(i), "]") Then
If InStr(Drive1.List(i), "]") > 11 Then
tmp = Left(Drive1.List(i), 11) & "...] " & "盘"
Else
tmp = Left(Drive1.List(i) & " ", 12) & "盘"
End If
End If
Combo1.AddItem tmp
Next
Combo1.ListIndex = Drive1.ListIndex ''设置当前驱动器
End Sub

[vbangle]

恢复：

Option Explicit

Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private numFileSum As Integer
Private numMonth As Integer
Private strPath As String

Private Sub Form_Load()
On Error GoTo UnitLoadError
Dim strName As String
Dim intCount As Integer
Dim sSql As String

Open reFileName For Input As #1
intCount = 1
Do While Not EOF(1) ' 循环至文件尾。
Line Input #1, strName
Select Case intCount
Case 1
numFileSum = strName
Label5.Caption = "磁盘张数：" & strName
Case 2
Label1.Caption = strName & "年"
Case 3
Label2.Caption = strName & "月"
Case 4
Label3.Caption = strName
Case 5
Label4.Caption = strName
End Select
intCount = intCount + 1
Loop
Close #1

UnitLoadError:
Dim sTmp As String
If Err <> 0 Then
sTmp = "不期望的错误：" & vbCrLf & vbCrLf & Err.Description & vbCrLf & "错误号：" & Err
MsgBox sTmp, vbInformation, App.Title
Exit Sub
End If
End Sub

Private Sub cmdCancel_Click()
Unload Me
End Sub

Private Sub cmdOK_Click()
On Error GoTo UnitRestoreError
Const Process_Query_Information = &H400
Const Still_Active = &H103
Dim pIdRAR, hProcess, lngExitCode As Long
Dim numMsgBox, numForPoint As Integer
Dim strFileDateS, strFileDateO, strEnvPath, strTmpFile As String
Me.Hide
strEnvPath = Environ("TEMP") ' 取得环境变量。
If Right(strEnvPath, 1) <> "\" Then
strEnvPath = strEnvPath & "\"
End If
strPath = Left(reFileName, InStrRev(reFileName, "\"))
For numForPoint = 1 To numFileSum
If MsgBox("恢复第" & Str(numForPoint) & "张盘，共" & Str(numFileSum) & "张盘", vbInformation + vbOKCancel, App.Title) = vbOK Then
strTmpFile = "_ZFBCKUP.D" & IIf(numForPoint < 10, "0" & Trim(Str(numForPoint)), Str(numForPoint)) '判断当小于10时，加入0，使得扩展名为3位
frmDateLoading.Show
FileCopy strPath & strTmpFile, strEnvPath & strTmpFile
Else
If Dir(strEnvPath & "_ZFBCKUP.D*") <> "" Then
Kill strEnvPath & "_ZFBCKUP.D*"
End If
Unload frmDateLoading
Unload Me
Exit Sub
End If
frmDateLoading.Hide
numForPoint = numForPoint + 1
Next numForPoint

frmDateLoading.Show

strTmpFile = "RAR E -Y -V " & strEnvPath & "_ZFBCKUP.D01 " & App.Path & "\" & Trim(Str(pCurryear))

pIdRAR = Shell(strTmpFile, vbHide)
hProcess = OpenProcess(Process_Query_Information, False, pIdRAR)
Do
GetExitCodeProcess hProcess, lngExitCode
DoEvents
Loop While lngExitCode = Still_Active

If Dir(strEnvPath & "_ZFBCKUP.D*") <> "" Then
Kill strEnvPath & "_ZFBCKUP.D*"
End If

Screen.MousePointer = vbDefault
Unload frmDateLoading
MsgBox "恭喜你，数据恢复完毕！", vbInformation, "请确定"
Unload Me

frmInfo.Show vbModal, Me

UnitRestoreError:
Dim sTmp As String
If Err <> 0 Then
frmDateLoading.Hide
sTmp = "不期望的错误：" & vbCrLf & vbCrLf & Err.Description & vbCrLf & "错误号：" & Err
If MsgBox(sTmp, vbYesNo + vbQuestion + vbDefaultButton2, App.Title) = vbYes Then
Resume
Else
Unload frmDateLoading
If Dir(strEnvPath & "SendDate.*") <> "" Then
Kill strEnvPath & "SendDate.*"
End If
Unload Me
End If
End If
End Sub

[liangqiang]

up

[dsclub]

http://expert.csdn.net/Expert/topic/779/779685.xml?temp=.1961023