main.frm

主要是一些文件操作的技巧

      Width           =   1695
   End
   Begin VB.DriveListBox cboDrive 
      Height          =   300
      Index           =   0
      Left            =   120
      TabIndex        =   5
      Top             =   600
      Width           =   1935
   End
   Begin VB.DirListBox lstDir 
      Height          =   1560
      Index           =   0
      Left            =   120
      TabIndex        =   4
      Top             =   960
      Width           =   1935
   End
   Begin VB.DriveListBox cboDrive 
      Height          =   300
      Index           =   1
      Left            =   4200
      TabIndex        =   3
      Top             =   600
      Width           =   2055
   End
   Begin VB.DirListBox lstDir 
      Height          =   1560
      Index           =   1
      Left            =   4200
      TabIndex        =   2
      Top             =   960
      Width           =   2055
   End
   Begin VB.FileListBox lstFile 
      Height          =   1710
      Index           =   0
      Left            =   120
      MultiSelect     =   2  'Extended
      TabIndex        =   1
      Top             =   2640
      Width           =   1935
   End
   Begin VB.FileListBox lstFile 
      Height          =   1710
      Index           =   1
      Left            =   4200
      TabIndex        =   0
      Top             =   2640
      Width           =   2055
   End
   Begin VB.Label Label4 
      Caption         =   "目的文件:"
      Height          =   255
      Left            =   4200
      TabIndex        =   7
      Top             =   360
      Width           =   2775
   End
   Begin VB.Label Label5 
      Caption         =   "源文件:"
      Height          =   255
      Left            =   120
      TabIndex        =   6
      Top             =   360
      Width           =   1455
   End
End
Attribute VB_Name = "Main"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

' 文件操作结构体
Private Type SHFILEOPSTRUCT
    hwnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer
    fAnyOperationsAborted As Boolean
    hNameMappings As Long
    lpszProgressTitle As String
End Type
' 文件操作函数
Private Declare Function SHFileOperation Lib "shell32.dll" Alias _
    "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias _
    "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation _
    As String, ByVal lpFile As String, ByVal lpParameters As _
    String, ByVal lpDirectory As String, ByVal nShowCmd As Long) _
    As Long
' 文件操作常量
Const FO_MOVE = 1
Const FO_COPY = 2
Const FO_DELETE = 3
Const FO_RENAME = 4
' 文件操作选择常量
Const FOF_MULTIDESTFILES = &H1
Const FOF_SILENT = &H4
Const FOF_RENAMEONCOLLISION = &H8
Const FOF_NOCONFIRMATION = &H10
Const FOF_WANTMAPPINGHANDLE = &H20
Const FOF_ALLOWUNDO = &H40
Const FOF_FILESONLY = &H80
Const FOF_SIMPLEPROGRESS = &H100
Const FOF_NOCONFIRMMKDIR = &H200
' 格式化磁盘
Private Declare Function SHFormatDrive Lib "shell32" _
    (ByVal hwnd As Long, ByVal Drive As Long, ByVal fmtID _
    As Long, ByVal options As Long) As Long
' 获取磁盘属性
Private Declare Function GetDriveType Lib "kernel32" Alias _
    "GetDriveTypeA" (ByVal nDrive As String) As Long

' 获取文件名
Private Function GetFileSpecs(Index As Integer) As String
    Dim I As Integer
    Dim strPath As String, FileSpecs As String
    
    strPath = lstFile(Index).Path
    If Right$(strPath, 1) <> "\" Then
        strPath = strPath & "\"
    End If
    For I = 0 To (lstFile(Index).ListCount - 1)
        If lstFile(Index).Selected(I) Then
            FileSpecs = FileSpecs & strPath & _
                lstFile(Index).List(I) & Chr$(0)
        End If
    Next I
    GetFileSpecs = FileSpecs
End Function


Private Sub cmdDiskCopy_Click()
    Dim DriveLetter$, DriveNumber&, DriveType&
    Dim RetVal&, RetFromMsg&
    DriveLetter = UCase(Drive1.Drive)
    DriveNumber = (Asc(DriveLetter) - 65)
    DriveType = GetDriveType(DriveLetter)
    If DriveType = 2 Then
        RetVal = Shell("rundll32.exe diskcopy.dll,DiskCopyRunDll " _
            & DriveNumber & "," & DriveNumber, 1) 'Notice space after
    Else   ' Just in case                         'DiskCopyRunDll
        RetFromMsg = MsgBox("Only floppies can" & vbCrLf & _
            "be diskcopied!", 64, "DiskCopy Example")
    End If
End Sub

Private Sub cmdDiskSpace_Click()
    Dim X As Double
    X = DiskSpaceInBytes(drvDrive.Drive)
        If X = -1 Then
        MsgBox "Function failed!", vbCritical, "Error"
    Else
        txtSpaceFree.Text = Format(X, "###,###") & " bytes"
    End If
End Sub

Private Sub cmdFormat_Click()
    Dim DriveLetter$, DriveNumber&, DriveType&
    Dim RetVal&, RetFromMsg%
    DriveLetter = UCase(Drive1.Drive)
    DriveNumber = (Asc(DriveLetter) - 65)
    DriveType = GetDriveType(DriveLetter)
    If DriveType = 2 Then
        RetVal = SHFormatDrive(Me.hwnd, DriveNumber, 0&, 0&)
    Else
        RetFromMsg = MsgBox("不是可移动的磁盘" & vbCrLf & _
            "drive! Format this drive?", 276, "SHFormatDrive Example")
      
    End If
End Sub

Private Sub cmdOpens_Click()
    Dim FileOp As SHFILEOPSTRUCT
    On Error GoTo colorerror
        FileOp.hwnd = 0
        FileOp.wFunc = FO_DELETE
        ChDrive lstFile(0).Path
        ChDir lstFile(0).Path
        If chkEntireDir = 1 Then
            FileOp.pFrom = lstFile(0).Path & Chr$(0)
        Else
            FileOp.pFrom = GetFileSpecs(0)
            If Len(FileOp.pFrom) = 0 Then
                MsgBox "文件没有选择"
                Exit Sub
            End If
        End If
        '打开文件
    Call ShellExecute(hwnd, "Open", FileOp.pFrom, "", App.Path, 1)
    Exit Sub
colorerror:
    MsgBox ("Please, check the PATH")
End Sub

Private Sub Command9_Click()
    Dim FileOp As SHFILEOPSTRUCT
    On Error GoTo colorerror
        FileOp.hwnd = 0
        FileOp.wFunc = FO_DELETE
        ChDrive lstFile(1).Path
        ChDir lstFile(1).Path
        If chkEntireDir = 1 Then
            FileOp.pFrom = lstFile(1).Path & Chr$(0)
        Else
            FileOp.pFrom = GetFileSpecs(1)
            If Len(FileOp.pFrom) = 0 Then
                MsgBox "文件没有选择"
                Exit Sub
            End If
        End If
        '打开文件
    Call ShellExecute(hwnd, "Open", FileOp.pFrom, "", App.Path, 1)
    Exit Sub
colorerror:
    MsgBox ("Please, check the PATH")
End Sub


Private Sub cboDrive_Change(Index As Integer)
    On Error GoTo colorerror
        lstDir(Index) = cboDrive(Index)
        Exit Sub
colorerror:
End Sub

Private Sub lstDir_Change(Index As Integer)
   On Error GoTo colorerror
    lstFile(Index) = lstDir(Index)
    Exit Sub
colorerror:
End Sub

Private Sub cmdExecute_Click(Index As Integer)
    Dim FileOp As SHFILEOPSTRUCT
    
    
    FileOp.hwnd = 0
    
    If Index = 0 Then
        FileOp.wFunc = FO_COPY
    ElseIf Index = 1 Then
        FileOp.wFunc = FO_MOVE
    ElseIf Index = 2 Then
        FileOp.wFunc = FO_DELETE
   
    End If
   
    ChDrive lstFile(0).Path
    ChDir lstFile(0).Path
    
    If chkEntireDir = 1 Then
        FileOp.pFrom = lstFile(0).Path & Chr$(0)
    Else
        FileOp.pFrom = GetFileSpecs(0)
        If Len(FileOp.pFrom) = 0 Then
            MsgBox "没有选择文件"
            Exit Sub
        End If
    End If
    
    FileOp.pTo = lstFile(1).Path & Chr$(0)
    ' 设置文件操作选项
    If chkUndo = 1 Then
        FileOp.fFlags = FileOp.fFlags Or FOF_ALLOWUNDO
    End If
    If chkShowDlg = 0 Then
        FileOp.fFlags = FileOp.fFlags Or FOF_SILENT
    End If
    If chkRename = 1 Then
        FileOp.fFlags = FileOp.fFlags Or FOF_RENAMEONCOLLISION
    End If
    If chkConfirmOp = 0 Then
        FileOp.fFlags = FileOp.fFlags Or FOF_NOCONFIRMATION
    End If
    If chkConfirmMkDir = 0 Then
        FileOp.fFlags = FileOp.fFlags Or FOF_NOCONFIRMMKDIR
    End If
    If chkShowFile = 0 Then
        FileOp.fFlags = FileOp.fFlags Or FOF_SIMPLEPROGRESS
        
    End If
    ' 对文件进行操作
    If SHFileOperation(FileOp) <> 0 Then
        MsgBox "Did not complete operation successfully."
    End If
    ' 更新
    lstFile(0).Refresh: lstDir(0).Refresh
    lstFile(1).Refresh: lstDir(1).Refresh
End Sub