|
-
May 24th, 2016, 02:06 PM
#11
Re: VB6 Threading-Examples using the vbRichClient5 ThreadHandler
Added a third example (AsyncFolderCopy) into the Demo-Zip of the Opener-Posting.
The Demo-GUI is relatively simple (sporting only Progress-Event-Handling in the Form.Caption and Start/Cancel-Buttons):

The implementation-code that's needed in the cCopyThread-Class of the ThreadLib-ActiveX-Dll can be considered requiring "average skills",
and thus sitting somewhere between the other two example-Folders of the Demo-Zip which can be labelled:
- "easy" (_Hello World) -
- and "advanced" (ThreadedDirScan)
Note, that as with all other examples - the ThreadLib-ActiveX-Dll-Project needs to be compiled first into the Folder where the GUI-VB6-Project resides.
Code:
Option Explicit
'two Event-Naming-Conventions, for communication with the vbRichClients hidden cThreadProxy-Class (not reaching the clients, when raised)
Event CancelCheck(Cancel As Boolean) 'ask the hosting cThreadProxy, whether a client demanded Job-Cancelling
Event GetFactory(Factory As cFactory) 'ask the cThreadProxy, to deliver a RichClient-Factory-Instance regfree (not used here in this Demo)
'Userdefined-Event
Event Progress(ByVal Percent As Double, ByVal ProgrFileSizeInSrc As Currency, ByVal TotalFileSizeInSrc As Currency)
Private F As cFactory, New_c As cConstructor 'RC5-lib-related Constructor-Variables
Private mProgrFileSizeInSrc As Currency, mTotalFileSizeInSrc As Currency, mCancelled As Boolean 'Class-internal Helper-variables
Public Function CopyFolderTo(ByVal DstFolder As String, ByVal SrcFolder As String, Optional ByVal ApplyFileAttributesToDst As Boolean, Optional ByVal Filter As String, Optional ByVal Level As Long) As String
On Error Resume Next 'we use "in-place-errorhandling" here, and accumulate the Errors in the return-value of this function (if there are any)
If Level = 0 Then 'init (reset) the Private Variables, when we start a new "deep-copy" (at root-recursion-level Zero)
If New_c Is Nothing Then 'when the New_c-constructor is not yet initialized,
RaiseEvent GetFactory(F) 'retrieve a Factory over the built-in Event (to avoid specifying paths for regfree RC5-inits)
Set New_c = F.C 'init the New_c-constructor-variable from the Factory-Property
End If
mCancelled = False 'reset the Cancel-Flag
mProgrFileSizeInSrc = 0 'reset the Progress-FileSize
mTotalFileSizeInSrc = GetTotalFileSize(SrcFolder, Filter) 'get the Total-Size of all Files (over a recursive-scan)
End If
Dim DL As cDirList, i As Long
Set DL = New_c.FSO.GetDirList(SrcFolder, dlSortNone, Filter, True)
If Err Then CopyFolderTo = CopyFolderTo & Err.Description & vbCrLf: Err.Clear: Exit Function
New_c.FSO.EnsurePathEndSep DstFolder
If Not New_c.FSO.FolderExists(DstFolder) Then New_c.FSO.CreateDirectory DstFolder
If Err Then CopyFolderTo = CopyFolderTo & Err.Description & vbCrLf: Err.Clear: Exit Function
For i = 0 To DL.FilesCount - 1 'copy the files from the current directory chunkwise
CopyFileChunkWiseTo DstFolder & DL.FileName(i), DL.Path & DL.FileName(i)
If Err Then CopyFolderTo = CopyFolderTo & "Error copying: " & DL.Path & DL.FileName(i) & " " & Err.Description & vbCrLf: Err.Clear
If Cancelled Then Exit Function
If ApplyFileAttributesToDst Then New_c.FSO.SetFileAttributesEx DstFolder & DL.FileName(i), DL.FileAttributes(i) And Not (FA_READONLY Or FA_HIDDEN), _
DL.FileLastAccessTime(i), DL.FileLastWriteTime(i), DL.FileCreationTime(i)
If Err Then CopyFolderTo = CopyFolderTo & Err.Description & vbCrLf: Err.Clear
Next
For i = 0 To DL.SubDirsCount - 1 'recursions into Sub-Directories
CopyFolderTo = CopyFolderTo & CopyFolderTo(DstFolder & DL.SubDirName(i), DL.Path & DL.SubDirName(i), ApplyFileAttributesToDst, Filter, Level + 1)
If Cancelled Then Exit Function
If ApplyFileAttributesToDst Then New_c.FSO.SetFileAttributesEx DstFolder & DL.SubDirName(i), DL.SubDirAttributes(i) And Not (FA_READONLY Or FA_HIDDEN), _
DL.SubDirLastAccessTime(i), DL.SubDirLastWriteTime(i), DL.SubDirCreationTime(i)
If Err Then CopyFolderTo = CopyFolderTo & Err.Description & vbCrLf: Err.Clear
Next
If Level = 0 Then RaiseEvent Progress(1, mProgrFileSizeInSrc, mTotalFileSizeInSrc)
End Function
'Helper-Function, to determine the TotalSize (Sum of all Files in Bytes) of a given Directory (using a recursive scan)
Private Function GetTotalFileSize(ByVal SrcFolder As String, Optional ByVal Filter As String) As Currency
On Error Resume Next
Dim DL As cDirList
Set DL = New_c.FSO.GetDirList(SrcFolder, dlSortNone, Filter, True)
If Err = 0 Then GetTotalFileSize = GetTotalFileSize + DL.TotalFileSizeInDir
On Error GoTo 0
If Cancelled Then Exit Function
Dim i As Long
For i = 0 To DL.SubDirsCount - 1
GetTotalFileSize = GetTotalFileSize + GetTotalFileSize(DL.Path & DL.SubDirName(i))
If Cancelled Then Exit Function
Next
End Function
'Helper-Function, which performs a low-level, chunk-wise copying of a file (to be able to cancel early, even when larger files >2GB are copied)
Private Function CopyFileChunkWiseTo(DstFile As String, SrcFile As String) As String
Dim Src As cStream, Dst As cStream, BytesRead As Long
Set Src = New_c.FSO.OpenFileStream(SrcFile, STRM_READ Or STRM_SHARE_DENY_NONE)
Set Dst = New_c.FSO.CreateFileStream(DstFile, STRM_WRITE Or STRM_SHARE_DENY_NONE)
Const BufSize As Long = 4194304: Static Buf(0 To BufSize - 1) As Byte
Do Until Src.GetPosition = Src.GetSize
BytesRead = Src.ReadToPtr(VarPtr(Buf(0)), BufSize)
Dst.WriteFromPtr VarPtr(Buf(0)), BytesRead
mProgrFileSizeInSrc = mProgrFileSizeInSrc + BytesRead
Static T As Double, LastT As Double
T = New_c.HPTimer
If T - LastT > 0.2 Then 'ensure, that we don't raise ThreadEvents more than about 5 times per second
If Cancelled Then Exit Function
RaiseEvent Progress(mProgrFileSizeInSrc / mTotalFileSizeInSrc, mProgrFileSizeInSrc, mTotalFileSizeInSrc)
LastT = T
End If
Loop
End Function
Private Function Cancelled() As Boolean 'helper-function to signalize early exits in the Job-Procedures...
If Not mCancelled Then RaiseEvent CancelCheck(mCancelled) '...by raising the appropriate Helper-Event
Cancelled = mCancelled
End Function
Olaf
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|