Question

VB6.0拷贝文件后手动粘贴

我想用写一个一个小程序自动生成一个文件后，然后在界面上点击复制按钮，复制到内存（相当于用鼠标点右键复制），再手工点鼠标粘贴到想要路径下。
求 “复制按钮” 下的代码，该如何操作？

Answer 1

'剪贴版数据格式定义
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type DROPFILES
pFiles As Long
pt As POINTAPI
fNC As Long
fWide As Long
End Type
Private Const CF_HDROP = 15
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
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 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)
Dim FileFullName As String
Public Function clipCopyFiles(FileName As String) As Boolean
Dim df As DROPFILES
Dim hGlobal As Long
Dim lpGlobal As Long

'清除剪贴版中现存的数据
If OpenClipboard(0&) Then
Call EmptyClipboard
FileName = FileName & vbNullChar
'为剪贴版拷贝操作分配相应大小的内存
hGlobal = GlobalAlloc(GHND, Len(df) + Len(FileName))
If hGlobal Then
lpGlobal = GlobalLock(hGlobal)
df.pFiles = Len(df)
Call CopyMem(ByVal lpGlobal, df, Len(df))
Call CopyMem(ByVal (lpGlobal + Len(df)), ByVal FileName, Len(FileName))
Call GlobalUnlock(hGlobal)
'将数据拷贝到剪贴版上
If SetClipboardData(CF_HDROP, hGlobal) Then
clipCopyFiles = True
End If
Call GlobalFree(hGlobal)
End If
Call CloseClipboard
End If
End Function

Sub Button1_Click()
'拷贝文件到Clipboard
FileFullName = "d:\test\a.txt"
If clipCopyFiles(FileFullName) Then
MsgBox "拷贝文件成功.", , Success
Else
MsgBox "无法拷贝文件...", , Failure
End If
End Sub

追问

不能用

追答

Dim FileFullName As String

Public Function clipCopyFiles(FileName As String) As Boolean
Dim df As DROPFILES
Dim hGlobal As Long
Dim lpGlobal As Long
If OpenClipboard(0&) Then
Call EmptyClipboard
'FileName = FileName & vbNullChar
hGlobal = GlobalAlloc(GHND, Len(df) + Len(FileName))
If hGlobal Then
lpGlobal = GlobalLock(hGlobal)
df.pFiles = Len(df)
Call CopyMem(ByVal lpGlobal, df, Len(df))
Call CopyMem(ByVal (lpGlobal + Len(df)), ByVal FileName, Len(FileName))
Call GlobalUnlock(hGlobal)
If SetClipboardData(CF_HDROP, hGlobal) Then
clipCopyFiles = True
End If
Call GlobalFree(hGlobal)
End If
Call CloseClipboard
End If
End Function

Sub Button1_Click()
'拷贝文件到Clipboard
FileFullName = "d:\test\a.txt"
If clipCopyFiles(FileFullName) Then
MsgBox "拷贝文件成功.", , Success
Else
MsgBox "无法拷贝文件...", , Failure
End If
End Sub
把 'FileName = FileName & vbNullChar这行注释掉。在WIN7/XP下测试可以用。

追问

还是不能粘贴，提示拷贝文件成功，鼠标右键里面粘贴变亮可用，但是点粘贴没反应。我在QQ窗口里面粘贴提示