VB 复制文件或文件夹到系统剪贴板
VB 复制文件或文件夹到系统剪贴板
'-----------------------------------------------------------模块内容
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
'VB API URL编码 URL解码
Public Const MAX_PATH As Long = 260
Public Const ERROR_SUCCESS As Long = 0
'将整个URL参数作为一个URL段
Public Const URL_ESCAPE_SEGMENT_ONLY As Long = &H2000
Public Const URL_ESCAPE_PERCENT As Long = &H1000
Public Const URL_UNESCAPE_INPLACE As Long = &H100000
'路径中包含#
Public Const URL_INTERNAL_PATH As Long = &H800000
Public Const URL_DONT_ESCAPE_EXTRA_INFO As Long = &H2000000
Public Const URL_ESCAPE_SPACES_ONLY As Long = &H4000000
Public Const URL_DONT_SIMPLIFY As Long = &H8000000
'转换不安全字符为相应的退格序列
Public Declare Function UrlEscape Lib "shlwapi" _
Alias "UrlEscapeA" _
(ByVal pszURL As String, _
ByVal pszEscaped As String, _
pcchEscaped As Long, _
ByVal dwFlags As Long) As Long
'Download by http://www.codefans.net
'转换退格序列为普通的字符
Public Declare Function UrlUnescape Lib "shlwapi" _
Alias "UrlUnescapeA" _
(ByVal pszURL As String, _
ByVal pszUnescaped As String, _
pcchUnescaped As Long, _
ByVal dwFlags As Long) As Long
'VB API URL编码 URL解码
Public Function EncodeUrl(ByVal sUrl As String) As String
Dim sUrlEsc As String
Dim dwSize As Long
Dim dwFlags As Long
If Len(sUrl) > 0 Then
sUrlEsc = Space$(MAX_PATH)
dwSize = Len(sUrlEsc)
dwFlags = URL_DONT_SIMPLIFY
If UrlEscape(sUrl, _
sUrlEsc, _
dwSize, _
dwFlags) = ERROR_SUCCESS Then
EncodeUrl = Left$(sUrlEsc, dwSize)
End If 'If UrlEscape
End If 'If Len(sUrl) > 0
End Function
Public Function DecodeUrl(ByVal sUrl As String) As String
Dim sUrlUnEsc As String
Dim dwSize As Long
Dim dwFlags As Long
If Len(sUrl) > 0 Then
sUrlUnEsc = Space$(MAX_PATH)
dwSize = Len(sUrlUnEsc)
dwFlags = URL_DONT_SIMPLIFY
If UrlUnescape(sUrl, _
sUrlUnEsc, _
dwSize, _
dwFlags) = ERROR_SUCCESS Then
DecodeUrl = Left$(sUrlUnEsc, dwSize)
End If 'If UrlUnescape
End If 'If Len(sUrl) > 0
End Function
'
'出处不明.
Public Function clipCopyFiles(DataFiles 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
DataFiles = DataFiles & vbNullChar
data = DataFiles
'为剪贴板拷贝操作分配相应大小的内存
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(DataFiles As String, TargetPath 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
'确定剪贴板的数据格式是文件，并打开剪贴板
If IsClipboardFormatAvailable(CF_HDROP) Then
If OpenClipboard(0&) Then
hDrop = GetClipboardData(CF_HDROP)
'获得文件数
nFiles = DragQueryFile(hDrop, -1&, "", 0)
filename = Space(MAX_PATH)
'确定执行的操作类型为拷贝操作
tfStr.wFunc = FO_COPY
'目的路径设置为File1指定的路径
tfStr.pTo = TargetPath
'执行拷贝操作
Call DragQueryFile(hDrop, 0, filename, Len(filename))
DataFiles = TrimNull(filename)
tfStr.pFrom = DataFiles
SHFileOperation tfStr
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
'-------------------------------------------
'窗体内容
'选择文件夹
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Const BIF_RETURNONLYFSDIRS = 1
Const BIF_NEWDIALOGSTYLE = &H40
Const BIF_EDITBOX = &H10
Const BIF_USENEWUI = BIF_NEWDIALOGSTYLE Or BIF_EDITBOX
Const MAX_PATH = 260
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Public Function BrowseForFolder(Optional sTitle As String = "请选择文件夹") As String
Dim iNull As Integer, lpIDList As Long, lResult As Long
Dim sPath As String, udtBI As BrowseInfo
With udtBI
.hWndOwner = 0 ' Me.hWnd
.lpszTitle = lstrcat(sTitle, "")
.ulFlags = BIF_RETURNONLYFSDIRS Or BIF_USENEWUI
End With
lpIDList = SHBrowseForFolder(udtBI)
If lpIDList Then
sPath = String$(MAX_PATH, 0)
SHGetPathFromIDList lpIDList, sPath
CoTaskMemFree lpIDList
iNull = InStr(sPath, vbNullChar)
If iNull Then
sPath = Left$(sPath, iNull - 1)
End If
End If
BrowseForFolder = sPath
End Function
'---------选择文件夹
Private Sub cmdCopy_Click() '复制文件
Dim DataFiles As String
Dim Path As String
Dim i As Long, n As Long
DataFiles = File1.Path & "\" & File1.List(File1.ListIndex)
DataFiles = EncodeUrl(DataFiles) '将文件名编码防止路径出错
'编码后的路径名称更新
DataFiles = Replace(DataFiles, "%20", Space(1))
DataFiles = Replace(DataFiles, "%5C", "\")
DataFiles = Replace(DataFiles, "%26", "&")
If clipCopyFiles(DataFiles) Then
MsgBox DataFiles & vbCrLf & "拷贝文件成功。", , "Success"
Else
MsgBox DataFiles & vbCrLf & "无法拷贝文件。", , "Failure"
End If
End Sub
Private Sub cmdPaste_Click() '粘贴文件
Dim DataFiles As String
Dim nRet As Long
Dim i As Long
Dim msg As String
nRet = clipPasteFiles(DataFiles, File2.Path)
If nRet Then
'For i = 0 To nRet - 1
' msg = msg & Files(i) & vbCrLf
'Next i
msg = DataFiles
MsgBox msg, , "共粘贴" & nRet & "个文件"
File2.Refresh
Text3.Text = msg
Else
MsgBox "从剪贴板粘贴文件错误。", , "Failure"
End If
End Sub
Private Sub Command4_Click() '复制文件夹
Dim DataFiles As String
Dim Path As String
Dim i As Long, n As Long
'拷贝文件到Clipboard
DataFiles = File1.Path
DataFiles = EncodeUrl(DataFiles) '将路径编码防止出错
'将编码后的内容更新
DataFiles = Replace(DataFiles, "%20", Space(1))
DataFiles = Replace(DataFiles, "%5C", "\")
DataFiles = Replace(DataFiles, "%26", "&")
If clipCopyFiles(DataFiles) Then
MsgBox DataFiles & vbCrLf & "拷贝文件成功。", , "Success"
Else
MsgBox DataFiles & vbCrLf & "无法拷贝文件。", , "Failure"
End If
End Sub
Private Sub Command1_Click()
Dim p As String
p = ""
p = BrowseForFolder()
If p <> "" Then
Text1.Text = p
File1.Path = Text1.Text
File1.Refresh
End If
End Sub
Private Sub Command2_Click()
Dim p As String
p = ""
p = BrowseForFolder()
If p <> "" Then
Text4.Text = p
File2.Path = Text4.Text
File2.Refresh
End If
End Sub
Private Sub File1_Click()
Text2.Text = File1.Path & "\" & File1.List(File1.ListIndex)
CFileName = File1.Path & "\" & File1.List(File1.ListIndex)
End Sub
Private Sub File2_Click()
Text3.Text = File2.Path & "\" & File2.List(File2.ListIndex)
CFileName = File1.Path & "\" & File1.List(File1.ListIndex)
End Sub
Private Sub Form_Load()
File1.Path = "C:\Users\Administrator\Desktop"
File1.Refresh
File2.Path = "C:\Users\Administrator\Desktop\新建文件夹"
File2.Refresh
End Sub
'--------------------------窗体内容结束