Новый подход к многопоточности в Excel

Введение

Инструменты многопоточности существуют в Excel - часто для запуска макросов в нескольких экземплярах Excel или для преобразования макросов в vbscripts, которые могут выполняться независимо. Однако я часто сталкиваюсь с проектами, в которых я бы хотел делегировать несколько задач для асинхронных процессов, и создание нескольких экземпляров самого Excel слишком велико для этого.

После запуска нескольких проектов, где мне нужно было выполнить несколько асинхронных запросов (подумайте об очистке интернета или моделировании радиоактивного распада), я решил сделать общий класс, который при задании асинхронного процесса может выполнять и обрабатывать несколько параллельно.


Например, этот Daisy Test создает многопоточную группу, которая отправляет html-запросы ко всем URL-адресам в столбце B. Первая ссылка этих поисковых запросов Google возвращается в столбец C в порядке поступления ответов. Это вызывает вторую группу ( daisy clained на события 1-го) для отправки запроса интернет-исследователя на этот URL-адрес, и они возвращаются в D

 Пример реализации

Чтобы прояснить некоторые комментарии, следует отметить, что эти запросы отправляются в порядке (B1, B2, ...), но сначала верните неупорядоченный (C2). Это потому, что мой класс позволяет потокам работать в parallel (следовательно, multithreading). Они все еще управляются только в одиночном потоке Excel, но запросы асинхронны и в разных процессах , поэтому эффективно работают в других потоках.

Резюме

N.B. Термин «поток» будет использоваться здесь свободно, без ссылки на фактический процессор. Вместо этого, когда я говорю «поток», я говорю о обработчике задачи (которая выполняется параллельно с другими задачами других обработчиков)

Настройка многопоточного потока состоит из основного родительского класса clsMultiThread, который управляет формой многопоточной коллекции (то есть, сколько задач выполняется в любой момент времени), а также несколько классов clsThreadHandle.

Эти обработчики потоков отвечают за выполнение задачи async и информируют родительский многопоточный класс, когда каждая задача завершена.

Внутренне задачи фактически выполняются объектами WorkerClass, по одному работнику для каждого потока. Они получают входные аргументы из своих родительских потоков, запускают свою соответствующую задачу async и подготавливают событие к родительскому clsThreadHandle по завершении. Затем дескриптор потока передает это событие и любое необязательное возвращаемое значение обратно к основному clsMultiThread, чье задание - либо закрыть поток после его завершения, либо запросить поток для выполнения другой задачи. Цепочка команд суммируется на изображении ниже:

 Цепь команды

Обратная связь Я после

  • Общая обратная связь по структуре, обработке событий, использованию интерфейсов и т. д.
  • Хороший выход (который я не думаю, что я сейчас делаю)
  • Пользовательский интерфейс
    • Является ли этот подход к проблеме уместным и интуитивным (прохождение рабочих классов и т. д.).
    • Не хватает ли какой-либо функции, которая должна быть там

Это также первый проект, который я когда-либо делал, с целью сделать что-то, что я могу повторно использовать (а также самый длинный и самый сложный бит кода, который я написал). По этой причине я также очень благодарен за любые комментарии к

  • Стиль кодирования
  • Использование комментариев
  • Все, что я должен иметь в виду при работе над такими проектами

Реализация

Основной класс clsMultiThread

Правильно, какой-то код. Вот основной класс, которыйобрабатывает все подклассы

 Option Explicit

'''
'VBA class to run multiple asynchronous processes
'Interfaces directly with clsThreadHandle
'Requires references to:
'mscrolib.dll
'''

'THREAD GROUP SHAPE PROPERTIES
Private threadGroup As New Collection            'holds all the treads
Private maxThreads As Long                       'maximum number of threads that can be open
Private minThreads As Long                       '[minimum number of threads]
Private iterableQueue As mscorlib.Queue          'this item holds all the items from iterator set in queue
'replaces iterableGroup, newtaskindex, taskidset
Private iterableSize As Long                     'number of items in iterable group or
Private passesArguments As Boolean               'true if iterableGroup exists

'THREAD GROUP REFERENCES
Private WithEvents threadEvents As clsHandleEvents 'Event object to raise events from each thread handle
Private workerClass As IWorker

'THREAD GROUP SETTINGS
Private autoQuitEnabled As Boolean               'dictates whether to quit on Complete event, should be false if daisychaining

'THREAD GROUP STATE PROPERTIES
Private openThreadCount As Long                  'number of threads/handles currently open
Private openTaskCount As Long                    'number of tasks running on those threads
Private closedTaskCount As Long                  'number of threads closed (failed and successful)
Private successfulTaskCount As Long              'number of threads completed sucessfully
Private newThreadIndex As Long                   'Iterator over handles (next new handle)
Private newTaskIndex As Long                     'Iterator over open tasks (next thread to be started)
Private taskIDset As Collection                  'Dictionary mapping taskIDs to iterableGroup location "REPLACE THIS. MERGE COLLECTION JUMBLES"
Private freeThreads As Collection                'holds all the free thread ids

'THREAD GROUP PERFORMANCE PROPERTIES
Private startTime As Date
'Private endTime As Date

'THREAD GROUP EVENTS
Public Event TaskComplete(returnVal As Variant, taskID As String, threadID As String) 'when a task is complete on a thread, maybe if failed
Public Event ThreadOpened(threadCount As Long, threadID As String) 'when a thread is opened, pass the new number of threads
Public Event ThreadClosed(threadCount As Long, threadID As String) 'when closed, pass closed thread ID
Public Event Complete(timeTaken As Date)         'when everything is (nearly) finished
Public Event Closed(timeTaken As Date)           'when entire group is closed
Public Event Opened(startTime As Date)           'when entire group is closed

'PRIVATE TYPES/ENUMS
Private Type Instruction                         'instruction on what to do next, and any necessary arguments that can be passed
    threadID As String
    instructionBody As InstructionType
End Type

Private Enum InstructionType
    mltCloseThread
    mltOpenThread
    mltSetTask
    mltDoNothing
    mltQuit
End Enum

Private Sub Class_Initialize()
    'Set defaults
    maxThreads = 5
    minThreads = 1
    newThreadIndex = 1
    newTaskIndex = 1
    autoQuitEnabled = True
    Set threadEvents = New clsHandleEvents
    Set taskIDset = New Collection
    Set freeThreads = New Collection
    startTime = Now
    RaiseEvent Opened(startTime)
    '''
    'Test space
    '''
End Sub

Private Sub threadEvents_Closed(threadID As String)
    RaiseEvent ThreadClosed(openThreadCount, threadID)
End Sub

Private Sub threadEvents_Opened(threadID As String)
    RaiseEvent ThreadOpened(openThreadCount, threadID)
End Sub

Private Sub threadEvents_Complete(obj As clsThreadHandle, returnVal As Variant) 'called when thread becomes free
    'DO NOT mark as free here
    RaiseEvent TaskComplete(returnVal, obj.Task, obj.Name) 'failed as boolean
    openTaskCount = openTaskCount - 1
    closedTaskCount = closedTaskCount + 1
    successfulTaskCount = successfulTaskCount + 1 'could be unsuccessful too though
    doInstructions obj.Name                      'pass object name so it can be marked free
    '    If failed Then
    '        failedTaskCount = failedTaskCount + 1
    '    Else
    '        successfulTaskCount = successfulTaskCount + 1
    '    End If
End Sub

Public Sub Execute()
    'check validity of user data, if valid, then execute task
    If iterableSize = 0 Then
        Err.Raise 5, Description:="You must set size argument to a non-zero value, or a non-empty iterable first"
    ElseIf workerClass Is Nothing Then
        Err.Raise 5, Description:="You must set the async class argument first"
    Else
        doInstructions
    End If
End Sub

Public Sub Quit()
    'Remove any references that would prevent proper closing
    'Default automatically called when openThreadCount = 0
    RaiseEvent Complete(Now - startTime)
    Set threadEvents = Nothing
End Sub

Private Sub doInstructions(Optional freeThreadID As String, Optional loopcount As Long = 1)
    Dim instructionVal As Instruction

    'mark thread free if applicable
    If freeThreadID <> vbNullString Then freeThread = freeThreadID

    'find out what to do
    instructionVal = getInstruction()
    'carry out instruction
    Select Case instructionVal.instructionBody
    Case InstructionType.mltCloseThread
        closeThread instructionVal.threadID
    Case InstructionType.mltOpenThread
        openThread
    Case InstructionType.mltSetTask
        Dim taskThread As clsThreadHandle
        Dim taskArguments As Variant
        Set taskThread = threadGroup(instructionVal.threadID)
        'assign task to thread
        assignTaskID (taskThread.Name)
        'get any arguments there may be
        'mark thread as busy

        BusyThread = taskThread.Name
        'iterate open tasks
        openTaskCount = openTaskCount + 1
        'execute task
        If passesArguments Then
            'pop appropriate item from queue
            Set taskArguments = iterableQueue.Dequeue
            taskThread.Execute taskArguments
        Else
            taskThread.Execute
        End If

    Case InstructionType.mltQuit
        'quit then do nothing
        Me.Quit
        instructionVal.instructionBody = mltDoNothing
    Case InstructionType.mltDoNothing
        'do nothing
    Case Else
        Err.Raise 5                              'invalid argument
    End Select

    'call self until no instruction
    If instructionVal.instructionBody <> mltDoNothing Then
Debug.Assert loopcount < maxThreads * 3 + 5      'max loop should be open all threads then run all tasks + a little
        doInstructions loopcount:=loopcount + 1  'watch for infinite loop
    End If

End Sub

Private Function getInstruction() As Instruction
    'function to determine what action to take next
    'called until do nothing returned
    'caller to doinstructions can specify a free thread in which case some parts skipped
    Dim results As Instruction                   'variable to hold instruction and any arguments

    Me.printState

    'Do we need to open or close threads?
    'Threads free? (threads open > tasks open):
    If openThreadCount > openTaskCount Then
        'Great we have a free thread, now use it or delete it (cos we have too many or no tasks remaining)
        If newTaskIndex > iterableSize Then      'already passed all tasks
            '[find] & close free thread
            results.instructionBody = mltCloseThread
            results.threadID = freeThread
        ElseIf openThreadCount <= maxThreads Then
            '[find] & use free thread (run a task on it)
            results.instructionBody = mltSetTask
            results.threadID = freeThread
        Else
            '[find] & close free thread
            results.instructionBody = mltCloseThread
            results.threadID = freeThread
        End If
    Else
        'No threads free, either open one (if not exceeding max, and there's a task left to put on it)
        'Or do nothing (can't close it if not free, shouldn't open new if no more tasks)
        If openThreadCount < maxThreads And newTaskIndex <= iterableSize Then
            results.instructionBody = mltOpenThread
        ElseIf openThreadCount = 0 And autoQuitEnabled Then
            results.instructionBody = mltQuit
        Else
            results.instructionBody = mltDoNothing
        End If
    End If

    getInstruction = results
End Function

Private Sub openThread()
    'opens a thread and assigns a task ID to it
    Dim newThread As New clsThreadHandle         'create new handle
    newThread.OpenHandle Me, threadEvents        'passes parent reference which allows handle to obtain thread ID
    threadGroup.Add newThread, newThread.Name    'add it to the group with a new id (set by itself)
    openThreadCount = openThreadCount + 1
    freeThread = newThread.Name                  'mark as free so task can be assigned to it

End Sub

Private Property Let freeThread(threadID As String)
    'NOT WORKING"""""
    'when a thread comes free, add it to the collection
    freeThreads.Add threadID, threadID
Debug.Print threadID; " marked as free; now"; freeThreads.Count; "threads are free"
End Property

Private Property Let BusyThread(threadID As String)
    'when a thread is not free or is closed, mark as busy by removing from free group
    On Error Resume Next                         'only remove ones what are there actually
    freeThreads.Remove threadID
Debug.Print threadID; " marked as busy"; IIf(Err.Number <> 0, ", but wasn't in free group", vbNullString)
End Property

Private Property Get freeThread() As String
    'gives up a free thread and adds it to the list
    freeThread = freeThreads(1)
    freeThreads.Remove (1)
End Property

Private Sub assignTaskID(threadID As String)
    '@Ignore WriteOnlyProperty
    'assigns task ID to thread
    'nb does NOT actually run the task (this is instruction stage still)
    Dim newThread As clsThreadHandle
    Set newThread = threadGroup(threadID)
    newThread.Task = NewTaskID
    Set newThread.Worker = AsyncClass
End Sub

Private Sub closeThread(threadID As String, Optional failed As Boolean = False)

    'close thread with appropriate id
    Dim oldThread As clsThreadHandle
    Set oldThread = threadGroup(threadID)
    'remove from all collections
    'taskIDset.Remove oldThread.Task remove from task id set if it was in there
    threadGroup.Remove oldThread.Name
    BusyThread = oldThread.Name                  'remove from free collection
    Set oldThread = Nothing
    'iterate counters
    openThreadCount = openThreadCount - 1
End Sub

Public Property Let Size(sizeFactor As Variant)
    'property of the thread group which dictates how many processes to run in total
    'size factor is either an iterable item, or an integer to dictate the size

    'Check if size factor is number
    If IsNumeric(sizeFactor) Then
        'If so, size is that
        iterableSize = CLng(sizeFactor)
        passesArguments = False                  'no argument to pass to thread, just run it a load of times

        'If not, *check if iterable
    ElseIf isIterable(sizeFactor) Then
        'If so, size is size of collection from extration
        Set iterableQueue = New Queue
        iterableSize = addIterableToQueue(sizeFactor, iterableQueue)
        passesArguments = True
    Else
        '[if not, raise error]
        Err.Raise 5                              'invalid argument
    End If

End Property

Public Sub IncreaseSize(sizeFactor As Variant)
    'method of threadGroup which adds more tasks to the queue, and immediately runs them
    'size factor is either an iterable item, or an integer to dictate the size

    'Check whether size is set yet
    If Me.Size = 0 Then
        Err.Raise 5, Description:="You must set Size before you can IncreaseSize"
    End If

    'check whether new data matches old type
    If IsNumeric(sizeFactor) Then
        If passesArguments Then
            Err.Raise 5, Description:="Size factor type doesn't match original type"
        Else
            'is numeric and was numeric, grand
            iterableSize = iterableSize + CLng(sizeFactor)
        End If
    ElseIf isIterable(sizeFactor) Then
        If passesArguments Then
            'was iterable and still is, great!
            Dim itemsAdded As Long
            itemsAdded = addIterableToQueue(sizeFactor, iterableQueue)
            iterableSize = iterableSize + itemsAdded
        Else
            'wasn't iterble, now is
            Err.Raise 5, Description:="Size factor type doesn't match original type"
        End If

    Else
        '[if not, raise error]
        Err.Raise 5                              'invalid argument
    End If
    Me.Execute
End Sub

Public Property Set AsyncClass(ByVal workObj As IWorker) 'Set the worker who carries out the tasks
    Set workerClass = workObj
End Property

Public Property Get AsyncClass() As IWorker
    Set AsyncClass = workerClass
End Property

Public Property Get Size() As Variant
    Size = iterableSize
End Property

Public Property Let autoQuit(ByVal value As Boolean)
    autoQuitEnabled = value
End Property

Public Property Get NewHandleID() As String
    NewHandleID = "Handle " & newThreadIndex
    newThreadIndex = newThreadIndex + 1          'use next one next time
End Property

Private Property Get NewTaskID() As String
    'generates new task, saves its ID to taskIDset, then bumps the task counter along one
    NewTaskID = "Task " & newTaskIndex
    taskIDset.Add newTaskIndex, NewTaskID        'add id to map
    newTaskIndex = newTaskIndex + 1
End Property

Private Sub Class_Terminate()
    'Set threadGroup = Nothing
Debug.Print "Terminating group"
    RaiseEvent Closed(Now - startTime)
End Sub

Public Sub printState()                          'for debugging
Debug.Print _
        "State:"; vbCrLf _
                  ; Space(5); "Threads open: "; openThreadCount; vbCrLf _
                  ; Space(5); "Threads in use: "; openTaskCount; vbCrLf _
                  ; Space(5); "Threads marked as free: "; freeThreads.Count; vbCrLf _
                  ; Space(5); "Tasks remaining: "; iterableSize - successfulTaskCount; vbCrLf _
                  ; Space(5); "Next task index: "; newTaskIndex
End Sub

Его ключевыми методами являются doInstruction (вызов getInstruction) и Size и IncreaseSize

Класс выполняется итеративно; каждый цикл класс узнает, что делать и выполняет это (doInstruction). doInstruction всегда вызывает себя, если не сказано ничего не делать, что позволяет стеку вызовов сжиматься. Существует несколько вариантов того, что делать каждый цикл

  • Откройте поток (создайте новый экземпляр clsThreadHandle и добавьте в коллекцию возможных мест для запуска задач)
  • Закройте поток (закройте дескриптор и удалите его из этой коллекции)
  • Запустить задачу в потоке
  • [Force quit a task - t.b. реализован]
  • Ничего не делать (позвольте стеку вызовов вернуться к нулю)

Метод getInstruction сообщает классу

  • Откройте поток, если он не превышает максимальное количество, и если есть задачи для запуска на нем
  • Закройте поток, если нет задач, которые нужно выполнить, или если их слишком много
  • Запустите задачу в потоке, если есть поток, помеченный бесплатно
  • Не делайте ничего, если нет потоков, и есть нужное количество потоков.

Size - это то, что диктует количество задач для выполнения

  • Если Size является числовым, класс будет запускать задачи в потоках до тех пор, пока не будет запущено это количество задач
  • Если Size является итерабельным, тогда класс будет продолжать выполнять задачи и передавать аргументы по существу For...Each ing через итерируемый аргумент
    • Это позволяет передать что-то вроде URL-адреса в качестве аргумента длякаждой задачи или даже диапазона, чтобы работник знал, где на листе записать свой результат, чтобы

IncreaseSize похож на Size; полезно, если вы хотите выполнять задачи капать фид в многопоточном наборе (скажем, вы подключаете один на другой, используя первый threadComplete события). Он увеличивает размер аргумента numeric /iterable.

Рукоятки потоков clsThreadHandle

Основной класс создает несколько экземпляров этого класса дескриптора потока.

 Option Explicit


'THREAD HANDLE BASE PROPERTIES
Private eventHandle As clsHandleEvents           'Events module multithread set which handle belongs to. Called when handle state changes
Private taskID As String                         'holds the id of the current task
Private handleID As String                       'holds the id of this handle
Private handleArgs As Variant                    'holds any arguments that need to be passed to the task

'THREAD EVENTS
Private WithEvents workerEvents As IWorkerEvents
Private workerObject As IWorker                  'interface to whatever worker may be passed to thread


Private Sub workerEvents_Complete(returnVal As Variant)
    eventHandle.NotifyComplete Me, returnVal
End Sub

Private Sub workerEvents_Started()
Debug.Print Me.Task; " started event was raised"
End Sub

Public Property Set Worker(ByVal workObj As IWorker)
    Set workerObject = workObj.CreateNew         'set worker to be a copy of the passed one
    Set workerEvents = New IWorkerEvents         'create event handler
    Set workerObject.Events = workerEvents       'pass it to the worker so it can listen in
End Property

Public Sub OpenHandle(multiThreadGroup As clsMultiThread, delegate As clsHandleEvents)
    'called when the handle is opened, sets the reference IDs of the string and the handle, as well as parent g
    Set eventHandle = delegate
    handleID = multiThreadGroup.NewHandleID
    eventHandle.NotifyThreadOpened (Name)
Debug.Print Name; " was opened"
End Sub

Public Sub Execute(Optional args As Variant)
Debug.Print Task; " executed on "; Name; " with "; IIf(IsMissing(args), "no arguments", "some arguments")

    workerObject.Execute args                    'run the event
End Sub

Public Property Get Task() As String
    Task = taskID
End Property

Public Property Let Task(val As String)
    taskID = val
Debug.Print Name; "'s task was set to "; taskID
End Property

Public Property Get Name() As String
    Name = handleID
End Property

Private Sub Class_Initialize()
Debug.Print "I'm made"
End Sub

Private Sub Class_Terminate()
    eventHandle.NotifyThreadClosed (Me.Name)
    Set eventHandle = Nothing
    Set workerObject = Nothing
End Sub

Private Sub workerEvents_StatusChange(statusVal As Variant)
'not yet implemented, probably unnecessary
End Sub

Я выбрал отдельные обработчики событий, а не один (например, я сделал с clsHandleEvents), потому что

  • Я считаю, что для каждого объекта задачи /рабочего объекта индивидуальный класс потоков легче изображать мысленно.
  • Я намерен добавить функциональность, в которой рабочий может кэшировать объекты в своем родительском дескрипторе (например, приложение InternetExplorer), чтобы сохранить повторную инициализацию между последовательными задачами в одном потоке
    • Наличие одного кеша для каждого потока делает этот простой

Обработка классов событий clsHandleEvents

Ссылка на этот класс хранится в каждом потоке, чтобы он мог поднять событие в класс multiThread, без прямого ссылки на него (это, по-моему, испортило бы сборку мусора)

 Option Explicit
'class to convert calls from the thread handle into events which the multi thread group can tap into

Public Event Complete(obj As clsThreadHandle, returnVal As Variant)
Public Event Opened(threadID As String)          'when thread is actually opened
Public Event Closed(threadID As String)          'when thread is closed

Public Sub NotifyComplete(obj As clsThreadHandle, Optional returnVal As Variant)
    RaiseEvent Complete(obj, returnVal)
End Sub

Public Sub NotifyThreadOpened(threadID As String)
    RaiseEvent Opened(threadID)
End Sub

Public Sub NotifyThreadClosed(threadID As String)
    RaiseEvent Closed(threadID)
End Sub

Private Sub Class_Terminate()
Debug.Print "Events Terminated"
End Sub

Интерфейсы

Есть 2 interface классы (ну, только IWorker действительно один, но я вызываю IWorkerEvents) тоже, аналогично этот пример )

IWorker формирует общий шаблон асинхронного процесса, который вы можете запустить, что повышает соответствующие события в соответствии с IWorkerEvents

IWorker

 Option Explicit

'class acts as interface for any thread task
'Execute runs the task
'Events are raised by the task if it interfaces properly

Public Property Set Events(ByRef value As IWorkerEvents)
End Property

Public Sub Execute(Optional argument As Variant)
End Sub

Public Function CreateNew() As IWorker
End Function

IWorkerEvents

 Option Explicit

'class holds all the events that a thread task can raise

Public Event Complete(returnVal As Variant)
Public Event StatusChange(statusVal As Variant)
Public Event Started()

Public Sub Complete(Optional returnVal As Variant)
    RaiseEvent Complete(returnVal)
End Sub

Public Sub StatusChange(statusVal As Variant)
    RaiseEvent StatusChange(statusVal)
End Sub

Public Sub Started()
    RaiseEvent Started
End Sub

Наконец-то ...

Существует модуль дополнительных функций, который мне особенно не нужен, но я буду включать, как это требуется для clsMultiThread для выполнения

 Option Explicit

Public Function addIterableToQueue(iterator As Variant, ByRef resultQueue As Queue) As Long
    'function to take iterable group and add it to the queue
    'returns the number of items added
    Dim item As Variant
    Dim itemsAdded As Long
    itemsAdded = 0
    For Each item In iterator
        resultQueue.enqueue item
        itemsAdded = itemsAdded + 1
    Next item
    addIterableToQueue = itemsAdded
End Function

Function isIterable(obj As Variant) As Boolean
    On Error Resume Next
    Dim iterator As Variant
    For Each iterator In obj
        Exit For
    Next
    isIterable = Err.Number = 0
End Function

Тестовый код

Не нужно обращать внимание на этот материал, кроме как в отношении того, как реализован worker Загрузите пример файла здесь

Мне просто пришло в голову, что на самом деле я не включил работника для проверки этого. Ну вот пример, который использует запрос MSHTML для возврата HTML-документа с веб-страницы. Он принимает аргумент String /Range, представляющий URL-адрес, и возвращает HTMLDocument. NB, это должно быть imported, поскольку для этого требуется Attribute .VB_UserMemId = 0 как в этой статье

 VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "clsHtmlWorker"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'''
'Basic worker object sends MSHTML GET request to webpage and returns an HTMLDocument or Nothing
'Requires reference to
' Microsoft HTML Object library (mshtml.tlb)
' Microsoft XML, v6.0 (msxml6.dll)
'''

Private httpRequest As MSXML2.XMLHTTP60

Implements IWorker

Private Type TWorker
    Events As IWorkerEvents
End Type

Private this As TWorker

Private Function IWorker_CreateNew() As IWorker
    Set IWorker_CreateNew = New clsHtmlWorker
End Function

Private Property Set IWorker_Events(RHS As IWorkerEvents)
    Set this.Events = RHS
End Property

Private Sub IWorker_Execute(Optional argument As Variant)
    Started                                      'raise event to thread handle
    'Do some task
    sendRequest argument
End Sub

'''
'Event raising
'''

Private Sub Started()
    If Not this.Events Is Nothing Then
        this.Events.Started
    End If
End Sub

Private Sub statusChange(ByVal statusText As String)
    If Not this.Events Is Nothing Then
        'status change is not fully implemented yet in clsMultiThread, I may get rid of it
        this.Events.statusChange statusText
    End If
End Sub

Private Sub Complete(Optional ByVal resultPage As HTMLDocument)
    If Not httpRequest Is Nothing Then Set httpRequest = Nothing
    If Not this.Events Is Nothing Then
        this.Events.Complete resultPage
    End If
End Sub

Private Sub sendRequest(ByVal url As String)
    '''
    'Sub to open a new XMLHTTP request at a given url
    'Also assigns OnReadyStateChange callback function to this class' default routine
    '''

    If httpRequest Is Nothing Then Set httpRequest = New MSXML2.XMLHTTP60

    With httpRequest
        'Assign callback function to handler class (by default property)
        .OnReadyStateChange = Me
        'open and send the request
        .Open "GET", url, True
        .send vbNullString
    End With

End Sub

Public Sub OnReadyStateChange()
Attribute OnReadyStateChange.VB_UserMemId = 0
    '''
    'This is the default callback routine of the class
    '''
    With httpRequest

        statusChange .statusText

        If .ReadyState = 4 Then                  'loaded
            If .Status = 200 Then                'successful
                'mark complete and pass document
                Dim htmlDoc As HTMLDocument
                Set htmlDoc = New HTMLDocument
                htmlDoc.body.innerHTML = .responseText
                Complete htmlDoc
            Else                                 'unsuccessful
                Complete
            End If
        End If
    End With
End Sub

Private Sub Class_Terminate()
    If Not httpRequest Is Nothing Then Set httpRequest = Nothing
End Sub

Многопоточная группа, реализующая его, может быть запущена в классе вызывающего абонента, например codeReviewTest. Отправляет запросы на URL-адреса в A1:A10, возвращает электронные письма из этих URL-адресов в соседних столбцах.

 Option Explicit

'''
'This class creates and runs a new multithread instance which runs clsHtmlWorker
'When each HTMLDocument is complete, the class scans it for e-mails
'''
Private WithEvents multiThreadGroup As clsMultiThread
'clsMultiThread is async so must be  declared separately (or in a doEvents loop)
Private Const REGEX_PATTERN As String = _
"(?:[a-z0-9!#$%&'*+/=?^_`{|}~-]+(?:\.[a-z0-9!#$%&'*+/=?^_`{|}~-]+)*|""(?:[\x01-\x08\x0b\x0c\x0e-\x1f\x21\x23-\x5b\x5d-\x7f]|\\[\x01-\x09\x0b\x0c\x0e-\x7f])*"")@(?:(?:[a-z0-9](?:[a-z0-9-]*[a-z0-9])?\.)+[a-z0-9](?:[a-z0-9-]*[a-z0-9])?|\[(?:(?:(2(5[0-5]|[0-4])|1[0-9]|[0-9]?[0-9]))\.){3}(?:(2(5[1-9]|[0-9])|1[0-5]|[0-4]?[0-9])|[0-9]*[0-9]:(?:[1-9]|\\[0-9])+)\])"

Public Sub run()
    'urls to check for emails are in a1:a10
    htmlRequestToUrls [a1:a10]
End Sub

Private Sub htmlRequestToUrls(urlCells As Range)

    Set multiThreadGroup = New clsMultiThread
    With multiThreadGroup
        .Size = urlCells                         'set iterable, here a load of urls
        Set .AsyncClass = New clsHtmlWorker      'set async worker
        .Execute                                 'run the group
    End With

End Sub

Private Sub multiThreadGroup_TaskComplete(returnVal As Variant, taskID As String, threadID As String)

    Dim rowI As Long, colI As Long
    rowI = Right(taskID, Len(taskID) - 4)

    If returnVal Is Nothing Then
        Cells(rowI, 2) = "Error in loading page"
    ElseIf TypeOf returnVal Is HTMLDocument Then
        Dim emailMatches() As String
        emailMatches = regexMatches(returnVal.body.innerText)
        If (Not emailMatches) = -1 Then
        'no emails on page
            Cells(rowI, 2) = "No e-mail matches"
        Else
            For colI = LBound(emailMatches) To UBound(emailMatches)
                Cells(rowI, colI + 2) = emailMatches(colI)
            Next colI
        End If
    Else                                         'nothing returned
        Cells(rowI, 2) = "Error in loading page"
    End If


End Sub

Private Function regexMatches(strInput As String) As String()

    Dim rMatch As Object
    Dim s As String
    Dim arrayMatches() As String
    Dim i As Long

    With CreateObject("VBScript.Regexp")
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = REGEX_PATTERN
        If .test(strInput) Then
            For Each rMatch In .Execute(strInput)
                ReDim Preserve arrayMatches(i)
                arrayMatches(i) = rMatch.value
                i = i + 1
            Next
        End If
    End With

    regexMatches = arrayMatches

End Function

Класс test создаст новую группу с несколькими потоками. Группа откроет по умолчанию 5 потоков, в каждом потоке создаст экземпляр clsHtmlWorker. Он преобразует диапазон [A1:A10] в 10 аргументов, которые он будет передавать, по одному за раз, рабочим в каждом потоке, когда они не заняты. После запуска всех задач класс будет autoQuit - резать ссылки на все подкласс, позволяя ему выйти из области

Вы можете загрузить пример книги если хотите, лучше всего работает с Rubberduck для организации папок. Код проверки находится в CodeReviewTestRunner или просто нажмите большую кнопку

30 голосов | спросил Greedo 16 Jpm1000000pmTue, 16 Jan 2018 15:21:35 +030018 2018, 15:21:35

2 ответа


10

Интересная идея и хорошо сделано!

Нейминг

Мне действительно не нравятся имена. Такие имена, как clsMultiThread, несколько вводят в заблуждение, поскольку, как вы заметили, на самом деле они не предоставляют какой-либо истинной многопоточности. Неосторожный пользователь будет ожидать, что он будет работать с чем угодно и будет разочарован, когда все их работы в очереди больно завершатся синхронно. ;)

Кроме того, мы не используем потоки, но объекты, которые могут выполняться или не выполняться в процессе или нет. Вы использовали MSXML2.XMLHTTP60, поэтому он должен запускаться в процессе. Однако это не обязательно, если бы мы использовали что-то вроде ShDocVw.WebBrowser или даже Excel.Application, которое может закончиться вне процесса. Это не резьба. Таким образом, в этом случае мы фактически говорим о запуске асинхронно больше, чем потоки.

Могу я вместо этого предложить такие имена, как ParallelTaskCoordinator, TaskHandle и AsyncObjectWatcher? Дело в том, что оно должно передать представление о том, что эти объекты не имеют ничего общего с асинхронным ходом; мы просто организуем параллельные асинхронные задачи.

В комментариях вы спросили о венгерских обозначениях. Мои личные предпочтения - не использовать венгерскую нотацию для объектов, поэтому я бы не использовал префикс cls. О проблемах с пространством имен не будет помогать то, префикс или нет, в основном потому, что хорошее пространство имен связано с группировкой logical , в отличие от объединения их друг с другом в зависимости от их типа модулей. Я в порядке с использованием HN для частных переменных, а не столько для объектов с открытым доступом, как имя модуля, то публичное свойство, поскольку они просто отвлекают от их смыслового значения. Семантическая часть имени гораздо важнее, и хорошее соглашение об именах должно поддерживать это.

В общем, ваша схема именования кажется достаточно продуманной. Несогласованность, которую я вижу, заключается в том, что в методе Execute у вас есть delegate в качестве имени аргумента, который затем присваивается eventHandle. Почему бы не вызвать аргумент таким же образом, так что при написании метода Execute ясно, что это должно быть?

Не полностью асинхронный, может быть заблокирован основным потоком

Само по себе это работает. Однако я хочу обратить ваше внимание на то, что он не будет работать в более сложных сценариях. Вот пример, где это происходит:

Выполняется в ближайших окнах:

call runtest: for i = 0 to 100 : debug.Print i: doevents: next

В теории вывод Debug.Print i должен чередоваться с прогрессом других задач. На практике я последовательно выполняю 5 заданий, затем 100 с выведенного i, затем остальные 5 завершенных задач. Это говорит мне, что если основной поток позволяет делать что-то, пока выполняются задачи в других потоках, они будут заблокированы до тех пор, пока основной поток не станет холостым. Таким образом, легко уничтожить асинхронность, если вы не будете осторожны.

Как видите, даже опрыскивание DoEvents, по-видимому, недостаточно. Думая об этом, это не удивительно, потому что «события» происходят из того же кода VBA, который должен выполняться в потоке пользовательского интерфейса. Поэтому, если это становится проблемой, вы должны полностью делегировать асинхронно внешнему процессу /потоку (например, через внешнюю библиотеку), в котором вы можете передавать прогресс в код VBA через события, а не полагаться на внешний объект, чтобы возбуждать событие в рабочий, который должен поднять событие к дескриптору потока, а затем менеджеру.

Обратите внимание, что даже если вы пошли по этому маршруту, вам понадобится логика повтора, чтобы успешно поднять это событие, потому что запуск кода VBA может помешать входу. Существует возможность упустить мероприятие, особенно если есть высокий уровень активности и слишком много ресурсов. Это наблюдалось до здесь , здесь , здесь . Эти примеры иллюстрируют случай, когда что-то не всегда срабатывает так, как мы ожидаем.

Как указано в комментариях, изменение # максимальных потоков может работать лучше. Например, установив максимальные потоки на 2, мы увидим, что задача 1 и задача 2 завершатся до блокировки, чтобы напечатать i в течение 90 раз, тогда задача 3 разрешена для запуска, а затем завершения, прежде чем мы снова заблокируем в течение последних 10 раз, а остальные полные. Однако это очень непротиворечиво в моей системе. В 3 раза я запускал тест, задача 3 не начиналась до тех пор, пока 90 не напечатали, а остальные не запустились до 100. С другой стороны, если я устанавливаю maxthreads на 1, я получаю одну задачу законченной, а затем блокируюсь 100 раз, пока остальные задачи не будут разрешены. Я не ожидаю, что он будет легко воспроизводимым, поскольку на это повлияет множество факторов (аппаратное обеспечение, версия Windows, версия Excel). Это просто то, что нужно знать и явно конструировать для возможности.

Если для вас важно, чтобы вы не блокировались, вам нужно рассмотреть другой подход. Например, вам понадобится внешняя библиотека .NET, которая создает поток, запускает задачу, а затем записывает вывод в файл. Это позволяет основному потоку читать его на досуге, и ни один из порожденных нитей не будет случайно заблокирован, когда основной поток должен что-то сделать. Тем не менее, все еще зависит от того, что он может быть заблокирован при попытке создать новый поток (так как вам нужен VBA для запуска кода для его создания, даже если он просто вызывает внешнюю функцию в DLL).

Примечание: во всех моих тестах только Debug.Print были напечатаны Task N started и Task N completed и Events terminated. Я прокомментировал PrintState; в противном случае ближайшее окно будет переполняться, и я не могу видеть весь вывод от начала до конца.

WinHttp вместо MSXML

Кроме того, я хочу обратить ваше внимание на то, что вы могли бы иметь экземпляр WinHttp.WinHttpRequest, который поддерживает события изначально. Поэтому вы можете объявить переменную типа Private WithEvents request As WinHttp.WinHttpRequest и вместо этого прослушать событие. Это означает, что вам не нужно настраивать член по умолчанию, как вам нужно, с помощью MSXML, и если интернет-запрос - это все, что вы делаете, вам даже не нужна коллекция потоков; просто создайте коллекцию WinHttp.WinHttpRequest и послушайте их события.

Но это, очевидно, не общее решение, а использование WinHttp.WinHttpRequest не мешает нам использовать его с вышеупомянутым решением для случая, когда мы хотим, чтобы рабочий обрабатывал настройку.

Не переписывайте, если вам не нужно

У вас есть doInstructions, который вызывает себя рекурсивно. Но ИМПОВ, нет причин для рекурсии. Вы можете сделать то же самое с простым циклом, как показано с моими взломанными изменениями. Более правильным решением может быть использование нескольких условий или переменной флага в нижней части цикла (гарантируя, что он выполняется хотя бы один раз). Это гарантирует, что вам не нужно беспокоиться о переполнении стека.

Private Sub doInstructions(Optional freeThreadID As String, Optional loopcount As Long = 1)
    Dim instructionVal As Instruction

Do
    'mark thread free if applicable
    If freeThreadID <> vbNullString Then freeThread = freeThreadID

    'find out what to do
    instructionVal = getInstruction()
    'carry out instruction
    Select Case instructionVal.instructionBody
    Case InstructionType.mltCloseThread
        closeThread instructionVal.threadID
    Case InstructionType.mltOpenThread
        openThread
    Case InstructionType.mltSetTask
        Dim taskThread As clsThreadHandle
        Dim taskArguments As Variant
        Set taskThread = threadGroup(instructionVal.threadID)
        'assign task to thread
        assignTaskID (taskThread.Name)
        'get any arguments there may be
        'mark thread as busy

        BusyThread = taskThread.Name
        'iterate open tasks
        openTaskCount = openTaskCount + 1
        'execute task
        If passesArguments Then
            'pop appropriate item from queue
            Set taskArguments = iterableQueue.Dequeue
            taskThread.Execute taskArguments
        Else
            taskThread.Execute
        End If

    Case InstructionType.mltQuit
        'quit then do nothing
        Me.Quit
        instructionVal.instructionBody = mltDoNothing
    Case InstructionType.mltDoNothing
        'do nothing
    Case Else
        Err.Raise 5                              'invalid argument
    End Select

    'call self until no instruction
    If instructionVal.instructionBody <> mltDoNothing Then
Debug.Assert loopcount < maxThreads * 3 + 5      'max loop should be open all threads then run all tasks + a little
        'doInstructions loopcount:=loopcount + 1  'watch for infinite loop
        freeThreadID = vbNullString
        loopcount = loopcount + 1
    Else
        Exit Do
    End If
Loop

End Sub

Только один тип работника для класса менеджера

В образце мы имеем следующее:

Set .AsyncClass = New clsHtmlWorker

У меня создалось впечатление, что точка менеджера должна позволять нам создавать потоки для разных работников, каждый из которых выполняется асинхронно. По этой причине кажется странным, что я могу использовать AsyncClass, чтобы установить единую реализацию IWorker. Разве я не могу назначить кучу рабочих, а их собственные аргументы должны быть завербованы? Думаю, это было бы более интуитивное использование менеджера. Что-то вроде этого:

Set .AsyncObjectsToExecute = Array( _
  WorkerType1Factory.Create("some argument one"), _
  WorkerType1Factory.Create("another argument"), _
  WorkerType2Factory.Create("do that", 123, 495), _
  WorkerType2Factory.Create("but not that", 0, 0), _
  WorkerType3Factory.Create() _
)

Из этого мы можем, очевидно, посмотреть, какие задачи мы планируем выполнить, перейдя в заводы IWorker. Это не ограничивает нас только одним конкретным рабочим классом, и это помогает понять, какие аргументы мы отправляем для каждой задачи.

Инкапсулировать ваши личные поля как тип

Я бы предложил, чтобы вы взяли страницу из книги @ MathieuGuindon и использовали его метод:

```'THREAD HANDLE BASE PROPERTIES
Private Type THandle
    eventHandle As clsHandleEvents           'Events module multithread set which handle belongs to. Called when handle state changes
    taskID As String                         'holds the id of the current task
    handleID As String                       'holds the id of this handle
    handleArgs As Variant                    'holds any arguments that need to be passed to the task
End Type
Private this As THandle

Это дает вам intellisense полей класса, просто используя this. и тем самым помогая четко дифференцировать между закрытыми полями класса и открытыми свойствами. Это один из способов помочь неправильному коду выглядеть неправильно.

RaiseEvents в событии Initialize

Это кажется мне неприятным:

Private Sub Class_Initialize()
    RaiseEvent Opened(startTime)
End Sub

Мое личное правило для любой работы внутри событий Initialize и Terminate заключается в том, чтобы полностью изолировать код от класса. Как правило, нецелесообразнокласс, потому что он не закончил строить себя и как таковой, результаты могут быть непредсказуемыми. В этом случае эффект может быть доброкачественным, потому что мы только поднимаем событие с сообщенным параметром. Однако в более сложной реализации, которая может действовать неожиданными манерами. Кроме того, это действительно ничего нам не покупает, потому что, если был вызван Initialize, мы уже знаем об этом, поскольку мы обычно должны инициализировать его в первую очередь.

Вам действительно нужна очередь

Приятно, что вы используете .NET-очередь, чтобы помочь настроить аргументы. Однако это означает, что у вас есть дополнительная ссылка, и у вас уже есть несколько ссылок, что затрудняет распространение кода в другой среде.

Один из способов заключается в том, чтобы связать очередь позже, объявив ее как объект и сделав CreateObject("System.Collections.Queue"). Это позволяет избежать необходимости добавления явной ссылки на основную библиотеку .NET и, следовательно, быть агностиком в версии .NET framework, так как в этом случае класс не будет изменяться между версиями.

Альтернативой является просто использование встроенной коллекции VBA. IINM, вы используете только очереди, чтобы собирать аргументы, которые также могут делать преобразования VBA. Это даст вам поведение в очереди:

col.Add ...
col.Add ...
col.Add ...

Do Until col.Count = 0
  col.Remove 1
Loop

без каких-либо внешних ссылок.

Не используйте имена по умолчанию из интерфейса

Как указано в @Raystafarian, вы не должны принимать присвоение по умолчанию RHS при реализации интерфейса. Я ненавижу его лично и всегда меняю имя. Внедрение интерфейсов не означает care , какое имя вы используете. Единственное, о чем он заботится, это процедура с именем something (check), и она содержит N количество аргументов (check) и каждый аргумент имеет одинаковые данные тип (проверка). Он даже не рассматривает имена аргументов. Поэтому вы должны изменить их на нечто более разумное. Если вы чувствуете себя невообразимо, назовите их Value, что я обычно делаю. Только не оставляйте это как RHS.

ответил this 29 MaramThu, 29 Mar 2018 07:14:14 +03002018-03-29T07:14:14+03:0007 2018, 07:14:14
6

Это way выше моего опыта, но, возможно, добавление ответа вызовет больше просмотров /ответов? Кроме того, что там делает этот новичок? ;)

Я хочу сказать сначала, действительно солидную работу. Вероятно, поэтому здесь не было слишком много активности. Возможно, некоторые из них будут выглядеть как нит-кирки, и если да, извините!


Аргументы ByRef или ByVal

Каждый из аргументов, как вы, вероятно, знаете, не объявлены ByVal, неявно ByRef. Я предполагаю, что вам, вероятно, понадобится много таких, чтобы быть ByRef, но лучше явно объявить их ByRef, так что проще сказать, что это предполагается для ByRef.

параметр obj

clsHandleEvents.Complete(obj as clsThreadHandle)
clsHandleEvents.NotifyComplete(obj as clsThreadHandle)
clsMultiThread.threadEvents_Complete(obj as clsThreadHandle)
multiThreadMethods.isIterable(obj as Variant)

Первые три могут, вероятно, использовать новое имя, если они все одинаковы. Возможно threadObject или threadHandle - до вас.

Четвертый принимает вариант и возвращает логическое значение, его можно назвать чем-либо из testObject в iteratorGroup. Возможно, вам захочется попробовать переименовать некоторые из этих

Queue

clsMultiThread

Private iterableQueue As mscorlib.Queue 
Set iterableQueue = New Queue

multiThreadMethods

Public Function addIterableToQueue(iterator As Variant, ByRef resultQueue As Queue)

Возможно, я плотный, будучи парнем VBA, но как узнать, что такое queue и какие методы он использует? Это не стандартная справочная библиотека для VBA, не так ли? Вероятно, я добавлю комментарий, объясняющий why , который вы выбрали, чтобы сделать это таким образом, поэтому никто не должен был возвращаться через все это, чтобы понять, почему это лучше, чем каким-либо другим способом.

RHS?

clsHtmlWorker

Private Property Set IWorker_Events(RHS As IWorkerEvents)
    Set this.Events = RHS
End Property

Что такое RHS? Это постоянный, он во всех шапках. Я могу сказать, что вы знаете лучше, используя Html в своем проекте, а не HTML - так что это такое?


Все, что было сказано, я даже не могу понять, как это работает, когда я нахожу его, я вижу, куда нужно отправлять запросы (httpRequest), но я не могу понять, как они возвращаются и заполняются лист, я не вижу, что это происходит, что я думаю является точкой, будучи асинхронной?

ответил Raystafarian 15 FebruaryEurope/MoscowbThu, 15 Feb 2018 08:12:40 +0300000000amThu, 15 Feb 2018 08:12:40 +030018 2018, 08:12:40

Похожие вопросы

Популярные теги

security × 330linux × 316macos × 2827 × 268performance × 244command-line × 241sql-server × 235joomla-3.x × 222java × 189c++ × 186windows × 180cisco × 168bash × 158c# × 142gmail × 139arduino-uno × 139javascript × 134ssh × 133seo × 132mysql × 132