VBA中的多线程

Sub RunForVBA(workbookName As String, seqFrom As Long, seqTo As Long)
    For i = seqFrom To seqTo
        x = seqFrom / seqTo
    Next i
End Sub

Sub RunForVBAMultiThread()
    Dim parallelClass As Parallel 

    Set parallelClass = New Parallel 

    parallelClass.SetThreads 4 

    Call parallelClass.ParallelFor(\"RunForVBA\", 1, 1000) 
End Sub

Sub RunAsyncVBA(workbookName As String, seqFrom As Long, seqTo As Long)
    For i = seqFrom To seqTo
        x = seqFrom / seqTo
    Next i
End Sub

Sub RunForVBAAndWait()
    Dim parallelClass As Parallel

    Set parallelClass  = New Parallel

    Call parallelClass.ParallelAsyncInvoke(\"RunAsyncVBA\", ActiveWorkbook.Name, 1, 1000) 
    \'Do other operations here
    \'....

    parallelClass.AsyncThreadJoin 
End Sub

UserForm1.Show vbModeless

If i Mod 10000 = 0 Then
    UpdateProgressBar(i) \'code to update progress bar display
    DoEvents
End If

Public Sub RunFunctionAsync(FunctionName As String)
    Dim A As Access.Application
    Set A = New Access.Application
    A.OpenCurrentDatabase Application.CurrentProject.FullName
    A.DoCmd.OpenForm \"MultithreadingEngine\"
    With A.Forms(\"MultiThreadingEngine\")
        .TimerInterval = 10
        .AddToTaskCollection (FunctionName)
    End With
End Sub

Public TaskCollection As Collection

Public Sub AddToTaskCollection(str As String)
    If TaskCollection Is Nothing Then
        Set TaskCollection = New Collection
    End If
    TaskCollection.Add str
End Sub
Private Sub Form_Timer()
    If Not TaskCollection Is Nothing Then
        If TaskCollection.Count <> 0 Then
            Dim CollectionItem As Variant
            For Each CollectionItem In TaskCollection
                Run CollectionItem
            Next CollectionItem
        End If
    End If
    Application.Quit
End Sub

\'Create new thread and return reference to workbook of worker thread
Public Function openNewInstance(ByVal fileName As String, Optional ByVal openVisible As Boolean = True) As Workbook
    Dim newApp As New Excel.Application
    ThisWorkbook.SaveCopyAs ThisWorkbook.Path & \"\\\" & fileName
    If openVisible Then newApp.Visible = True
    Set openNewInstance = newApp.Workbooks.Open(ThisWorkbook.Path & \"\\\" & fileName, False, False) 
End Function

\'Start macro in other instance and wait for return (OnTime used in target macro)
Public Sub runMakroInOtherInstance(ByRef otherWkb As Workbook, ByVal strMakro As String, ParamArray var() As Variant)
    Dim makroName As String
    makroName = \"\'\" & otherWkb.Name & \"\'!\" & strMakro
    Select Case UBound(var)
        Case -1:
            otherWkb.Application.Run makroName
        Case 0:
            otherWkb.Application.Run makroName, var(0)
        Case 1:
            otherWkb.Application.Run makroName, var(0), var(1)
        Case 2:
            otherWkb.Application.Run makroName, var(0), var(1), var(2)
        Case 3:
            otherWkb.Application.Run makroName, var(0), var(1), var(2), var(3)
        Case 4:
            otherWkb.Application.Run makroName, var(0), var(1), var(2), var(3), var(4)
        Case 5:
            otherWkb.Application.Run makroName, var(0), var(1), var(2), var(3), var(4), var(5)
    End Select
End Sub

Public Sub SYNCH_OR_WAIT()
    On Error Resume Next
    While masterBlocked.Count > 0
        DoEvents
    Wend
    masterBlocked.Add \"BLOCKED\", ThisWorkbook.FullName
End Sub

Public Sub SYNCH_RELEASE()
    On Error Resume Next
    masterBlocked.Remove ThisWorkbook.FullName
End Sub

Sub runTaskParallel()
    ...
    Dim controllerWkb As Workbook
    Set controllerWkb = openNewInstance(\"controller.xlsm\")

    runMakroInOtherInstance controllerWkb, \"CONTROLLER_LIST_FILES\", ThisWorkbook, rootFold, masterBlocked
    ...
End Sub

Sub MultiProcessing_Principle()
    Dim k As Long, j As Long
    k = Environ(\"NUMBER_OF_PROCESSORS\")
    For j = 1 To k
        Shellm \"msaccess\", \"C:\\Autoexec.mdb\"
    Next
    DoCmd.Quit
End Sub

Private Sub Shellm(a As String, b As String) \' Shell modificirani
    Const sn As String = \"\"\"\"
    Const r As String = \"\"\" \"\"\"
    Shell sn & a & r & b & sn, vbMinimizedNoFocus
End Sub