修改代码: API函数CopyFileEx -- 复制大文件显示进度的代码

Cavan2022

以下VB代码可以在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
    

复制代码

peter-chen

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function CopyFileEx Lib "kernel32" Alias "CopyFileExA" ( _
        ByVal lpExistingFileName As String, _
        ByVal lpNewFileName As String, _
        ByVal lpProgressRoutine As LongPtr, _
        ByVal lpData As LongPtr, _
        ByRef pbCancel As Long, _
        ByVal dwCopyFlags As Long) As LongPtr

    Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
    Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal hModule As LongPtr, ByVal lpProcName As String) As LongPtr
#Else
    Private Declare Function CopyFileEx Lib "kernel32" Alias "CopyFileExA" ( _
        ByVal lpExistingFileName As String, _
        ByVal lpNewFileName As String, _
        ByVal lpProgressRoutine As Long, _
        ByVal lpData As Long, _
        ByRef pbCancel As Long, _
        ByVal dwCopyFlags As Long) As Long

    Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
    Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
#End If

Private pbCancel As Long

Private Function XCopy(ByVal oldFile As String, ByVal newFile As String) As Boolean
    Dim hKernel32 As LongPtr
    Dim lpCopyFileEx As LongPtr
   
    hKernel32 = LoadLibrary("kernel32.dll")
    lpCopyFileEx = GetProcAddress(hKernel32, "CopyFileExA")
   
    XCopy = CopyFileEx(oldFile, newFile, lpCopyFileEx, 0&, pbCancel, 2)
End Function

Private Function CopyProgressHandler(ByVal total As Long, ByVal transferred As Long, ByVal streamSize As Long, ByVal StreamByteTrans As Long, ByVal dwStreamNumber As Long, ByVal reason As Long, _
     ByVal hSourceFile As Long, ByVal hDestinationFile As Long, ByVal lpData As Long) As Long
    Sheet1.Range("A1").Value = "进度: " & Format(transferred / total * 100, "0%")
    DoEvents
    CopyProgressHandler = 0
End Function

Sub btnCopy_Click()
    If XCopy("C:\Source.avi", "D:\New.avi") Then
        MsgBox "复制成功"
    Else
        MsgBox "复制失败"
    End If
End Sub

Sub btnCancel_Click()
    pbCancel = 1
    DoEvents
End Sub

Cavan2022

peter-chen 发表于 2023-6-22 12:36
Option Explicit

#If VBA7 Then

试了这段代码, 不行,问题如下:
1, A1单元格没有显示进度信息
2, 程序运行几秒钟后,闪退,目标处虽然存在源文件,但是打不开,提示文件出错

Cavan2022

有会的老师吗?
分享一下,谢谢!!

zhw79

你前面发过1个帖子里的代码可以运行的，VB6和VBA