利用WinRar压缩和解压缩文件

最新推荐文章于 2019-01-04 11:59:08 发布

miaozk2006

最新推荐文章于 2019-01-04 11:59:08 发布

阅读量392

点赞数 1

本文链接：https://blog.csdn.net/miaozk2006/article/details/82416839

版权

今天的rar shell只是一个简单应用，rar.exe和winrar.exe语法都是一样的。
对rar而言，用rar.exe最好，不需要判断winrar在哪里,而且非常小，因为没有界面，所有压缩选项可以定制，而Winrar受默认压缩选项限制。
rar的语法在cmd里面rar |more看个明白，或看rar.txt
Option Explicit
Private Const c_CmdSelectPack = 0
Private Const c_CmdSelectUnpack = 1
Private m_strLongFileName As String      '保存原长文件名，压缩后还原
Private Sub Form_Activate()
    SSTab1.Tab = 0
End Sub
Private Sub cmdUnpack_Click()             '解压缩文件
    '关于WinRar的用法
    '主要介绍以下如何在WinRar中用命令行来压缩和解压缩文件?
    '压缩：WINRAR A [-switches] <Archive> [Files] [@File lists]
    '例如你想把try.mdb压缩到C盘下，可以WINRAR A C:\try.rar C:\try.mdb
    '解压缩:     如果带目录解压缩
    '　　　　　　WINRAR X [-switches] <Archive> [Files] [@File lists] [destionation folder\]
    '　　　　　如果在当前目录解压缩，即解压缩时不写目录名
    '　　　　　　WINRAR E [-switches] <Archive> [Files] [@File lists] [destionation folder\]
    '　        　例如你想把try.rar解压缩到C盘下，可以WINRAR X C:\try.rar C:\try.mdb
    Dim Rarexe As String '注释：WINRAR执行文件的位置
    Dim Source As String '注释：解压缩前的原始文件
    Dim Target As String '注释：解压缩后的目标文件
    Dim FileString As String '注释：Shell指令中的字符串
    Dim Result As Long
    Dim strShortNamePath As String
    If Len(txtSource(c_CmdSelectUnpack).Text) = 0 or Len(txtDescription(c_CmdSelectUnpack).Text) = 0 Then Exit Sub
    strShortNamePath = GetShortName(App.Path)
    Rarexe = strShortNamePath & "\rar"
    Source = txtSource(c_CmdSelectUnpack)
    Target = txtDescription(c_CmdSelectUnpack)
    FileString = Rarexe & " X " & " -o+" & Space$(1) & Source & " " & Target
    lblState.Caption = "正在解压缩文件中......"
    Me.MousePointer = vbHourglass
    Result = Shell(FileString, vbHide)
    Call WaitShellProgram(Result)          '等待Rar工作完成
    Me.MousePointer = vbDefault
    lblState.Caption = vbNullString
    MsgBox "解压缩成功完成!", vbInformation, "提示信息"
End Sub
Private Sub cmdPack_Click()                    '压缩文件
    '关于WinRar的用法
    '主要介绍以下如何在WinRar中用命令行来压缩和解压缩文件?
    '压缩：WINRAR A [-switches] <Archive> [Files] [@File lists]
    '例如你想把try.mdb压缩到C盘下，可以WINRAR A C:\try.rar C:\try.mdb
    '解压缩:     如果带目录解压缩
    '　　　　　　WINRAR X [-switches] <Archive> [Files] [@File lists] [destionation folder\]
    '　　　　　如果在当前目录解压缩，即解压缩时不写目录名
    '　　　　　　WINRAR E [-switches] <Archive> [Files] [@File lists] [destionation folder\]
    '　        　例如你想把try.rar解压缩到C盘下，可以WINRAR X C:\try.rar C:\try.mdb
    Dim Rarexe As String '注释：WINRAR执行文件的位置
    Dim Source As String '注释：压缩前的原始文件
    Dim Target As String '注释：压缩后的目标文件
    Dim FileString As String '注释：Shell指令中的字符串
    Dim Result As Long
    Dim strShortNamePath
    Dim strTemp As String
    Dim lngPos As Long
    Dim strOldFileName As String
    Dim strNewFileName As String
    If Len(txtSource(c_CmdSelectPack).Text) = 0 or Len(txtDescription(c_CmdSelectPack).Text) = 0 Then Exit Sub
    strShortNamePath = GetShortName(App.Path)
    Rarexe = strShortNamePath & "\rar.exe -m5" '最大参数压缩
    Source = txtSource(c_CmdSelectPack)
    Target = txtDescription(c_CmdSelectPack).Text
    FileString = Rarexe & " a " & "-ep1 " & Target & " " & Source
    lblState.Caption = "正在压缩文件中......"
    Me.MousePointer = vbHourglass
    Result = Shell(FileString, vbHide)
    Call WaitShellProgram(Result)               '等待Rar工作完成
    Me.MousePointer = vbDefault
    lblState.Caption = vbNullString
    MsgBox "文件压缩成功完成!", vbInformation, "提示信息"
    lngPos = InStrRev(m_strLongFileName, "\")
    If lngPos > 0 Then
        strTemp = Right$(m_strLongFileName, Len(m_strLongFileName) - lngPos) & ".rar"
        If Dir(txtDescription(c_CmdSelectPack).Text) <> vbNullString Then
            strOldFileName = txtDescription(c_CmdSelectPack).Text
            lngPos = InStrRev(txtDescription(c_CmdSelectPack).Text, Dir(txtDescription(c_CmdSelectPack).Text))
            strNewFileName = Left$(txtDescription(c_CmdSelectPack).Text, lngPos - 1) & strTemp
            If Dir(strNewFileName) = vbNullString Then    '多次重复压缩
                Name strOldFileName As strNewFileName
            End If
        End If
    End If
End Sub
Private Sub cmdExit_Click(Index As Integer)
    End
End Sub
Private Sub cmdSource_Click(Index As Integer)
    Dim strFilePath As String
    Select Case Index
        Case c_CmdSelectPack                         '选择原文件路径
        If optDir.Value = True Then
            strFilePath = GetFolderPath(Me.hWnd)
            If Len(strFilePath) = 3 Then
                MsgBox "不能选择系统根目录！", vbCritical, "错误"
                Exit Sub
            End If
            m_strLongFileName = strFilePath            '备份长路径
            txtSource(c_CmdSelectPack).Text = GetShortName(strFilePath)
        ElseIf optFile.Value = True Then
            dlgSelectFile.Filter = "所有支持的文件类型|*.*"
            dlgSelectFile.ShowOpen
            m_strLongFileName = strFilePath            '备份长路径
            txtSource(c_CmdSelectPack).Text = GetShortName(dlgSelectFile.FileName)
        End If
        Case c_CmdSelectUnpack                      '选择压缩文件路径
        dlgSelectFile.Filter = "Rar类型文件|*.rar"
        dlgSelectFile.ShowOpen
        txtSource(c_CmdSelectUnpack).Text = GetShortName(dlgSelectFile.FileName)
    End Select
End Sub
Private Sub cmdDescription_Click(Index As Integer)
    Dim strFilePath As String, strTxtSelPack As String, lngPos As Long
    Select Case Index
        Case c_CmdSelectPack          '选择压缩文件路径
        If Len(txtSource(c_CmdSelectPack)) = 0 Then Exit Sub
        strFilePath = GetFolderPath(Me.hWnd)
        txtDescription(c_CmdSelectPack).Text = GetShortName(strFilePath)
        strTxtSelPack = txtSource(c_CmdSelectPack).Text
        lngPos = InStrRev(strTxtSelPack, "\")
        If Len(txtDescription(c_CmdSelectPack).Text) > 3 Then '根据目录添加"\"
            txtDescription(c_CmdSelectPack).Text = txtDescription(c_CmdSelectPack).Text & "\" _
                           & Right$(strTxtSelPack, Len(strTxtSelPack) - lngPos) & ".rar"
        Else
            txtDescription(c_CmdSelectPack).Text = txtDescription(c_CmdSelectPack).Text _
                           & Right$(strTxtSelPack, Len(strTxtSelPack) - lngPos) & ".rar"
        End If
        Case c_CmdSelectUnpack        '选择解压缩后文件路径
        strFilePath = GetFolderPath(Me.hWnd)
        txtDescription(c_CmdSelectUnpack).Text = GetShortName(strFilePath)
    End Select
End Sub

程序代码
Option Explicit
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
'注意结构声明的不同
Private Type BROWSEINFO
    hWndOwner As Long        '主句柄
    pidlRoot As Long         '展开根目录
    pszDisplayName As Long
    lpszTitle As Long        '列表框标题,这里是用的long,所以得用lstrcat获取字符指针了
    ulFlags As Long          '规定只能选择文件夹，其他无效
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type
Private Const BIF_RETURNONLYFSDIRS = 1 '只能选择文件夹
Private Const MAX_PATH = 260            '路径最大值
Public Function GetFolderPath(frmHwnd As Long) As String
    Dim iNull As Integer, lpIDList As Long
    Dim sPath As String, udtBI As BROWSEINFO
    With udtBI
        .hWndOwner = frmHwnd                            '设置主窗体句柄
        .lpszTitle = lstrcat("请选择", "程序路径")      'lstcat连接两个字符串然后返回内存地址，同&作用类似。
        .ulFlags = BIF_RETURNONLYFSDIRS                 '规定只能选择文件夹，其他无效
    End With
    '显示列表框
    lpIDList = SHBrowseForFolder(udtBI)
    If lpIDList Then
        sPath = String$(MAX_PATH, 0)
        '获取返回的路径
        SHGetPathFromIDList lpIDList, sPath
        '释放内存块
        CoTaskMemFree lpIDList
        iNull = InStr(sPath, vbNullChar)               '去除空格符
        If iNull Then sPath = Left$(sPath, iNull - 1)
    End If
    GetFolderPath = sPath
End Function
程序代码
Option Explicit
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" _
                          (ByVal lpszLongPath As String, _
                          ByVal lpszShortPath As String, _
                          ByVal cchBuffer As Long) _
                          As Long
Private Const MAX_PATH = 260
Public Function GetShortName(LongPath As String) As String
    Dim ret&
    Dim ShortPath As String
    Dim Retplase As Long
    ShortPath = Space$(MAX_PATH)
    ret& = GetShortPathName(LongPath, ShortPath, MAX_PATH)
    Retplase = InStr(ShortPath, Chr$(0)) '分离空格符
    If ret& > 0 or Retplase > 0 Then
        GetShortName = Left$(ShortPath, Retplase - 1)
    End If
End Function
程序代码
Option Explicit
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Const GWL_STYLE = (-16)            '窗口样式
'窗口风格
Private Const WS_MAXIMIZEBOX = &H10000     '带最大化按钮的窗口
Private Const WS_MINIMIZEBOX = &H20000     '带最小化按钮的窗口
Private Const WS_SYSMENU = &H80000         '带系统菜单的窗口
Private Const WS_OVERLAPPED = &H0&         '具有标题栏和边框的层叠窗口
Private Const WS_THICKFRAME = &H40000      '具有可调边框
Private Const WS_GROUP = &H20000           '指定一组控制的第一个控制
'WaitForSingleObject函数用来检测hHandle事件的信号状态，当函数的执行时间超过dwMilliseconds就返回。
'但如果参数dwMilliseconds为INFINITE时函数将直到相应时间事件变成有信号状态才返回，否则就一直等待下去，直到WaitForSingleObject有返回直才执行后面的代码。
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
'dwDesiredAccess访问模式
'bInheritHandle 继承标志，是否可以被一个新的进程继承使用，如果为TRUE，就可以被一个新进程继承句柄。
'dwProcessId 进程标识符
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Const INFINITE = -1&              '等待值为无穷大
Private Const SYNCHRONIZE = &H100000      '使等待一个进程结程结束的函数能获取有效的句柄
Private Const WAIT_TIMEOUT = &H102&       '等候超时
Public Function WaitShellProgram(id As Long)
    Dim ret&, pHandle&
    pHandle = OpenProcess(SYNCHRONIZE, False, id) '获得进程的句柄
    Do
        ret = WaitForSingleObject(pHandle, 0)
        DoEvents
    Loop While ret = WAIT_TIMEOUT
    CloseHandle pHandle
End Function