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

Question

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

Answer 1

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

Answer 2

备份：Option ExplicitPrivate 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 LongPrivate 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 SubPrivate Sub dir1_change()
    bckupPath = Dir1.Path
    If Right(Dir1.Path, 1) <> "\" Then
        bckupPath = Dir1.Path & "\"
    End If
End SubPrivate 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 SubPrivate 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 SubPrivate 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

Answer 3

恢复：Option ExplicitPrivate 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 StringPrivate 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 #1UnitLoadError:
  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 SubPrivate Sub cmdCancel_Click()
  Unload Me
End SubPrivate 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