Как я могу скопировать открытый файл с помощью VB6?

Question

У меня есть старое приложение VB6, которое загружает вложения файлов в поле BLOB базы данных. Он работает нормально, если у пользователя нет открытого файла.

Я пытался создать копию файла, затем загрузить эту копию, но, к моему удивлению, процедура FileCopy выдает ошибку «Отказано в доступе» всякий раз, когда вы пытаетесь скопировать файл, открытый пользователем.

Это меня удивило, потому что вы можете скопировать файл в проводнике Windows, когда он открыт, и я предполагал, что метод FileCopy использовал тот же вызов API, что и проводник.

В любом случае, мой вопрос: Как мне скопировать открытый файл в VB6?

Answer 1

Отвечая на мой вопрос:

Основываясь на этой статье , ответ, который работал для меня, описан ниже.

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

Answer 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

exitcopy:

Close #FF1, #FF2

Функция выхода

ErrorCopy: ErrCount = ErrCount + 1

Если ErrCount> 2000, то

SharedFilecopy = False

Resume exitcopy

прочее

Resume

End If

Функция завершения

Answer 3

Сокращенное решение:

1- Проект -> Рекомендации. Проверьте «Microsoft Scripting Runtime»

2- Используйте это:

Dim fso As New FileSystemObject 
fso.CopyFile file1, file2