谁有 API 函数 CopyFileEx 复制大文件,并显示进度的代码

Cavan2022

哪位老师:
       有API 函数 CopyFileEx 复制大文件,并且能显示进度的代码?

       分享一下,谢谢!!

ykcbf1100

[API 函数] CopyFileEx - 复制档案
一般要处理复制档案使用 File.Copy 方法就可以达到需求，可是若在复制档案过程中要显示进度及取消复制，就需要使用 API 函数 CopyFileEx 来处理。下列范例程序使用 CoypFileEx 来进行复制档案，复制过程序会显示进度，按下「取消复制」钮可中断复制动作。

Cavan2022

复制文件的方法有很多种，在这里我提供一种给大家使用，有需要的可以拿去试，但结果我就不做保证，需不需要看你！
在复制大型文件比较有用，可以显示进度，我用了API的CopyFileEx，如果你用CopyFile就只能等，CopyFileEx提供了一个回调函数功能，可以使用AddressOf到模块回调函数，这个就不说了，我在这里提供的类模块回调，不需要模块。具体代码如下：
类模块中：
Option Base 0
Option Explicit

'***********************************************************************
'自定义事件
Public Event FileCopyExBegin()
Public Event FileCopyExProgress(ByVal Progress As Long, ByRef Cancel As Boolean)
Public Event FileCopyExCancel()

'***********************************************************************
'分配内存API
Private Const HEAP_ZERO_MEMORY = &H8
Private Const PAGE_EXECUTE_READWRITE = &H40

Private Declare Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function IsBadReadPtr Lib "Kernel32" (Destination As Any, ByVal Length As Long) As Long
Private Declare Function GetProcessHeap Lib "Kernel32" () As Long
Private Declare Function HeapAlloc Lib "Kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "Kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
Private Declare Function VirtualProtect Lib "Kernel32" (lpAddress As Any, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long

'************************************************************************
'复制文件API
Private Const COPY_FILE_FAIL_IF_EXISTS = &H1
Private Const COPY_FILE_RESTARTABLE = &H2

Private Const CALLBACK_STREAM_SWITCH = 1

Private Const PROGRESS_CONTINUE = 0
Private Const PROGRESS_CANCEL = 1
Private Const PROGRESS_STOP = 2
Private Const PROGRESS_QUIET = 3

Private Declare Function CopyFileExA Lib "Kernel32" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal lpProgressRoutine As Long, lpData As Any, ByVal pbCancel As Long, ByVal dwCopyFlags As Long) As Long

'*************************************************************************
'自定义类型
Private Type CopyFileExInfo
  CallBackPtr As Long
  CopyCancel As Boolean
  CopyFlags As Long
  CopyProgress As Long
End Type

Private Const CallBack_FileCopyEx = 3
Private FileCopyExInfo As CopyFileExInfo

'***************************************************************************
'IsOverWrite:如果文件存在是否覆盖源文件
Public Function FileCopyEx(ByVal SourPath As String, ByVal DestPath As String, Optional ByVal IsOverWrite As Boolean = False) As Boolean
  With FileCopyExInfo
    .CopyProgress = 0
    .CopyCancel = False
    .CallBackPtr = GetFileCopyExCallBackPtr(CallBack_FileCopyEx) '回调函数指针
    .CopyFlags = COPY_FILE_RESTARTABLE
    If Not IsOverWrite Then .CopyFlags = .CopyFlags Or COPY_FILE_FAIL_IF_EXISTS
    FileCopyEx = CBool(CopyFileExA(SourPath, DestPath, .CallBackPtr, ByVal 0&, VarPtr(.CopyCancel), .CopyFlags))
    If .CallBackPtr <> 0 Then
      Call HeapFree(GetProcessHeap, 0, ByVal .CallBackPtr)
      .CallBackPtr = 0
    End If
  End With
End Function

'***************************************************************************
'获取回调函数指针
Private Function GetFileCopyExCallBackPtr(ByVal FunctionCount As Long) As Long
  Dim FunctionPtr As Long
  Call CopyMemory(FunctionPtr, ByVal ObjPtr(Me), 4)
  FunctionPtr = FunctionPtr + (FunctionCount - 1) * 4 + &H1C
  If CBool(IsBadReadPtr(ByVal FunctionPtr, 4)) Then Exit Function
  Call CopyMemory(FunctionPtr, ByVal FunctionPtr, 4)
  If FunctionPtr = 0 Then Exit Function
  Dim AsmCode(18) As Long
  AsmCode(0) = &H83EC8B55:  AsmCode(1) = &H75FF08EC
  AsmCode(2) = &H3475FF38:  AsmCode(3) = &HFF3075FF
  AsmCode(4) = &H75FF2C75:  AsmCode(5) = &H2475FF28
  AsmCode(6) = &HFF2075FF:  AsmCode(7) = &H75FF1C75
  AsmCode(8) = &H1475FF18:  AsmCode(9) = &HFF1075FF
  AsmCode(10) = &H75FF0C75: AsmCode(11) = &HFC75FF08
  AsmCode(12) = &H50F8458D: AsmCode(13) = &H100068
  AsmCode(14) = &H2000B800: AsmCode(15) = &HC08B0000
  AsmCode(16) = &H458BD0FF: AsmCode(17) = &H34C2C9F8
  Call CopyMemory(ByVal VarPtr(AsmCode(13)) + 1, ObjPtr(Me), 4)
  Call CopyMemory(ByVal VarPtr(AsmCode(14)) + 2, FunctionPtr, 4)
  Dim Length As Long
  Length = (UBound(AsmCode) + 1) * 4
  GetFileCopyExCallBackPtr = HeapAlloc(GetProcessHeap, HEAP_ZERO_MEMORY, Length)
  If GetFileCopyExCallBackPtr = 0 Then Exit Function
  Call VirtualProtect(ByVal GetFileCopyExCallBackPtr, Length, PAGE_EXECUTE_READWRITE, 0&)
  Call CopyMemory(ByVal GetFileCopyExCallBackPtr, AsmCode(0), Length)
End Function

'***************************************************************************
'回调函数：CopyProgressRoutine
'原本的回调函数没有Result和EachBytesCopied参数，而且有返回值(Function)，具体可看MSDN
'改成Sub（Result为返回值，EachBytesCopy为每次复制的字节数，CopyFileEx触发回调函数的条件）
Private Sub CopyProgressRoutine(ByRef Result As Long, ByVal EachBytesCopied As Long, ByVal TotalFileSize As Currency, ByVal TotalBytesTransferred As Currency, ByVal StreamSize As Currency, ByVal StreamBytesTransferred As Currency, ByVal dwStreamNumber As Long, ByVal dwCallbackReason As Long, ByVal hSourceFile As Long, ByVal hDestinationFile As Long, ByVal lpData As Long)
  On Error Resume Next
  If dwCallbackReason = CALLBACK_STREAM_SWITCH Then
    RaiseEvent FileCopyExBegin
  End If
  DoEvents
  Dim CopyProgress As Long
  CopyProgress = (TotalBytesTransferred / TotalFileSize) * 100
  If FileCopyExInfo.CopyProgress < CopyProgress Then
    RaiseEvent FileCopyExProgress(CopyProgress, FileCopyExInfo.CopyCancel)
    If FileCopyExInfo.CopyCancel Then
      RaiseEvent FileCopyExCancel
    End If
  End If
  FileCopyExInfo.CopyProgress = CopyProgress
  Result = PROGRESS_CONTINUE '也可以使用PROGRESS_CANCEL来取消
End Sub

窗体中：2个Command，1个Label
Option Explicit
Dim WithEvents iFile As IClsFile
Dim CancelCopy As Boolean

Private Sub Command1_Click()
  Dim Path1 As String
  Dim Path2 As String
  Path1 = "E:\Test.avi" '源文件
  Path2 = "D:\Av.avi" '目标文件
  CancelCopy = False
  MsgBox iFile.FileCopyEx(Path1, Path2, True)
End Sub

Private Sub Command2_Click()
  CancelCopy = True
End Sub

Private Sub Form_Load()
  Set iFile = New IClsFile
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
  Set iFile = Nothing
End Sub

Private Sub iFile_FileCopyExBegin()
  MsgBox "iFile_FileCopyExBegin"
End Sub

Private Sub iFile_FileCopyExCancel()
  MsgBox "iFile_FileCopyExCancel"
End Sub

Private Sub iFile_FileCopyExProgress(ByVal Progress As Long, Cancel As Boolean)
  Label1.Caption = "已复制:" & Progress & "%"
  Cancel = CancelCopy
End Sub

Yalishanda30

SHFileOperation API也可以的

ykcbf1100

Yalishanda30 发表于 2023-6-15 09:03
SHFileOperation API也可以的

你这个64位的有吗？

Yalishanda30

ykcbf1100 发表于 2023-6-15 09:18
你这个64位的有吗？

公司excel是32位的，不知道是不是把API用ptrsafe标记一下就可以了

ykcbf1100

Yalishanda30 发表于 2023-6-15 09:24
公司excel是32位的，不知道是不是把API用ptrsafe标记一下就可以了

使用时源文件和目标文件都是全路径吗？

Cavan2022

显示进度条的,标题写的不准确

Yalishanda30

ykcbf1100 发表于 2023-6-15 09:30
使用时源文件和目标文件都是全路径吗？

可以复制文件夹，也可以复制单个文件，如果复制文件夹，(源文件夹路径,目标文件夹路径)
如果复制单个文件，(源文件路径,目标文件路径)
都需要全路径，操作和鼠标点击复制，再粘贴是类似的，只是用代码代替了鼠标选择文件/文件夹还有路径

Cavan2022

一下代码可以在VS上运行,哪位高手改成VBA的,在Excel上运行,谢谢!

1. Imports System.Runtime.InteropServices
   
2. 
   
3. Public Class Form1
   
4.     Private pbCancel As Int32
   
5. 
   
6.     <DllImport("kernel32.dll", CharSet:=CharSet.Auto)> _
   
7.     Private Shared Function CopyFileEx( _
   
8.         ByVal lpExistingFileName As String, _
   
9.         ByVal lpNewFileName As String, _
   
10.         ByVal lpProgressRoutine As CopyProgressRoutine, _
    
11.         ByVal lpData As IntPtr, _
    
12.         ByRef pbCancel As Int32, _
    
13.         ByVal dwCopyFlags As ECopyFileFlags) As Boolean
    
14.     End Function
    
15. 
    
16.     ''' <summary>
    
17.     ''' 執行 CopyFileEx 方法的回呼函式定義。
    
18.     ''' </summary>
    
19.     Delegate Function CopyProgressRoutine( _
    
20.         ByVal TotalFileSize As Long, _
    
21.         ByVal TotalBytesTransferred As Long, _
    
22.         ByVal StreamSize As Long, _
    
23.         ByVal StreamBytesTransferred As Long, _
    
24.         ByVal dwStreamNumber As UInteger, _
    
25.         ByVal dwCallbackReason As ECopyProgressCallbackReason, _
    
26.         ByVal hSourceFile As IntPtr, _
    
27.         ByVal hDestinationFile As IntPtr, _
    
28.         ByVal lpData As IntPtr) As ECopyProgressResult
    
29. 
    
30.     ''' <summary>
    
31.     ''' 執行 CopyFileEx 的回呼函式的回傳列舉。
    
32.     ''' </summary>
    
33.     Enum ECopyProgressResult As UInteger
    
34.         PROGRESS_CONTINUE = 0
    
35.         PROGRESS_CANCEL = 1
    
36.         PROGRESS_STOP = 2
    
37.         PROGRESS_QUIET = 3
    
38.     End Enum
    
39. 
    
40.     Enum ECopyProgressCallbackReason As UInteger
    
41.         CALLBACK_CHUNK_FINISHED = 0
    
42.         CALLBACK_STREAM_SWITCH = 1
    
43.     End Enum
    
44. 
    
45.     <Flags()> _
    
46.     Enum ECopyFileFlags As UInteger
    
47.         COPY_FILE_FAIL_IF_EXISTS = 1
    
48.         COPY_FILE_RESTARTABLE = 2
    
49.         COPY_FILE_OPEN_SOURCE_FOR_WRITE = 4
    
50.         COPY_FILE_ALLOW_DECRYPTED_DESTINATION = 8
    
51.     End Enum
    
52. 
    
53.     Private Function XCopy(ByVal oldFile As String, ByVal newFile As String) As Boolean
    
54.         Return CopyFileEx(oldFile, newFile, New CopyProgressRoutine(AddressOf Me.CopyProgressHandler), IntPtr.Zero, pbCancel, ECopyFileFlags.COPY_FILE_RESTARTABLE)
    
55.     End Function
    
56. 
    
57.     Private Function CopyProgressHandler(ByVal total As Long, ByVal transferred As Long, ByVal streamSize As Long, ByVal StreamByteTrans As Long, ByVal dwStreamNumber As UInteger, ByVal reason As ECopyProgressCallbackReason, _
    
58.      ByVal hSourceFile As IntPtr, ByVal hDestinationFile As IntPtr, ByVal lpData As IntPtr) As ECopyProgressResult
    
59.         Label1.Text = String.Format("進度: {0}%", CInt(transferred / total * 100))
    
60.         Application.DoEvents()
    
61. 
    
62.         Return ECopyProgressResult.PROGRESS_CONTINUE
    
63.     End Function
    
64. 
    
65.     Private Sub btnCopy_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnCopy.Click
    
66.         If XCopy("C:\Source.avi", "D:\New.avi") Then
    
67.             MsgBox("複製成功")
    
68.         Else
    
69.             MsgBox("複製失敗")
    
70.         End If
    
71. 
    
72.     End Sub
    
73. 
    
74.     Private Sub btnCancel_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnCancel.Click
    
75.         pbCancel = 1
    
76.         Application.DoEvents()
    
77.     End Sub
    
78. End Class

复制代码