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

模块

Option Explicit

Private Type POINTAPI

    x As Long
    y As Long

End Type

Private 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 String

End Type

Private Declare Function SHFileOperation _
                Lib "shell32.dll" _
                Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long

'剪贴板处理函数
Private Declare Function EmptyClipboard Lib "user32" () As Long

Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function CloseClipboard Lib "user32" () As Long

Private Declare Function SetClipboardData _
                Lib "user32" (ByVal wFormat As Long, _
                              ByVal hMem As Long) As Long

Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long

Private Declare Function IsClipboardFormatAvailable _
                Lib "user32" (ByVal wFormat As Long) As Long

Private 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 Long

Private Declare Function DragQueryPoint _
                Lib "shell32.dll" (ByVal hDrop As Long, _
                                   lpPoint As POINTAPI) As Long

Private Declare Function GlobalAlloc _
                Lib "kernel32" (ByVal wFlags As Long, _
                                ByVal dwBytes As Long) As Long

Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long

Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long

Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long

Private Declare Sub CopyMem _
                Lib "kernel32" _
                Alias "RtlMoveMemory" (Destination As Any, _
                                       Source As Any, _
                                       ByVal Length As Long)

'剪贴板数据格式定义
Private Const CF_TEXT = 1

Private Const CF_BITMAP = 2

Private Const CF_METAFILEPICT = 3

Private Const CF_SYLK = 4

Private Const CF_DIF = 5

Private Const CF_TIFF = 6

Private Const CF_OEMTEXT = 7

Private Const CF_DIB = 8

Private Const CF_PALETTE = 9

Private Const CF_PENDATA = 10

Private Const CF_RIFF = 11

Private Const CF_WAVE = 12

Private Const CF_UNICODETEXT = 13

Private Const CF_ENHMETAFILE = 14

Private Const CF_HDROP = 15

Private Const CF_LOCALE = 16

Private Const CF_MAX = 17

' 内存操作定义
Private Const GMEM_FIXED = &H0

Private Const GMEM_MOVEABLE = &H2

Private Const GMEM_NOCOMPACT = &H10

Private Const GMEM_NODISCARD = &H20

Private Const GMEM_ZEROINIT = &H40

Private Const GMEM_MODIFY = &H80

Private Const GMEM_DISCARDABLE = &H100

Private Const GMEM_NOT_BANKED = &H1000

Private Const GMEM_SHARE = &H2000

Private Const GMEM_DDESHARE = &H2000

Private Const GMEM_NOTIFY = &H4000

Private Const GMEM_LOWER = GMEM_NOT_BANKED

Private Const GMEM_VALID_FLAGS = &H7F72

Private Const GMEM_INVALID_HANDLE = &H8000

Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)

Private Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)

Private Const FO_COPY = &H2

Private Type DROPFILES

    pFiles As Long
    pt As POINTAPI
    fNC As Long
    fWide As Long

End Type

Public 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 If

End Function

Public 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 If

End Function

Private 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 Select

End Function

窗体

添加控件：

一个FileListBox，Name = File1

一个DirListBox，Name = Dir1

一个DriveListBox，Name = Drive1

两个CommandButton，Name = cmdCopy / cmdPaste

Private Sub Dir1_Change()
    File1.Path = Dir1.Path

End Sub

Private Sub Drive1_Change()
    Dir1.Path = Drive1.Drive

End Sub

Private 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 If

End Sub

Private 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 If

End Sub