Computers and Programming Experiences

VBScript MultiThreading
While searching for a way to fake multithreading in Visual Basic Script, I examined several examples and developed my own code based on Scott Haleen's version.

In my example below I originally had 5 Thread Scripts which could be anything, I altered the sleep timing so each script completed in 2, 4, 6, 8 & 10 seconds and returned various quit codes.

If I developed this as a normal script it would take 30 seconds in total to complete, but the MultiThreading version completes in only 10 seconds if all threads allowed to run concurrently (i.e. when the longest running thread has finished).

I've added for completeness the ability to terminate a thread by timeout if required. However, Terminating a thread (or process in this case) is not recommended as putting an axe through a running script can have unexpected results. The benefit it does do is allow more control over the overall script especially when timing is critical (i.e. for frequently executed scheduled tasks). I examined several options, but each had their limitations...

1. 'CScript /T:nn script.vbs' - No return or exit code for a terminated script.
2. 'WScript.Timeout = nn' - No return or exit code for a terminated script.
3. Timeout Function within thread script (i.e. Thread1.vbs) - Won't terminate if running a long single command until it has completed.
4. WshScriptExec.Terminate - Intermitently produces a Windows Invalid Handle exception.

In the end I went with WshScriptExec.Terminate object within the main multithreading script and handled the intermittent exception, as I could capture a terminate response if I needed to do something with a terminated thread.

The Timeout functionality also provided an added benefit as it allowed me to record/log how long a thread was processing, this is useful for long running threads as putting these first means your script can complete quicker when having more than the max concurrent threads.

VBScript MultiThreading Code

Option Explicit

' ########################################################################################
' # VBScript   : MainScript.vbs                                                          #
' # Coded By   : Matt Wakeling                                                           #
' # Coded Date : 02nd August 2014                                                        #
' ########################################################################################
' # Description        : VBScript to simulate multi-threading                            #
' #                                                                                      #
' # Change History     : 001.000 Initial Release                                         #
' #                      001.001 Added Exception Handling                                #
' #                      001.002 Added Debug Mode + Logging                              #
' #                      001.003 Added Maximum Concurrent Thread Functionality           #
' #                      001.004 Added Time out Thread Functionality                     #
' # Thread Time out    : 0         = No Time out                                         #
' #                    : 1 - 32767 = Seconds until time out                              #      
' # Thread Exec Status : 0         = Running                                             #
' #                      1         = Completed                                           #
' #                      2         = Terminated (Time out)                               #
' # Thread Exit Code   : 0         = Default                                             #
' #                      1 - 255   = User Defined                                        #
' #                                                                                      #
' # Known Problems     : 0x80070578 Invalid Window Handle on Terminate Thread this is a  #
' #                      known WshScriptExec.Terminate object issue. The script handles  #
' #                      the exception.                                                  # 
' ########################################################################################

On Error Resume Next

'Declare Constants
Const bolDebugMode = True

Const ForWriting = 2
Const ForAppending = 8
Const adVarChar = 200 
Const adInteger = 3 
Const adDate = 7
Const adFilterNone = "" 

Const MaxThreads = 2
Const ThreadTimeout = 30  ' 0 = No time out


'Declare Variables
Dim objFSO, objLogFile, strLogFile
Dim objWshShell, objADORRS
Dim arrMultiThreads(), arrExec(), intThreadCount
Dim intLoopCounter

Set objADORRS = CreateObject("ADOR.Recordset") 
objADORRS.Fields.Append "Thread", adVarChar, 255
objADORRS.Fields.Append "ExecStatus", adInteger, 5  
objADORRS.Fields.Append "ExecID", adInteger, 5
objADORRS.Fields.Append "ProcessID", adInteger, 5
objADORRS.Fields.Append "ProcessStart", adDate, 5
objADORRS.Fields.Append "ProcessTime", adInteger, 5
objADORRS.Open 

Set objWshShell = WScript.CreateObject("WScript.Shell") 

strLogFile = Wscript.ScriptName & ".log"

Set objFSO = createobject("Scripting.FileSystemObject") 
Set objLogFile = objFSO.OpenTextFile(strLogFile, ForAppending, true)

objLogFile.WriteLine Now & " | Script           : Started" 

If bolDebugMode then objLogFile.WriteLine Now & " | Script Status    : Debug Mode Enabled"
If bolDebugMode then objLogFile.WriteLine Now & " | Script Name      : " & Wscript.ScriptName
If bolDebugMode then objLogFile.WriteLine Now & " | Script Path      : " & Wscript.ScriptFullName
If bolDebugMode then objLogFile.WriteLine Now & " | Build number     : " & ScriptEngineMajorVersion & "." & ScriptEngineMinorVersion & "." & ScriptEngineBuildVersion
If bolDebugMode then objLogFile.WriteLine Now & " | Description      : Multi Threaded VBScript Example"

If Err <> 0 Then LogError("Script Error")

If bolDebugMode then objLogFile.WriteLine Now & " | MultiThreading   : Initialise Threads"
If bolDebugMode then objLogFile.WriteLine Now & " | MultiThreading   : Maximum Concurrent Threads = " & MaxThreads
If bolDebugMode then objLogFile.WriteLine Now & " | MultiThreading   : Thread Time Out = " & ThreadTimeout

Redim preserve arrMultiThreads(4)

arrMultiThreads(0) = "cscript.exe //NoLogo //B Thread1.vbs"
arrMultiThreads(1) = "cscript.exe //NoLogo //B Thread2.vbs"
arrMultiThreads(2) = "cscript.exe //NoLogo //B Thread3.vbs"
arrMultiThreads(3) = "cscript.exe //NoLogo //B Thread4.vbs"
arrMultiThreads(4) = "cscript.exe //NoLogo //B Thread5.vbs"

If Err <> 0 Then LogError("Initialise Threads Error")

intThreadCount = 0 
intLoopCounter = 0
For intLoopCounter = 0 To UBound(arrMultiThreads)
 Redim preserve arrExec(intLoopCounter) 

 If bolDebugMode then objLogFile.WriteLine Now & " | MultiThreading   : Execute (" & arrMultiThreads(intLoopCounter) & ")"
 Set arrExec(intLoopCounter) = objWshShell.Exec(arrMultiThreads(intLoopCounter))
   
 objADORRS.AddNew 
 objADORRS("Thread") = arrMultiThreads(intLoopCounter) 
 objADORRS("ExecStatus") = 0  
 objADORRS("ExecID") = intLoopCounter
 objADORRS("ProcessID") = arrExec(intLoopCounter).ProcessID
 objADORRS("ProcessStart") = Now()
 objADORRS("ProcessTime") = 0 
 objADORRS.Update  
   
 intThreadCount = intThreadCount + 1

 If intThreadCount > (MaxThreads - 1) then  
            WaitForThreads(MaxThreads - 1) 
   objADORRS.MoveLast
 End If 
 
 If Err <> 0 Then LogError("Execute Thread Error")
Next

WaitForThreads 0

If bolDebugMode then objLogFile.WriteLine Now & " | Script Status    : Performing Clean-up"

objLogFile.WriteLine Now & " | Script           : Completed" 

If Err <> 0 Then LogError("Script Error")

objADORRS.Close
objLogFile.Close

'Perform Clean up 

intThreadCount = 0
intLoopCounter = 0

strLogFile = ""

Erase arrMultiThreads
Erase arrExec

Set objADORRS = Nothing
Set objLogFile = Nothing
Set objFSO = Nothing


Sub WaitForThreads(intThreads)
' ########################################################################################
' # Description     : Wait for threads to complete and get script return code            #
' ########################################################################################

 On Error Resume Next
  
 Dim intThreadHandle
  
 Do While intThreadCount > intThreads
  objADORRS.Filter = "ExecStatus = 0" 

  objADORRS.MoveFirst
  Do While Not objADORRS.EOF
   objADORRS("ProcessTime") = DateDiff("s", objADORRS("ProcessStart"), Now())   
   intThreadHandle = objADORRS("ExecID")

   If (arrExec(intThreadHandle).Status <> 0 Or (objADORRS("ProcessTime") >= ThreadTimeout And ThreadTimeout <> 0)) then  
    If (objADORRS("ProcessTime") >= ThreadTimeout And ThreadTimeout <> 0) Then 
     If Err <> 0 Then LogError("WaitForThreads Error")
     arrExec(intThreadHandle).Terminate
     If Err <> 0 Then LogError("WaitForThreads Error : Terminate Thread (Invalid Window Handle)")
  
     objADORRS("ExecStatus") =  2
     If bolDebugMode then objLogFile.WriteLine Now & " | MultiThreading   : Terminated (" & objADORRS("Thread") & ") ExecStatus : " & objADORRS("ExecStatus") & " | ExitCode : " & arrExec(intThreadHandle).ExitCode & " | ProcessID : " &  arrExec(intThreadHandle).ProcessID & " | Status : " &  arrExec(intThreadHandle).Status & " | ProcessTime : " & objADORRS("ProcessTime")    

    Else
     objADORRS("ExecStatus") =  arrExec(intThreadHandle).Status
     If bolDebugMode then objLogFile.WriteLine Now & " | MultiThreading   : Completed (" & objADORRS("Thread") & ") ExecStatus : " & objADORRS("ExecStatus") & " | ExitCode : " & arrExec(intThreadHandle).ExitCode & " | ProcessID : " &  arrExec(intThreadHandle).ProcessID & " | Status : " &  arrExec(intThreadHandle).Status & " | ProcessTime : " & objADORRS("ProcessTime")    
    End If
   End If

   If Err <> 0 Then LogError("WaitForThreads Error")
  
   objADORRS.MoveNext
  Loop
  intThreadCount = objADORRS.RecordCount
 Loop
 
 objADORRS.Filter = adFilterNone 
 
 intThreadHandle = 0 
End Sub



Sub LogError(strErrorMessage)
' ########################################################################################
' # Description     : Exception Logging                                                  #
' ########################################################################################

 Dim objErrorFile, strErrorFile

 strErrorFile = Wscript.ScriptName & ".ERROR.log"

 Set objErrorFile = objFSO.OpenTextFile(strErrorFile, ForAppending, true)
 
 objErrorFile.WriteLine Now & " | Err Message : " & strErrorMessage & " | Err Number : " & Err.Number & " | Err Hex : " & Hex(Err.Number) & " | Err Description : " & Err.Description & " | Err Source : " & Err.Source 
    Err.Clear

 objErrorFile.Close
 
 strErrorFile = ""
 
 Set objErrorFile = Nothing 
End Sub

Example Thread Code

Const ForWriting = 2

Dim objFSO, objLogFile, strLogFile

strLogFile = Wscript.ScriptName & ".log"

Set objFSO = createobject("Scripting.FileSystemObject") 
Set objLogFile = objFSO.OpenTextFile(strLogFile, ForWriting, true)

objLogFile.WriteLine Now & " | Script Name : " & Wscript.ScriptName
WScript.Sleep 3000
objLogFile.WriteLine Now & " | Script Path : " & Wscript.ScriptFullName
WScript.Sleep 3000
objLogFile.WriteLine Now & " | Build number : " & ScriptEngineMajorVersion & "." & ScriptEngineMinorVersion & "." & ScriptEngineBuildVersion

objLogFile.Close

strLogFile = ""

Set objLogFile = Nothing
Set objFSO = Nothing

WScript.Quit(5)

Example Log Output

03/08/2014 18:51:02 | Script           : Started
03/08/2014 18:51:02 | Script Status    : Debug Mode Enabled
03/08/2014 18:51:02 | Script Name      : MainScript.vbs
03/08/2014 18:51:02 | Script Path      : D:\TEST\MultiThreadScript\MainScript.vbs
03/08/2014 18:51:02 | Build number     : 5.8.18337
03/08/2014 18:51:02 | Description      : Multi Threaded VBScript Example
03/08/2014 18:51:02 | MultiThreading   : Initialise Threads
03/08/2014 18:51:02 | MultiThreading   : Maximum Concurrent Threads = 2
03/08/2014 18:51:02 | MultiThreading   : Thread Time Out = 30
03/08/2014 18:51:02 | MultiThreading   : Execute (cscript.exe //NoLogo //B Thread1.vbs)
03/08/2014 18:51:02 | MultiThreading   : Execute (cscript.exe //NoLogo //B Thread2.vbs)
03/08/2014 18:51:06 | MultiThreading   : Completed (cscript.exe //NoLogo //B Thread2.vbs) ExecStatus : 1 | ExitCode : 0 | ProcessID : 4444 | Status : 1 | ProcessTime : 4
03/08/2014 18:51:06 | MultiThreading   : Execute (cscript.exe //NoLogo //B Thread3.vbs)
03/08/2014 18:51:12 | MultiThreading   : Completed (cscript.exe //NoLogo //B Thread3.vbs) ExecStatus : 1 | ExitCode : 5 | ProcessID : 1540 | Status : 1 | ProcessTime : 6
03/08/2014 18:51:12 | MultiThreading   : Execute (cscript.exe //NoLogo //B Thread4.vbs)
03/08/2014 18:51:21 | MultiThreading   : Completed (cscript.exe //NoLogo //B Thread4.vbs) ExecStatus : 1 | ExitCode : 0 | ProcessID : 1528 | Status : 1 | ProcessTime : 9
03/08/2014 18:51:21 | MultiThreading   : Execute (cscript.exe //NoLogo //B Thread5.vbs)
03/08/2014 18:51:31 | MultiThreading   : Completed (cscript.exe //NoLogo //B Thread5.vbs) ExecStatus : 1 | ExitCode : 0 | ProcessID : 2632 | Status : 1 | ProcessTime : 10
03/08/2014 18:51:34 | MultiThreading   : Terminated (cscript.exe //NoLogo //B Thread1.vbs) ExecStatus : 2 | ExitCode : 0 | ProcessID : 2116 | Status : 1 | ProcessTime : 30
03/08/2014 18:51:34 | Script Status    : Performing Clean-up
03/08/2014 18:51:34 | Script           : Completed

To run the script perform the following tasks...

1. Create a new directory i.e. C:\VBScript
2. Copy MultiThreading Code into C:\VBScript\MultiThreading.vbs
3. Copy Thread Code into C:\VBScript\Thread1.vbs
4. Copy Thread Code into C:\VBScript\Thread2.vbs
5. Copy Thread Code into C:\VBScript\Thread3.vbs
6. Copy Thread Code into C:\VBScript\Thread4.vbs
7. Copy Thread Code into C:\VBScript\Thread5.vbs
8. Alter Sleep Timings and WScript.Quit() values for each Thread Script.
9. In Command Prompt type 'cscript C:\VBScript\MultiThreading.vbs' and press Enter

I hope this is of some use to you all, please feel free to leave a comment...

VBScript to import multiple VCF (VCard) Contact Cards into Outlook 2007
My partner just got her new phone and wanted to import all of her contact numbers, of course this being electronics the actual task became my responsibility, should have seen that coming.

I installed the relevant software for each of her phones and managed to export all her contacts into VCF VCard format, which then could be imported into Outlook and sent directly to her new smartphone.

At this point I found that she had umpteen contacts and outlook only allows you to enter one at a time (typical...). I did some searching and did find a VBA Script to import multiple records, or I could pay for an application to perform the task (well, I'm not paying if I don't need too).

The VBA Script did throw up several errors when running or would constantly get itself into a muddle and loop continuously, so I decided to write my own version in much loved VBScript.

Outlook 2007 Import Multiple VCards (VCF) Code

Option Explicit

' ########################################################################################
' # VBScript   : ProcessVCards.vbs                                                       #
' # Coded By   : Matt Wakeling                                                           #
' # Coded Date : 01st November 2011                                                      #
' ########################################################################################
' # Description     : VBScript to import multiple VCF Contact Cards into Outlook 2007    #
' #                                                                                      #
' # Known Problems  : The Outlook objects are cleared every contact and a sleep          #
' #                   command has been added after processing each contact as the        #
' #                   orignal script caused errors, which would not usually occur. I     #
' #                   believe this is caused by the processing speed of the PC.          #
' #                                                                                      #
' #                   This method worked 100% of the time, so it may not be best         #
' #                   coding practice (i.e. re-declaring the objects every time) but     #
' #                   does work, which is more important :-)                             #
' ########################################################################################

' Initialise Constants
Const WAIT_SECONDS  = 2
Const VCARD_DIRECTORY  = "C:\VCARDS"

Const olContact = 40

' Initialise Variables
Dim objWSHShell
Dim objOutlook 
Dim objActiveInspector
Dim strVCFilename 
Dim objFileSystemObject 
Dim objFSODirectory
Dim objFSOFile 
Dim objItem
Dim lngReturnValue 
Dim olDiscard
    
Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")       
    
Set objFSODirectory = objFileSystemObject.GetFolder(VCARD_DIRECTORY)        
    
Set objWSHShell = CreateObject("WScript.Shell")       
      

For Each objFSOFile In objFSODirectory.Files 
  If UCase(Right(objFSOFile.Name,3)) = "VCF" Then 
    strVCFilename = "C:\VCARDS\" & objFSOFile.Name
                      
    Set objOutlook = CreateObject("Outlook.Application")
    If Not(objOutlook Is Nothing) Then 
      lngReturnValue = objWSHShell.Run (Chr(34) & strVCFilename & Chr(34), 0, True)
              
      Set objActiveInspector = objOutlook.ActiveInspector
             
      Set objItem = objActiveInspector.CurrentItem
             
      If (objItem.Class = olContact) Then
        objActiveInspector.CurrentItem.Save
        objActiveInspector.CurrentItem.Close olDiscard

        WScript.echo "Successfully Imported : " & objFSOFile.Name
      End If
              
      WScript.sleep WAIT_SECONDS * 1000 
   
      Set objItem  = Nothing
      Set objActiveInspector  = Nothing
      Set objOutlook = Nothing
    Else
      WScript.echo "Outlook Connection Issue, file " & objFSOFile.Name & " not imported"
    End If
  Else
    WScript.echo objFSOFile.Name & " is not a valid Contact Card"
  End If 
Next

Set objFileSystemObject  = Nothing     
Set objFSODirectory  = Nothing 
Set objWSHShell = Nothing

To run the script perform the following tasks...

1. OPTIONAL Clear or Move your contacts in the default contacts folder in Outlook 2007.
2. Create a new directory in C:\ called VCARDS.
3. Create a new directory in C:\VCARDS called VBScript.
4. Create a new text document and paste in the above code.
5. Save the new text document as 'ProcessVCards.vbs'.
6. Copy all your VCard (VCF Files) contacts to the C:\VCARDS directory.
7. Open a command prompt (START --> RUN --> CMD).
8. Change directory to C:\VCARDS\SCRIPT.
9. Type 'cscript ProcessVCards.vbs' and press .

When executed the VBScript should produce output similar to the following to show everything is working correctly...



The default outlook contacts screen will show output similar to the following...



I hope this is of some use to you all, please feel free to leave a comment...