VB与Windows资源管理器互拷文件

模块

Option ExplicitPrivate Type POINTAPI    x As Long    y As LongEnd TypePrivate Type SHFILEOPSTRUCT    hwnd As Long    wFunc As Long    pFrom As String    pTo As String    fFlags As Integer    fAnyOperationsAborted As Long    hNameMappings As Long    lpszProgressTitle As StringEnd TypePrivate Declare Function SHFileOperation _                Lib "shell32.dll" _                Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long'剪贴板处理函数Private Declare Function EmptyClipboard Lib "user32" () As LongPrivate Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As LongPrivate Declare Function CloseClipboard Lib "user32" () As LongPrivate Declare Function SetClipboardData _                Lib "user32" (ByVal wFormat As Long, _                              ByVal hMem As Long) As LongPrivate Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPrivate Declare Function IsClipboardFormatAvailable _                Lib "user32" (ByVal wFormat As Long) As LongPrivate Declare Function DragQueryFile _                Lib "shell32.dll" _                Alias "DragQueryFileA" (ByVal hDrop As Long, _                                        ByVal UINT As Long, _                                        ByVal lpStr As String, _                                        ByVal ch As Long) As LongPrivate Declare Function DragQueryPoint _                Lib "shell32.dll" (ByVal hDrop As Long, _                                   lpPoint As POINTAPI) As LongPrivate Declare Function GlobalAlloc _                Lib "kernel32" (ByVal wFlags As Long, _                                ByVal dwBytes As Long) As LongPrivate Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As LongPrivate Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As LongPrivate Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As LongPrivate Declare Sub CopyMem _                Lib "kernel32" _                Alias "RtlMoveMemory" (Destination As Any, _                                       Source As Any, _                                       ByVal Length As Long)'剪贴板数据格式定义Private Const CF_TEXT = 1Private Const CF_BITMAP = 2Private Const CF_METAFILEPICT = 3Private Const CF_SYLK = 4Private Const CF_DIF = 5Private Const CF_TIFF = 6Private Const CF_OEMTEXT = 7Private Const CF_DIB = 8Private Const CF_PALETTE = 9Private Const CF_PENDATA = 10Private Const CF_RIFF = 11Private Const CF_WAVE = 12Private Const CF_UNICODETEXT = 13Private Const CF_ENHMETAFILE = 14Private Const CF_HDROP = 15Private Const CF_LOCALE = 16Private Const CF_MAX = 17' 内存操作定义Private Const GMEM_FIXED = &H0Private Const GMEM_MOVEABLE = &H2Private Const GMEM_NOCOMPACT = &H10Private Const GMEM_NODISCARD = &H20Private Const GMEM_ZEROINIT = &H40Private Const GMEM_MODIFY = &H80Private Const GMEM_DISCARDABLE = &H100Private Const GMEM_NOT_BANKED = &H1000Private Const GMEM_SHARE = &H2000Private Const GMEM_DDESHARE = &H2000Private Const GMEM_NOTIFY = &H4000Private Const GMEM_LOWER = GMEM_NOT_BANKEDPrivate Const GMEM_VALID_FLAGS = &H7F72Private Const GMEM_INVALID_HANDLE = &H8000Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)Private Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)Private Const FO_COPY = &H2Private Type DROPFILES    pFiles As Long    pt As POINTAPI    fNC As Long    fWide As LongEnd TypePublic Function clipCopyFiles(Files() As String) As Boolean    Dim data     As String    Dim df       As DROPFILES    Dim hGlobal  As Long    Dim lpGlobal As Long    Dim i        As Long       '清除剪贴板中现存的数据    If OpenClipboard(0&) Then        Call EmptyClipboard              For i = LBound(Files) To UBound(Files)            data = data & Files(i) & vbNullChar        Next i        data = data & vbNullChar        '为剪贴板拷贝操作分配相应大小的内存        hGlobal = GlobalAlloc(GHND, Len(df) + Len(data))        If hGlobal Then            lpGlobal = GlobalLock(hGlobal)                     df.pFiles = Len(df)            '将DropFiles结构拷贝到内存中            Call CopyMem(ByVal lpGlobal, df, Len(df))            '将文件全路径名拷贝到分配的内存中。            Call CopyMem(ByVal (lpGlobal + Len(df)), ByVal data, Len(data))            Call GlobalUnlock(hGlobal)                     '将数据拷贝到剪贴板上            If SetClipboardData(CF_HDROP, hGlobal) Then                clipCopyFiles = True            End If        End If        Call CloseClipboard    End IfEnd FunctionPublic Function clipPasteFiles(Files() As String) As Long    Dim hDrop      As Long    Dim nFiles     As Long    Dim i          As Long    Dim desc       As String    Dim filename   As String    Dim pt         As POINTAPI    Dim tfStr      As SHFILEOPSTRUCT    Const MAX_PATH As Long = 260       '确定剪贴板的数据格式是文件，并打开剪贴板    If IsClipboardFormatAvailable(CF_HDROP) Then        If OpenClipboard(0&) Then            hDrop = GetClipboardData(CF_HDROP)            '获得文件数            nFiles = DragQueryFile(hDrop, -1&, "", 0)                  ReDim Files(0 To nFiles - 1) As String            filename = Space(MAX_PATH)                     '确定执行的操作类型为拷贝操作            tfStr.wFunc = FO_COPY            '目的路径设置为File1指定的路径            tfStr.pTo = Form1.File1.Path                     For i = 0 To nFiles - 1                '根据获取的每一个文件执行文件拷贝操作                Call DragQueryFile(hDrop, i, filename, Len(filename))                Files(i) = TrimNull(filename)                tfStr.pFrom = Files(i)                SHFileOperation tfStr            Next i            Form1.File1.Refresh            Form1.Dir1.Refresh                     Call CloseClipboard        End If        clipPasteFiles = nFiles    End IfEnd FunctionPrivate Function TrimNull(ByVal StrIn As String) As String    Dim nul As Long       nul = InStr(StrIn, vbNullChar)    Select Case nul        Case Is > 1            TrimNull = Left(StrIn, nul - 1)        Case 1            TrimNull = ""        Case 0            TrimNull = Trim(StrIn)    End SelectEnd Function

窗体

添加控件：

一个FileListBox，Name = File1

一个DirListBox，Name = Dir1

一个DriveListBox，Name = Drive1

两个CommandButton，Name = cmdCopy / cmdPaste

Private Sub Dir1_Change()    File1.Path = Dir1.PathEnd SubPrivate Sub Drive1_Change()    Dir1.Path = Drive1.DriveEnd SubPrivate Sub cmdCopy_Click()    Dim Files() As String    Dim Path    As String    Dim i       As Long, n As Long       Path = Dir1.Path    If Right(Path, 1) <> "\" Then        Path = Path & "\"    End If       '根据在File1上的选择建立拷贝文件的列表    With File1        For i = 0 To .ListCount - 1            If .Selected(i) Then                ReDim Preserve Files(0 To n) As String                Files(n) = Path & .List(i)                n = n + 1            End If        Next i    End With       '拷贝文件到Clipboard    If clipCopyFiles(Files) Then        MsgBox "拷贝文件成功。", , "Success"    Else        MsgBox "无法拷贝文件。", , "Failure"    End IfEnd SubPrivate Sub cmdPaste_Click()    Dim Files() As String    Dim nRet    As Long    Dim i       As Long    Dim msg     As String       nRet = clipPasteFiles(Files)    If nRet Then        For i = 0 To nRet - 1            msg = msg & Files(i) & vbCrLf        Next i        MsgBox msg, , "共粘贴" & nRet & "个文件"    Else        MsgBox "从剪贴板粘贴文件错误。", , "Failure"    End IfEnd Sub