スレッド処理

Option Explicit

' スレッドプロセスに参照させる変数・定数・関数はグローバル領域に宣言すること。

' イベントID
Const EVENT_END        = 0    ' スレッド停止
Const EVENT_MESSAGE    = 1    ' メッセージ表示
Const EVENT_DELAY_MSG  = 2    ' 遅延メッセージ表示
Const EVENT_ADD_THREAD = 3    ' スレッド追加

' その他定数
Const THREAD_VBS_FILE = "thread.vbs"    ' スレッド処理を行うVBSファイル
Const EXEC_WAIT_SEC   = 30          ' スレッド処理全体の待ち時間(秒)

Dim queue, execList, threadNum

Main
WScript.Quit

Sub Main

' 変数を初期化
  Set queue    = WScript.CreateObject("System.Collections.Queue")
    Set execList = WScript.CreateObject("Scripting.Dictionary")
  threadNum    = 0

' スレッドを作成
  createThread 1

' イベントを設定
  enqueueEvent queue, createEvent(EVENT_MESSAGE, "event1")
  enqueueEvent queue, createEvent(EVENT_DELAY_MSG, 2000)
  enqueueEvent queue, createEvent(EVENT_ADD_THREAD, 1)
  enqueueEvent queue, createEvent(EVENT_MESSAGE, "event2")
  enqueueEvent queue, createEvent(EVENT_MESSAGE, "event3")
  enqueueEvent queue, createEvent(EVENT_MESSAGE, "event4")
  enqueueEvent queue, createEvent(EVENT_MESSAGE, "event5")

' 処理終了まで待機
  Dim isComplete
  isComplete = waitComplete(EXEC_WAIT_SEC)
  If (Not isComplete) Then
    forceToTerminateThread
    MsgBox EXEC_WAIT_SEC & "秒経過しても完了しなかったため。強制終了しました。"
  End If

msgbox "全スレッド完了"
End Sub

' スレッドを作成
Sub createThread(num)
  Dim cntQueue, shell, ie, threadVbsPath, index, dummyObj

' オブジェクトを作成
  Set cntQueue = WScript.CreateObject("System.Collections.Queue")
  Set shell    = WScript.CreateObject("WScript.Shell")
  Set dummyObj = WScript.CreateObject("System.Object")
  Set ie = createIE()

' スレッド用VBSファイルのパスを取得
  threadVbsPath = WScript.CreateObject("WScript.Shell").CurrentDirectory & "\" & THREAD_VBS_FILE

' スレッド数だけカウントキューにオブジェクトを格納
  For index = 1 to num
    cntQueue.Enqueue dummyObj
  Next

' IEにスレッド間で共有する情報を格納
  With ie
    .PutProperty "threadManager", Me
    .PutProperty "cntQueue", cntQueue
  End With

' スレッド処理を行うプロセスを作成
  Dim wshExec
  For index = 1 to num
    Set wshExec = shell.exec("wscript " & threadVbsPath & " " & ie.HWND)
    execList.Add threadNum + index, wshExec
  Next

' 起動したプロセスがIEから情報を取得するまで待機
  Do While(True)
    WScript.Sleep 100
    If (cntQueue.Count = 0) Then
      Exit Do
    End If
  Loop

threadNum = threadNum + num
  ie.Quit

End Sub

' IEオブジェクトを作成
Function createIE()
  Dim ie

' IEを作成
  Set ie = WScript.CreateObject("InternetExplorer.Application")

' 処理完了まで待機
  Do While(ie.Busy)
      WScript.Sleep 100
  Loop

Set createIE = ie
End Function

' 他プロセスからこのファイルの関数を呼ばれた場合、
' 呼び出し先(このファイルを実行するプロセス)の
' スレッド割り込みにより処理が実行される。
' このため、他プロセス間で共有しているリソースは
' このファイルの関数を経由して変更する限り
' 常に1スレッドでの処理となる。
' このため他プロセスからであってもキュー操作は
' enqueueEvent、dequeueEventを使って処理すること。

' キューにイベントを追加
Sub enqueueEvent(queue, eventData)
  queue.Enqueue eventData
End Sub

' キューからイベントを取得
Function dequeueEvent(queue)
  If (0 = queue.Count) Then
    Set dequeueEvent = Nothing
  Else
    Set dequeueEvent = queue.Dequeue
  End If
End Function

' スレッド終了まで待機
Function waitComplete(waitTime)
  Dim waitCount, index
  Dim interval
  interval = 500
  waitComplete = False

' 指定された待機時間を越えるまでのインターバルの回数を取得
  waitCount = CInt(waitTime * 1000 / interval + 0.5)

' キューが空になるまで待機
  Do While(0 < waitCount)
    WScript.Sleep interval
    If (0 = queue.Count) Then
      Exit Do
    End If
    waitCount = waitCount - 1
  Loop

' 時間切れの場合はFalseを返却
  If (0 = waitCount) Then
    Exit Function
  End If

' キューにスレッド終了のイベントを設定する
  If (0 < waitCount) Then
    For index = 1 To threadNum
      enqueueEvent queue, createEvent(EVENT_END, Nothing)
    Next
  End If

' スレッドが終了するまで待機する
  Do While(0 < waitCount)
    WScript.Sleep interval
    If (0 = getAliveThreadNum()) Then
      Exit Do
    End If
    waitCount = waitCount - 1
  Loop

' スレッドが終了した場合はTrueを返却
  If (0 < waitCount) Then
    waitComplete = True
  End If

End Function

' スレッドの数を返却する
Function getAliveThreadNum()
  Dim wshExec, cnt
  cnt = 0
  For Each wshExec In execList.Items
    If (wshExec.Status = 0) Then
      cnt = cnt + 1
    End If
  Next
  getAliveThreadNum = cnt
End Function

' スレッドを強制終了する
Sub forceToTerminateThread
  Dim wshExec
  On Error Resume Next
  For Each wshExec In execList.Items
    If (0 = wshExec.Status) Then
      wshExec.Terminate
    End If
  Next
End Sub

' イベントを作成する
Function createEvent(id, info)
  Dim ed
  Set ed = New EventData
  ed.setId(id)
  ed.setInfo(info)
  Set createEvent = ed
End Function

' キューに格納するイベント情報
Class EventData

Private id
  Private info

Public Function getId()
    getId = id
  End Function

Public Function getInfo()
    If (IsObj(info)) Then
      Set getInfo = info
    Else
      getInfo = info
    End If
  End Function

Public Function setId(eventId)
    id = eventId
  End Function

Public Function setInfo(eventInfo)
    If (IsObj(eventInfo)) Then
      Set info = eventInfo
    Else
      info = eventInfo
    End If
  End Function

End Class

' 指定された変数がオブジェクトかどうかを判定する
Function IsObj(val)
  Select Case typeName(val)
  Case "Byte"
    IsObj = False
  Case "Integer"
    IsObj = False
  Case "Long"
    IsObj = False
  Case "Single"
    IsObj = False
  Case "Double"
    IsObj = False
  Case "Currency"
    IsObj = False
  Case "Decimal"
    IsObj = False
  Case "Date"
    IsObj = False
  Case "String"
    IsObj = False
  Case "Boolean"
    IsObj = False
  Case "Empty"
    IsObj = False
  Case "Null"
    IsObj = False
  Case Else
    IsObj = True
  End Select
End Function