今天的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
★VB部分相关文章推荐：★
※vb中line的用法[转]
※画图工具的VB实现
※VB 一个获得自己外网 IP 地址的程序代码
※VB程序中实现IP地址子网掩码网关DNS的更改 [转]
※在 VB 中应用 FSO 对象模型介绍（摘自网络）
※[转] Vb中FSO 对象的介绍
※VB 画坐标轴
※VB 二进制文件的操作
※[VB]BMP转JPGVB中KeyCode常数用法
※vb实时曲线的绘制和保存
※VB操作EXCEL
※vb初学回顾：最大公约数 最小公倍数 素数求取
※vb 关于窗口样式的API以及处理文本的API参考
※【引用】在VB6.0中实现弹出式菜单的几种方法
※【引用】URLDownloadToFile_VB下载文件!
※利用WinRar压缩和解压缩文件
※VB 剪切板
※VB实现指示窗口中拖动方框的程序
※VB绘制走动的表针
※如何用VB制作DLL文件
※【引用】VB修改IP地址
※VB多窗体退出代码
※[转]VB:如何检测到U盘的插拔(源代码)
※巧用SendMessage函数扩展Treeview功能
※vb中如何在任务管理器里面隐藏应用程序进程
※如何实现VB与EXCEL的无缝连接
※一个API方式存取日志文件的模块[VB]
※VB用记录集填充表格函数
※VB打开文本文件各种方法
※vb ClipBoard 剪切板应用（复制剪切粘贴）
※【引用】窗口处理技巧大全 vb(窗体控件)
※【转】 Md rd命令之VB
※vb：读写文本文件
※在vb中实现真正锁定的带自定义菜单的文本控件
※【引用】使用CommonDialog的ShowSave后如何判断是保存还是※取消？
※vb 关于commondialog的多选VB获取Windows操作系统所有版本
※vb UTF文本文件访问
※VB编程中的Unicode vs Ansi
※VB编PiView4注册机
※VB获取超过2G文件的大小
※比CopyMemory还要快的函数SuperCopyMemory
※VB:编程效率快步提高之:十七种可用一行代码完成的技巧
※VB画出来的五星红旗
※Qt第一印象——Qte与Qt
更多精彩>>>