如何使用 VB6 复制打开的文件？答案

【问题标题】：How can I copy an open file using VB6?如何使用 VB6 复制打开的文件？
【发布时间】：2013-09-14 06:07:56
【问题描述】：

我有一个将文件附件上传到数据库 BLOB 字段的旧版 VB6 应用程序。除非用户打开文件，否则它工作正常。

我尝试创建文件的副本，然后上传该副本，但令我惊讶的是，每当您尝试复制用户打开的文件时，FileCopy 过程都会收到“权限被拒绝”错误。

这让我很吃惊，因为您可以在 Windows 资源管理器中复制打开的文件，而且我假设 FileCopy 方法使用与资源管理器相同的 API 调用。

无论如何，我的问题是：如何在 VB6 中复制打开的文件？

【问题讨论】：

标签： vb6

【解决方案1】：

回答我自己的问题：

Based on this article，对我有用的答案如下所述。

1 - 将此声明添加到 VB 文件中：

Declare Function apiCopyFile Lib "kernel32" Alias "CopyFileA" _
      (ByVal lpExistingFileName As String, _
      ByVal lpNewFileName As String, _
      ByVal bFailIfExists As Long) As Long

2 - 为该函数创建一个小包装器，如下所示：

Sub CopyFileEvenIfOpen(SourceFile As String, DestFile As String)
  Dim Result As Long
   If Dir(SourceFile) = "" Then
     MsgBox Chr(34) & SourceFile & Chr(34) & " is not valid file name."
   Else
     Result = apiCopyFile(SourceFile, DestFile, False)
   End If
End Sub

3 - 将我之前对 FileCopy 的调用替换为：

CopyFileEvenIfOpen sourceFile, tempFile

【讨论】：

我喜欢让这些小包装例程像原生 VB6 例程一样工作。如果源文件不存在，我会引发错误，而不是显示消息框。另外我会检查 Result 0 （这表明复制失败）并在这种情况下也会引发错误。

【解决方案2】：

如果您想在不使用 api 的情况下做同样的事情：

函数 SharedFilecopy(ByVal SourcePath As String, ByVal DestinationPath As String)

Dim FF1 As Long, FF2 As Long
Dim Index As Long
Dim FileLength As Long
Dim LeftOver As Long
Dim NumBlocks As Long
Dim filedata As String
Dim ErrCount As Long
On Error GoTo ErrorCopy
'-------------
'Copy the file
'-------------
Const BlockSize = 32767
FF1 = FreeFile
Open SourcePath$ For Binary Access Read As #FF1
FF2 = FreeFile
Open DestinationPath For Output As #FF2
Close #FF2

Open DestinationPath For Binary As #FF2

Lock #FF1: Lock #FF2

FileLength = LOF(FF1)
NumBlocks = FileLength \ BlockSize
LeftOver = FileLength Mod BlockSize

filedata = String$(LeftOver, 32)

Get #FF1, , filedata
Put #FF2, , filedata
filedata = ""
filedata = String$(BlockSize, 32)

For Index = 1 To NumBlocks
    Get #FF1, , filedata
    Put #FF2, , filedata
Next Index
Unlock #FF1: Unlock #FF2
SharedFilecopy = True

退出复制：

Close #FF1, #FF2

退出函数

错误复制： ErrCount = ErrCount + 1

如果 ErrCount > 2000 那么

SharedFilecopy = False

Resume exitcopy

其他

Resume

如果结束

结束函数

【讨论】：

【解决方案3】：

更短的解决方案：

1- 项目 -> 参考。检查“Microsoft 脚本运行时”

2- 使用这个：

Dim fso As New FileSystemObject 
fso.CopyFile file1, file2

【讨论】：