form1.frm

这是一个使用VB操作RAR文件的示例

Private Sub btnProcess_Click()
If CorruptFile = True Then
    MsgBox "文件损坏！", vbCritical + vbOKOnly, "提示"
    Exit Sub
End If

'/////////检查输入路径

If txtOpenRar.Text <> "" Then
    If Mid(Me.txtOpenRar.Text, Len(Me.txtOpenRar.Text) - 3, 4) = ".rar" Then 'if the ext on fullpathtorar is .rar
        If PasswordStatus = True Then 'there is a password associated with file
            If txtPassword.Text = "" Then ' checks to see if user has entered a password
                MsgBox "首先请提供密码! ", vbExclamation, "密码保护"
                Exit Sub
            Else 'there is text in password field
               'do nothing
            End If 'end text in password field check
        End If 'end checking for password
    Else ' file ext is not rar
        MsgBox "文件选择错误，请检查!" & vbCrLf & vbCrLf & vbExclamation + vbOKOnly, "错误"
        Exit Sub
    End If ' end detection of correct filetype
Else
    MsgBox "没有选择压缩文件!", vbExclamation, "文件错误" 'there can't have been a file selected or a correct file selected
    Exit Sub
End If


'///////////check output path
If Me.txtOutputPath.Text = "" Then MsgBox "请选择解压缩路径!", vbExclamation + vbOKOnly, "错误": Exit Sub

'show progress form
Me.Hide
frmProgress.Show
        


End Sub

Private Sub cmdChangeDir_Click()
Me.txtOutputPath.Text = BrowseFolder("请选择解压缩文件夹", Me)
End Sub

Private Sub btnReload_Click()
Call ListFiles_Click
End Sub

Private Sub btnShowComment_Click()
MsgBox ArchiveComment, vbOKOnly, "文件注释"
End Sub

'Private Sub cmdListFiles_Click()

Private Sub Form_Load()
Dim TheCommand As String
Set Colx = Me.ListView.ColumnHeaders.Add(, , "名称")
Set Colx = Me.ListView.ColumnHeaders.Add(, , "大小")
Set Colx = Me.ListView.ColumnHeaders.Add(, , "压缩前大小")
Set Colx = Me.ListView.ColumnHeaders.Add(, , "修改日期")
Set Colx = Me.ListView.ColumnHeaders.Add(, , "CRC32")
Set Colx = Me.ListView.ColumnHeaders.Add(, , "路径")


    'set pictures for the rar comment button
    Me.btnShowComment.Picture = LoadResPicture(109, vbResIcon)
    'Me.btnShowComment.DownPicture = LoadResPicture(109, vbResIcon)
    Me.btnShowComment.DisabledPicture = LoadResPicture(110, vbResIcon)
    
    'set the reload icons
    Me.btnReload.Picture = LoadResPicture(111, vbResIcon)
    Me.btnReload.DisabledPicture = LoadResPicture(112, vbResIcon)
    
    
    

    Me.txtPassword.Visible = False 'disable password field unless user wants a password to enter
    Me.lblpassword.Visible = False
    Me.btnPasswordHelp.Visible = False
    Me.btnShowComment.Enabled = False
    Me.btnReload.Enabled = False
    'txtPassword.BackColor = RGB(230, 230, 230) ' sets password field to grey

'load images from the resource file into the picure boxes, and then into the imagelist
    For i = 0 To 2
        Me.pictoolbar(i).Picture = LoadResPicture(106 + i, vbResIcon)
        Me.imglstToolbar.ListImages.Add , , Me.pictoolbar(i).Picture
    Next
    
'assign the image list to the toolbar
    Me.Toolbar.ImageList = Me.imglstToolbar
'populate the toolbar with buttons
    With Me.Toolbar.Buttons
        .Add 1, , "1) 选择Rar压缩文件", , 1
        .Item(1).ToolTipText = "选择一个RAR格式的压缩文件"
        .Add 2, , "2) 选择解压缩路径", , 2
        .Item(2).ToolTipText = "选择解压缩的目的路径"
        .Add 3, , "3) 解压缩文件", , 3
        .Item(3).ToolTipText = "开始解压缩文件"
    End With

'sort the treeview out. same as above code really
For i = 0 To 3
    Me.Image1(i).Picture = LoadResPicture(101 + i, vbResIcon)
    Me.ImageList.ListImages.Add , , Me.Image1(i).Picture
Next

'the followin code allows a RAR archive to be opened without Rar support directly
If Command$ <> "" Then

    'check to see if its a rar archive
    'trim off the " at he begining and end of the command
    TheCommand = Right(Command$, Len(Command$) - 1)
    TheCommand = Left(TheCommand, Len(TheCommand) - 1)

    If Right(TheCommand, 4) = ".rar" Then
    'if it is then put the name of the file in the text box
        Me.txtOpenRar.Text = TheCommand
        'reset the form back to normal
        Call ResetForm
        'obtain number of files in the archive
        Call ListFiles_Click
    Else ' the file is not a rar archive
        MsgBox "不是一个 Rar 文件!", vbOKOnly + vbExclamation, "提示"
    End If
End If


End Sub


Private Sub Form_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
Call txtOpenRar_OLEDragDrop(Data, Effect, Button, Shift, X, Y)
End Sub

Private Sub Form_Resize()
If Me.Width < 5800 Then
    Me.Width = 5800
End If
Me.ListView.Width = Me.Width - 110
Me.txtOpenRar.Width = Me.Width - 1200
Me.txtOutputPath.Width = Me.Width - 1200
'Me.lblCredits.Left = Me.Width - 1150
End Sub

'damn memory leak wont survive this!!
Private Sub Form_Terminate()
'Unload FilesInArchive 'logical order
Unload Me 'always me last
End Sub

Private Sub Form_Unload(Cancel As Integer)
'Unload FilesInArchive
Unload Me
End Sub


Private Sub lblCredits_Click()
MsgBox "Thanks to:" _
& vbCrLf _
& vbCrLf & "- WinRar for making the Unrar.dll file free to use" _
& vbCrLf & "- Leigh Bowers for the basis of the Unrar.dll code" _
& vbCrLf & "- Pedro Lamas for the code on how to list files using the unrar.dll" _
& vbCrLf & "- Rossini Enrico for his breakdown of the Unrar.dll code and file flags" _
& vbCrLf & "- Microsoft for the Open Dialog API code" _
& vbCrLf & "- D. Rijmenants for the Open Directory API" _
& vbCrLf & "- Mike Bouffler for his Icon Suite/Edit program, which all the icons are made from" _
& vbCrLf & "- FrozenPea of VbCity.com for showing me how to read Rar comments" _
& vbCrLf & "- Me, Ashley Butler for implementing and editing all the code and creating the GUI" _
, vbInformation + vbOKOnly, "Program Credits"

'http://edais.mvps.org/Tutorials/Graphics/GFXch5.html for bitshifting



End Sub

Private Sub Toolbar_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button
    Case "1) 选择Rar压缩文件"
        Call btnOpenRar_Click
    Case "2) 选择解压缩路径"
        Call cmdChangeDir_Click
    Case "3) 解压缩文件"
        Call btnProcess_Click
End Select

End Sub

Private Sub txtOpenRar_KeyPress(KeyAscii As Integer)
KeyAscii = 0
End Sub

Private Sub txtOpenRar_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
'allows a rar archive to be dropped on the open rar text box


'check to see if its a rar archive
If Right(Data.Files(1), 4) = ".rar" Then
    'if it is then put the name of the file in the text box
    Me.txtOpenRar.Text = Data.Files(1)
    'reset the form back to normal
    Call ResetForm
    'obtain number of files in the archive
    Call ListFiles_Click
Else ' the file is not a rar archive
    MsgBox "你选择的不是一个RAR格式的文件。", vbOKOnly + vbExclamation, "提示"
End If
End Sub

Private Sub txtOutputPath_KeyPress(KeyAscii As Integer)
KeyAscii = 0
End Sub



Private Sub btnPasswordHelp_Click()
MsgBox "如果你没有档案的密码,你就无法进行 " _
& vbCrLf & vbCrLf & "如果密码错误,则不会被解压缩.", vbInformation, "提示"
End Sub

Sub ResetForm()

'
'
'
'
'clear treeview
Set Lisx = Nothing
Me.ListView.ListItems.Clear

Me.btnShowComment.Enabled = False
TotalArchiveSize = 0 'clears archive size, allows proper reporting of file lenght
NumberOfFilesInArchive = 0 'clears the counter of files in archive
PasswordStatus = False ' resets password status

Me.txtPassword.Visible = False 'disables password field
Me.lblpassword.Visible = False
Me.btnPasswordHelp.Visible = False

'Me.txtPassword.BackColor = RGB(230, 230, 230) 'vbgrey doesn't exist so....
Me.txtPassword.Text = "" 'clear text in password field
Me.btnReload.Enabled = False
End Sub

Private Sub btnOpenRar_Click()
Call ResetForm


On Error GoTo ErrorHandler
'MsgBox "err handle is off"
txtOpenRar.Text = ShowOpenDialog("选择一个rar文件", "Rar 文件 (*.Rar)", "*.Rar", Me, App.path)
'go to old error handler otherwise an error is created further on
If txtOpenRar.Text = "" Then Err.Number = 32755: GoTo ErrorHandler
Call ListFiles_Click

Debug.Print ArchiveComment
If ArchiveComment <> "" Then
    Me.btnShowComment.Enabled = True
    MsgBox ArchiveComment, vbOKOnly, "压缩文件注释"
Else
    Me.btnShowComment.Enabled = False
End If
Exit Sub

ErrorHandler: 'error handler
Debug.Print Err.Number
If Err.Number = 32755 Then 'the cancel error code
    txtOpenRar.Text = ""
'    lblFilesInArchive.Caption = "?? files and ?? folders in Archive"
    '
    '
    '
    '
    'clear treeview
    'FilesInArchive.List1.Clear
ElseIf Err.Number = 53 Then
    MsgBox "Unrar.dll 不存在或者没有注册，请复制压缩包中的UNRAR.DLL到 System32 文件夹。", vbCritical + vbOKOnly, "提示"
Else
    MsgBox "未知错误", vbCritical, "错误"
End If

End Sub

Private Sub ListFiles_Click()

'doevents mean disable all buttons
'Me.btnOpenRar.Enabled = False
'Me.btnPasswordHelp.Enabled = False
'FilesInArchive.List1.Enabled = False
'Me.lblCredits.Enabled = False
'Me.btnProcess.Enabled = False
'Me.cmdChangeDir.Enabled = False

Set Lisx = Nothing
Me.ListView.ListItems.Clear
'frmsource.listview.listitems.Clear
'set the root to be the archive that was selected
'Set Lisx = frmSource.listview.Nodes.Add(, , "Main Archive", Me.txtOpenRar.Text, 3, 3)

Call RARExtract("ObtainList", Me.txtOpenRar, , Me.txtPassword.Text)

're-enable all buttons
'Me.btnOpenRar.Enabled = True
'Me.btnPasswordHelp.Enabled = True
'FilesInArchive.List1.Enabled = True
'Me.lblCredits.Enabled = True
'Me.btnProcess.Enabled = True
'Me.cmdChangeDir.Enabled = True

'lblFilesInArchive = NumberOfFilesInArchive & " file(s) and " & iFolderCount & " folder(s) in Archive"   'displays the number of files in a nice label

End Sub