Option Explicit '********************************** 短路径名 Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long Dim jj&, wsource$, wtarget$, aa$, tmpstr$, starttm&, objWMIService, colProcesslist Private Sub Command1_Click() '压缩 wsource = "e:\music\*.wma" wtarget = "c:\test.rar" aa = "rar a -ep " & wtarget & " " & wsource Call Shell(aa, vbHide) starttm = Timer Do DoEvents If Isrunexe("rar.exe") = False Then Exit Do Loop Until Timer > starttm + 60 MsgBox "压缩完成!" End Sub
Private Sub Command2_Click() '解压缩 wsource = "c:\test.rar" wtarget = Environ("userprofile") & "\桌面" wtarget = Getshortname(wtarget) aa = "rar x " & wsource & " " & wtarget ' Shell 指令 Call Shell(aa, vbHide) starttm = Timer Do DoEvents If Isrunexe("rar.exe") = False Then Exit Do Loop Until Timer > starttm + 60 MsgBox "解压缩完成!" End Sub
Public Function Isrunexe(ExeNm As String) As Boolean tmpstr = "." Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & tmpstr & "\root\cimv2") Set colProcesslist = objWMIService.ExecQuery("Select * from Win32_Process Where Name = '" & ExeNm & "'") Isrunexe = IIf(colProcesslist.Count > 0, True, False) Set objWMIService = Nothing Set colProcesslist = Nothing End Function
Public Function Getshortname(ByVal sLongFileName As String) As String Dim lRetVal&, sShortPathName$, iLen% sShortPathName = Space(255) iLen = Len(sShortPathName) lRetVal = GetShortPathName(sLongFileName, sShortPathName, iLen) Getshortname = Left(sShortPathName, lRetVal) jj = InStr(Getshortname, Chr(0)) If jj > 0 Then Getshortname = Mid(Getshortname, 1, jj - 1) End Function
