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

I have a legacy VB6 application that uploads file attachments to a database BLOB field. It works fine unless a user has the file open.

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

I tried creating a copy of the file, then uploading that copy, but to my surprise, the FileCopy procedure gets a "permission denied" error whenever you try to copy a file that is open by the user.

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

This suprised me, because you can copy a file in Windows Explorer while it is open, and I was assuming that the FileCopy method used the same API call as explorer.

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

Anyway, my question is: How can I copy an open file in VB6?

无论如何,我的问题是:如何在VB6中复制打开的文件?

3 个解决方案

#1

Answering my own question:

回答我自己的问题:

Based on this article, the answer that worked for me is described below.

基于这篇文章,下面介绍了对我有用的答案。

1 - Add this declaration to the VB file:

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

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

2 - Create a little wrapper for that function, like so:

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 - Replace my previous call to FileCopy with this:

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

CopyFileEvenIfOpen sourceFile, tempFile

#2

If you would like to do the same without using the api:

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

Function SharedFilecopy(ByVal SourcePath As String, ByVal DestinationPath As String)

函数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

exitcopy:

Close #FF1, #FF2

Exit Function

ErrorCopy: ErrCount = ErrCount + 1

ErrorCopy:ErrCount = ErrCount + 1

If ErrCount > 2000 Then

如果ErrCount> 2000那么

SharedFilecopy = False

Resume exitcopy

Else

Resume

End If

End Function

#3

Shorter solution:

1- Project -> References. Check "Microsoft Scripting Runtime"

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

2- Use this:

2-使用这个:

Dim fso As New FileSystemObject 
fso.CopyFile file1, file2

#1