This is another post I have started beeing inspired by posts on AnalystCave blog, and wanted to reach further from where he left it.
There are some starting posts with info that worth to take a look before getting hands on dough:
as expected. I realised of some points after this operation, and showed me that, at the end, I was taming the topic. Here is the code cleaned and with the propper functions. Note: You will need the API Sleep function, already declared in the code chunks above.
- https://analystcave.com/excel-vba-multithreading-tool/
- https://analystcave.com/excel-multithreading-vba-with-vba-worker-threads/
- https://analystcave.com/vba-native-vba-multithreading/
- https://analystcave.com/excel-multithreading-in-vba-using-vbscript/
- https://stackoverflow.com/questions/5721564/multi-threading-in-vba
- http://www.excelhero.com/blog/2010/05/multi-threaded-vba-update.html
- http://www.freevbcode.com/ShowCode.asp?ID=4029
- http://mikejuniperhill.blogspot.com/2017/06/excelvba-multi-threading-example.html
- http://www.vbaccelerator.com/codelib/thread/exethr.htm, always interesting, too much to explore here.
- http://dailydoseofexcel.com/archives/2006/10/09/async-xmlhttp-calls/
- http://www.databison.com/simulating-multithreading-in-vba-using-excel/ , although this post actually does not really perform anything near to multithreading
- http://www.desaware.com/tech/threading.aspx, very promising, but do not know how to make it work, and files in the site are broken. But you can search the original code content in the book C++ for VB Programmers (ISBN 1-893115-76-3).
- http://www.desaware.com/tech/waiting.aspx
- https://support.microsoft.com/en-us/help/150777/info-descriptions-and-workings-of-ole-threading-models
The running code
Following are my final design (by 15/01/2019) of the multithreading topic. There are some code uncommented, not in use, but is kept here if it’s needed in the future.' Author: Tomasz Kacprowicz
' Modifications: Enrique Luengo
Option Explicit
Dim startD As Date
Dim endD As Date
#If VBA7 Then
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems
#Else
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For 32 Bit Systems
#End If
'Private Declare Function CreateThread Lib "kernel32" (ByVal lpSecurityAttributes As Long, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, ByVal lpParameter As Long, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
'Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
'
'.... temporally invented (search in Google for full declaration)
'Private Declare Function GetCurrentThread Lib "kernel32" ()
'Private Declare Function GetExitCodeThread Lib "kernel32" ()
'Private Declare Function ExitThread Lib "kernel32" ()
'Private Declare Function TerminateThread Lib "kernel32" ()
'
'Sub a_test()
' Dim hndThread As Long
' Dim lgCounter As Long
'
' On Error Resume Next
'
' For lgCounter = 1 To 100000
' ' Free threaded approach
' hndThread = CreateThread(ByVal 0&, ByVal 0&, AddressOf AsyncThread, 0&, ByVal 0&, 0&)
' If hndThread = 0 Then ' (error)
' Exit Sub
' End If
'
' ' We don't need the thread handle
' CloseHandle hndThread
' Next lgCounter
'
' MsgBox "Done"
'End Sub
'
'Function AsyncThread()
' On Error Resume Next
'
' ' Do Stuff
'
' ' Clean up Thread
' AsyncThread = True
' Dim lpExitCode
' GetExitCodeThread GetCurrentThread, lpExitCode
'' ExitThread lpExitCode ' Crashes Excel
' TerminateThread GetCurrentThread, lpExitCode
'End Function
Private Sub SaveRangeToMaster(ByVal masterWorkbookName As String, _
ByRef r As Excel.Range)
'Save data to the master file
Dim oXLmain As Excel.Application 'Object
Set oXLmain = GetObject(, "Excel.Application")
oXLmain.Workbooks(masterWorkbookName) _
.Sheets(r.Worksheet.Name) _
.Range(r.address) _
.Value2 = r.Value2
Set oXLmain = Nothing
End Sub
Private Sub SetRangeToMaster(ByVal masterWorkbookName As String, _
ByVal sheetName As String, _
ByVal rangeAddress As String, _
ByVal val As Variant)
'Set data to the master file
Dim oXLmain As Excel.Application 'Object
Set oXLmain = GetObject(, "Excel.Application")
oXLmain.Workbooks(masterWorkbookName) _
.Sheets(sheetName) _
.Range(rangeAddress) _
.Value = val
Set oXLmain = Nothing
End Sub
Public Sub TestMultithreading()
Dim par As clsParallel
Set par = New clsParallel
par.SetThreads 2
par.SetWorkBook ActiveWorkbook 'ThisWorkbook 'Application.Workbooks.Open(...)
startD = Timer
Call par.Parallel("RunTest", 1, 200000000, "A1") '... up to 30 arguments to run the macro
endD = Timer
MsgBox endD - startD
Set par = Nothing
End Sub
Private Sub RunTest(ByVal workbookName As String, _
ByVal fromArg As Long, _
ByVal toArg As Long, _
Optional ByVal address As String)
Dim r As Excel.Range
Dim i As Long
Dim x As Double
For i = fromArg To toArg
x = fromArg / toArg
Next i
Set r = Range(address)
r.Value = toArg
Call SaveRangeToMaster(workbookName, r)
End Sub
This code relies on the Tomasz Kacprowicz’s class Parallel, that I have modified to perform better (I think), and to be more understandable in the steps it executes. Paste this code in a Class, and call it clsParallel.
' Author: Tomasz Kacprowicz
' Modifications: Enrique Luengo
Option Explicit
Private cThreads As Long
Private parallelKey As String
Private Workbook As Excel.Workbook
Private Sub class_initialize()
' set 4 cores processor as default (each core will handle 1 thread at max performance)
cThreads = 4
Call VBA.Randomize
parallelKey = VBA.Hex(VBA.CLng(VBA.Rnd() * 1000000)) ' "Unique" key for tracking
End Sub
Private Sub Class_Terminate()
DropSemaphores
End Sub
Public Sub SetThreads(ByVal threads As Long)
If threads > 0 Then cThreads = threads
End Sub
Public Sub SetWorkBook(ByVal oWbk As Excel.Workbook)
Set Workbook = oWbk
End Sub
'Public Function GetThreads() As Long
' GetThreads = cThreads
'End Function
'Public Function GetThread(ByVal strFile As String) As Long
' GetThread = CLng(Mid(strFile, _
' InStr(strFile, "_") + 1, _
' InStr(strFile, ".") - InStr(strFile, "_") - 1))
'End Function
Private Sub CreateSemaphores()
Dim thread As Long
For thread = 1 To cThreads
Call Workbook.Names.Add(Name:="_" & parallelKey & "_" & thread, RefersTo:="=0", Visible:=True)
Next thread
End Sub
Private Sub DropSemaphores()
Dim thread As Long
On Error Resume Next
For thread = 1 To cThreads
Call Workbook.Names("_" & parallelKey & "_" & thread).Delete
Next thread
On Error GoTo 0
End Sub
Private Function CountSemaphores() As Long
Dim thread As Long
Dim c As Long
c = 0
For thread = 1 To cThreads
If VBA.CLng(VBA.Replace(Expression:=Workbook.Names("_" & parallelKey & "_" & thread).Value2, Find:="=", Replace:="")) > 0 Then
c = c + 1
End If
Next thread
CountSemaphores = c
End Function
Private Function CountActive() As Long
Dim thread As Long
Dim c As Long
c = 0
For thread = 1 To cThreads
If VBA.CLng(Workbook.Names("_" & parallelKey & "_" & thread).Value2 = 1) > 0 Then
c = c + 1
End If
Next thread
CountActive = c
End Function
Private Sub NewThread(ByVal strVBScript As String, _
ByVal thread As Long, _
ByVal args As String)
Dim s As String
Dim sFileName As String
Dim oWSh As Object
'Save a copy of the Excel workbook
Dim threadFileName As String
threadFileName = Workbook.Path & "\" & parallelKey & "_" & thread & ".xls"
Call ActiveWorkbook.SaveCopyAs(threadFileName)
'Save the VBscript to file
Dim iFileVBS As Integer
iFileVBS = VBA.FreeFile()
sFileName = Workbook.Path & "\" & parallelKey & "_" & thread & ".vbs"
Open sFileName For Output As #iFileVBS
Print #iFileVBS, strVBScript
Close #iFileVBS
'Execute the VBscript file asynchronously
Set oWSh = VBA.CreateObject("WScript.Shell")
oWSh.Run """" & sFileName & """"
Set oWSh = Nothing
End Sub
Public Function IsTheadRunning(ByVal thread As Long) As Boolean
'If VBA.Dir(Workbook.Path & "\" & parallelKey & "_" & thread & ".vbs") Then
' IsTheadRunning = True
'Else
' IsTheadRunning = False
'End If
IsTheadRunning = VBA.CBool(Workbook.Names("_" & parallelKey & "_" & thread).Value2)
End Function
Private Sub ThreadsJoin()
Dim thread As Long
Do Until False
DoEvents
If CountSemaphores >= cThreads Then
Sleep 100
'Kill Workbook.Path & "\" & parallelKey & "_" & "*.vbs"
Kill Workbook.Path & "\" & parallelKey & "_" & "*.xls"
DropSemaphores
Exit Sub
End If
Sleep 10
Loop
End Sub
Public Function Parallel(ByVal macroName As String, _
ByVal seqFrom As Long, _
ByVal seqTo As Long, _
Optional ByVal arg1 As Variant, Optional ByVal arg2 As Variant, _
Optional ByVal arg3 As Variant, Optional ByVal arg4 As Variant, _
Optional ByVal arg5 As Variant, Optional ByVal arg6 As Variant, _
Optional ByVal arg7 As Variant, Optional ByVal arg8 As Variant, _
Optional ByVal arg9 As Variant, Optional ByVal arg10 As Variant, _
Optional ByVal arg11 As Variant, Optional ByVal arg12 As Variant, _
Optional ByVal arg13 As Variant, Optional ByVal arg14 As Variant, _
Optional ByVal arg15 As Variant, Optional ByVal arg16 As Variant, _
Optional ByVal arg17 As Variant, Optional ByVal arg18 As Variant, _
Optional ByVal arg19 As Variant, Optional ByVal arg20 As Variant, _
Optional ByVal arg21 As Variant, Optional ByVal arg22 As Variant, _
Optional ByVal arg23 As Variant, Optional ByVal arg24 As Variant, _
Optional ByVal arg25 As Variant, Optional ByVal arg26 As Variant, _
Optional ByVal arg27 As Variant, Optional ByVal arg28 As Variant, _
Optional ByVal arg29 As Variant, Optional ByVal arg30 As Variant) As Boolean
Dim thread As Long
Dim Module As Double
Dim args As String
Dim s As String
Dim strVBScriptThread As String
CreateSemaphores ' names in ActiveWorkbook that will hold the thread semaphores
'Create Thread template
s = s & "' 1. Create new parallel thread (new Excel App): "
s = s & "Dim oXLparallelApp: " ' Object that handles the parallel "{thread?}"
s = s & ": "
s = s & "Set oXLparallelApp = CreateObject(""Excel.Application""): "
s = s & "With oXLparallelApp: "
s = s & " .Application.Visible = False: "
s = s & " .Workbooks.Open(""" & "{threadFileName?}" & """): "
s = s & ": "
s = s & " ' 2. run the parallelized procedure: "
s = s & " .Application.Run """ & parallelKey & "_" & "{thread?}" & ".xls!" & _
macroName & """ , """ & _
Workbook.Name & """," & _
"{subSeqFrom?}" & "," & _
"{subSeqTo?}" & ": "
'!!!!!!!!!!!!!!!!!
' args & ":" ' we can feed up to 30 args
' To run a specific macro: "myBook.xlsm!myModule.myMacro"
'!!!!!!!!!!!!!!!!!
s = s & " .ActiveWorkbook.Close True: "
s = s & " .Application.Quit: "
s = s & "End With: "
s = s & "Set oXLparallelApp = Nothing: "
's = s & "' 3. Actualize thread counter in main Workbook: "
's = s & "On Error Resume Next: "
's = s & "Dim oXLmainApp: " ' Object that handles the main app
's = s & ": "
's = s & "Set oXLmainApp = GetObject(, ""Excel.Application""): "
's = s & "If Err.Number <> 0 Then: "
's = s & " If Err.Number = 429 Then 'No current instance of Excel start up Excel: "
's = s & " Err.Clear: "
's = s & " 'WScript.Quit: "
's = s & " 'If oXLmainApp <> ""Microsoft Excel"" Then: "
's = s & " ' Set oXLmainApp = CreateObject(""Excel.Application""): "
's = s & " 'End If: "
's = s & " End If: "
's = s & "End If: "
's = s & "'If TypeName(oXLmainApp) = ""Empty"" Then: "
's = s & "' MsgBox ""Excel NOT Running"", vbInformation, ""Excel Status"": "
's = s & "' 'WScript.Quit: "
's = s & "'End If: "
's = s & "On Error Resume Next: "
's = s & ": "
's = s & "'If oXLmainApp.Workbooks.Count > 0 Then: "
's = s & " 'For Each oXLWbk In oXLmainApp.Workbooks: "
's = s & " On Error Resume Next: "
's = s & " Set oXLWbk = oXLApp.WorkBooks(""" & Workbook.Name & """): "
's = s & " oXLWbk.Activate: "
's = s & " If Err <> 0 Then: "
's = s & " ' unable to activate, so workbook was not open -> open it now: "
's = s & " Dim fullPath: fullPath = InputBox(""Give full path and name for workbook"", , oXLApp.ActiveWorkbook.Name): "
's = s & " If Not vbYes = MsgBox(""Open workbook ["" & fullPath & ""]?"", vbYesNo) Then 'WScript.Quit: "
's = s & " 'Set oXLWbk = oXLmainApp.Workbooks.Open(fullPath, 0, True): "
's = s & " Set oXLWbk = oXLmainApp.ActiveWorkbook: "
's = s & " End If: "
's = s & " Err.Clear: "
's = s & " On Error GoTo 0: "
's = s & " 'Next: "
's = s & "'End If: "
's = s & "With oXLmainApp: "
's = s & " .Workbooks(""" & Workbook.Name & """)" & _
".Names(""_" & parallelKey & "_" & "{thread?}" & """).Value2 = 1: " ' while running...
's = s & ": "
's = s & " Do Until CLng(Replace(.Workbooks(""" & Workbook.Name & """)" & _
".Names(""_" & parallelKey & "_" & "{thread?}" & """).Value2,""="","""")) = 1: "
's = s & " If Err.Number <> 0 Then Exit Do: "
's = s & " WScript.Sleep(100): "
's = s & " .Workbooks(""" & Workbook.Name & """)" & _
".Names(""_" & parallelKey & "_" & "{thread?}" & """).Value2 = 1: "
's = s & " Loop: "
's = s & "End With: "
's = s & "Set oXLmainApp = Nothing: "
's = s & ": "
's = s & "'On Error GoTo 0: "
' Autokill...
s = s & "Kill " & Workbook.Path & "\" & parallelKey & "_" & "{thread?}" & "*.vbs: "
s = VBA.Replace(s, ": ", vbCrLf)
'If argX Like "Sheet:=*" Then
' argX = VBA.Mid$(argX, VBA.InStr(1, argX, ":=") + 2)
'ElseIf argX Like "Address:=*" Then
' argX = VBA.Mid$(argX, VBA.InStr(1, argX, ":=") + 2)
'End If
args = args & ", " & GetArg(arg1)
args = args & ", " & GetArg(arg2)
args = args & ", " & GetArg(arg3)
args = args & ", " & GetArg(arg4)
args = args & ", " & GetArg(arg5)
args = args & ", " & GetArg(arg6)
args = args & ", " & GetArg(arg7)
args = args & ", " & GetArg(arg8)
args = args & ", " & GetArg(arg9)
args = args & ", " & GetArg(arg10)
args = args & ", " & GetArg(arg11)
args = args & ", " & GetArg(arg12)
args = args & ", " & GetArg(arg13)
args = args & ", " & GetArg(arg14)
args = args & ", " & GetArg(arg15)
args = args & ", " & GetArg(arg16)
args = args & ", " & GetArg(arg17)
args = args & ", " & GetArg(arg18)
args = args & ", " & GetArg(arg19)
args = args & ", " & GetArg(arg20)
args = args & ", " & GetArg(arg21)
args = args & ", " & GetArg(arg22)
args = args & ", " & GetArg(arg23)
args = args & ", " & GetArg(arg24)
args = args & ", " & GetArg(arg25)
args = args & ", " & GetArg(arg26)
args = args & ", " & GetArg(arg27)
args = args & ", " & GetArg(arg28)
args = args & ", " & GetArg(arg29)
args = args & ", " & GetArg(arg30)
Stop
'Create threads
Module = CDbl(seqTo - seqFrom) / cThreads
For thread = 1 To cThreads
strVBScriptThread = VBA.Replace(s, "{threadFileName?}", Workbook.Path & "\" & parallelKey & "_" & thread & ".xls")
strVBScriptThread = VBA.Replace(s, "{subSeqFrom?}", seqFrom + CLng((thread - 1) * Module))
strVBScriptThread = VBA.Replace(s, "{subSeqTo?}", seqFrom + CLng(thread * Module))
strVBScriptThread = VBA.Replace(s, "{thread?}", thread)
Call NewThread(strVBScriptThread, thread, args)
Next thread
'Join threads returns
ThreadsJoin
End Function
Private Function GetArg(ByVal val As Variant) As String
If VarType(val) = vbString Then
GetArg = """" & val & """"
Else
GetArg = "" & val
End If
End Function
The modifications
We must explore which are the paths we could explore to make progress in this multithreading topic. Isolating the main Office objects. Dealing with multithreading in independent Shell instances may require macro to connect to Office core application (Excel.Application, Word.Application,…). But, as they are external, they don’t know about the Office related applications. We need to access this elements via late binding, through object containers. We cannot recall on Excel., Word.,… whatever, and then create with the reserved word New. They have to be specifically redeclared as “Object” (see note) and then created via the CreateObject method. Note here, as VBScript is not tiped defined, they are all variants/objects, you just do not need to specify the As… type. Here is a sample on how to load a swarm of bot agents (initially it was used to scrap a website… now is on it’s way to do something else, but the core is kept). Maybe, on of the main points to note here is that you do not need to stringify the VBA code, if you just can open a new Excel instance and call it through the Application.Run command.Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private oIE As Object 'As SHDocVw.InternetExplorer ' Microsoft Internet Controls must be referenced in Tools > References.
Private oXML As Object 'As MSXML2.XMLHTTP ' Microsoft XML v3.0 (or later) must be referenced in Tools > References.
'Private Const sURL_Base As String = "http://www.google.com/"
Public Sub sVBS_Swarm()
' Note: this procedure uses independent VBScript files
' you may need to authorize each once when they run for the first time, depending on your security settings.
Call sVBScriptAgent(lgAgent:=1, _
strURL:="http://www.google.com/", _
wsReport:=wsX, _
sOutputRangeAddress:="A1")
End Sub
Public Sub sVBScriptAgent(ByRef lgAgent As Long, _
ByVal strURL As String, _
ByVal wsReport As Excel.Worksheet, _
ByVal sOutputRangeAddress As String)
' Worth looking: https://www.softwaretestinghelp.com/vbscript-excel-tutorial-11/
Dim oWSH As Object ' As New ShellWindows ' Windows Scripting Host
Dim iFileOut As Integer
Dim sFileName As String
Dim s As String
' Create VBScript string
s = s & "Option Explicit" & vbCrLf
s = s & "Dim oXML" & vbCrLf ' Object for the MSXML2.XMLHTTP
s = s & "Dim sHTML" & vbCrLf ' Variable for HTML content
s = s & "Dim vResults" & vbCrLf ' Variable to hold parsed data
s = s & vbCrLf
's = s & "Call sExcelReport" & vbCrLf
's = s & " 'WScript.Quit" & vbCrLf
's = s & vbCrLf
' s = s & "' Create core objects" & vbCrLf
' s = s & "Set oXML = WScript.CreateObject(""MSXML2.ServerXMLHTTP"")" & vbCrLf
' s = s & vbCrLf
' s = s & "' Navigate to property page" & vbCrLf
' s = s & "oXML.Open ""GET"", """ & strURL & """, False" & vbCrLf
' s = s & "oXML.setRequestHeader ""User-Agent"", ""Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)""" & vbCrLf
' s = s & "'oXML.setRequestHeader ""Content-Type"", ""text/xml"" ' only to retrieve text" & vbCrLf
' s = s & "'oXML.setRequestHeader ""Content-type"", ""application/text"" ' this may also work for text" & vbCrLf
' s = s & "WScript.Sleep 50" & vbCrLf
' s = s & "oXML.send("""")" & vbCrLf
' s = s & "' wait until completion" & vbCrLf
' s = s & "If oXML.Status = 200 Then ' check if internet connection status = True " & vbCrLf
' s = s & " Do Until oXML.ReadyState = 4" & vbCrLf
' s = s & " WScript.Echo oXML.ReadyState" & vbCrLf ' Test...
' s = s & " Loop" & vbCrLf
' s = s & vbCrLf
' s = s & " ' Get Html content" & vbCrLf
' s = s & " sHTML = oXML.responseText" & vbCrLf
' s = s & "Else" & vbCrLf
' s = s & " MsgBox ""No internet connection"", vbInformation, ""Internet connection"" & vbCrLf" & vbCrLf
' s = s & " 'WScript.Quit" & vbCrLf
' s = s & "End If" & vbCrLf
' 's = s & "WScript.Echo sHTML" & vbCrLf ' Test...
s = s & "Call sExcelReport" & vbCrLf
s = s & "Set oXML = Nothing" & vbCrLf
s = s & vbCrLf
's = s & "WScript.Echo ""Test""" & vbCrLf ' Test...
s = s & "Private Sub sExcelReport()" & vbCrLf
s = s & "' Write back results to Excel" & vbCrLf
s = s & " Dim oXLApp" & vbCrLf ' Object for the Excel.Application
s = s & " Dim oXLWbk" & vbCrLf ' Object for the Excel.Workbook
s = s & " Dim oXLWsh" & vbCrLf ' Object for the Excel.Worksheet
s = s & " Dim oXLRng" & vbCrLf ' Object for the Excel.Range
s = s & vbCrLf
s = s & " ' Get running Excel instance (or open one if needed)" & vbCrLf
s = s & " 'On Error Resume Next" & vbCrLf
s = s & " Set oXLApp = GetObject(, ""Excel.Application"")" & vbCrLf
' Note, do not use:
' WScript.GetObject("", "Excel.Application") as it will be referred to WSH DOM elements and will not find the running Excel instance
' GetObject("""", "Excel.Application") as it will again be referred to WSH DOM elements and will not find the running Excel instance
s = s & " If Err.Number <> 0 Then" & vbCrLf
s = s & " If Err.Number = 429 Then 'No current instance of Excel start up Excel" & vbCrLf
s = s & " Err.Clear" & vbCrLf
s = s & " 'WScript.Quit" & vbCrLf
s = s & " 'If xlApp <> ""Microsoft Excel"" Then" & vbCrLf
s = s & " ' Set xlApp = CreateObject(""Excel.Application"")" & vbCrLf
s = s & " 'End If" & vbCrLf
s = s & " End If" & vbCrLf
s = s & " End If" & vbCrLf
s = s & " 'If TypeName(oXLApp) = ""Empty"" Then" & vbCrLf
s = s & " ' MsgBox ""Excel NOT Running"", vbInformation, ""Excel Status"" & vbCrLf" & vbCrLf
s = s & " ' 'WScript.Quit" & vbCrLf
s = s & " 'End If" & vbCrLf
s = s & " On Error Resume Next" & vbCrLf
's = s & " oXLApp.Visible = True" & vbCrLf
s = s & vbCrLf
s = s & " 'If oXLApp.Workbooks.Count > 0 Then" & vbCrLf
s = s & " 'For Each oXLWbk In oXLApp.Workbooks" & vbCrLf
's = s & " On Error Resume Next" & vbCrLf
s = s & " Set oXLWbk = oXLApp.WorkBooks(""" & ThisWorkbook.Name & """)" & vbCrLf
s = s & " oXLWbk.Activate" & vbCrLf
's = s & " If Err <> 0 Then" & vbCrLf
's = s & " ' unable to activate, so workbook was not open -> open it now" & vbCrLf
's = s & " Dim fullPath: fullPath = InputBox(""Give full path and name for workbook"", , oXLApp.ActiveWorkbook.Name)" & vbCrLf
's = s & " If Not vbYes = MsgBox(""Open workbook ["" & fullPath & ""]?"", vbYesNo) Then 'WScript.Quit" & vbCrLf
's = s & " 'Set oXLWbk = oxlApp.Workbooks.Open(fullPath, 0, True)" & vbCrLf
's = s & " Set oXLWbk = oxlApp.ActiveWorkbook" & vbCrLf
's = s & " End If" & vbCrLf
's = s & " Err.Clear" & vbCrLf
's = s & " On Error GoTo 0" & vbCrLf
s = s & " Set oXLWsh = oXLWbk.Sheets(""" & ActiveSheet.Name & """)" & vbCrLf
s = s & " Set oXLRng = oXLWsh.Range(""A1"")" & vbCrLf
s = s & " 'WScript.Echo oXLApp.Name & "" > "" & oXLWbk.Name & "" > "" & oXLWsh.Name & "" > "" & oXLRng.Value" & vbCrLf
s = s & " oXLRng.Value = sHTML" & vbCrLf
s = s & " 'Next" & vbCrLf
s = s & " 'End If" & vbCrLf
s = s & " 'Exit Sub" & vbCrLf
'----------------
' to run the desired macro in the excel file
s = s & "oXLApp.Run ""sTestHiddenData""" & vbCrLf
'----------------
's = s & " 'Wscript.Sleep Int(Rnd * (800 + 1 - 350)) + 350" & vbCrLf ' Wait a random number [350-800 msec]... to avoid ban
s = s & " 'oXLWbk.Saved = True" & vbCrLf
s = s & " 'oXLApp.Activewindow.Close" & vbCrLf
s = s & " 'oXLApp.Quit" & vbCrLf
s = s & vbCrLf
s = s & " Set oXLRng = Nothing" & vbCrLf
s = s & " Set oXLWsh = Nothing" & vbCrLf
s = s & " Set oXLWbk = Nothing" & vbCrLf
s = s & " Set oXLApp = Nothing" & vbCrLf
s = s & "End Sub" & vbCrLf
' Write other functions
s = s & fVBSOtherFunctions
' Output VBScript to file (set lgAgent flag to keep track of the agent)
sFileName = ThisWorkbook.Path & "\" & "Agent_" & lgAgent & ".vbs"
iFileOut = VBA.FreeFile()
Open sFileName For Output As iFileOut
Print #iFileOut, s
Close iFileOut
s = vbNullString
DoEvents
' Run VBScript file
Set oWSH = CreateObject("Wscript.Shell")
oWSH.Run """" & sFileName & """"
'' Kill script file once executed
'Sleep (1000)
'Kill sFileName
DoEvents
Set oWSH = Nothing
End Sub
Private Function fVBSOtherFunctions() As String
' Other functions
Dim s As String
' to check for internet connection (avoid getting trapped without connection)
's = s & "Function Is_Connected() 'As Boolean" & vbCrLf
's = s & "Dim MyLoop" & vbCrLf
's = s & "Dim strComputer" & vbCrLf
's = s & "Dim objPing" & vbCrLf
's = s & "Dim objStatus" & vbCrLf
's = s & vbCrLf
's = s & "MyLoop = True" & vbCrLf
's = s & "While MyLoop = True" & vbCrLf
's = s & " strComputer = ""smtp.gmail.com""" & vbCrLf
's = s & " Set objPing = GetObject(""winmgmts:{impersonationLevel=impersonate}!\\"").ExecQuery(""select * from Win32_PingStatus where address = '"" & strComputer & ""'"")" & vbCrLf
's = s & " For Each objStatus In objPing" & vbCrLf
's = s & " If objStatus.Statuscode = 0 Then" & vbCrLf
's = s & " MyLoop = False" & vbCrLf
's = s & " Is_Connected = (InternetGetConnectedState(IEStat, 0&) <> 0)" & vbCrLf
's = s & " 'WScript.Quit" & vbCrLf
's = s & " End If" & vbCrLf
's = s & " Next" & vbCrLf
's = s & " pause (10) 'To sleep for 10 secondes" & vbCrLf
's = s & "Wend" & vbCrLf
' will this work on VBScript???
's = s & "Private Declare Function InternetGetConnectedState Lib ""wininet.dll"" (ByRef dwFlags As Long, ByVal dwReserved As Long) As Boolean" & vbCrLf
's = s & "Function Is_Connected() As Boolean" & vbCrLf
's = s & "Dim IEStat As Long" & vbCrLf
's = s & "Is_Connected = (InternetGetConnectedState(IEStat, 0&) <> 0)" & vbCrLf
's = s & "End Function" & vbCrLf
s = s & vbCrLf & "'----------------------------" & vbCrLf
fVBSOtherFunctions = s
End Function
In the fVBSOtherFunctions we will need a parser for the HTML code. This will be achieved through the MSMXL2.XMLHTTP object, DOM elements and nodes.
Get track of agents in use. We can share variables in-between workbooks over the same Excel instance (application), via the Hidden Space Name (more on www.cpearson.com/excel/hidden.htm), so running a tracker can refresh data of any thread. Here a little sample that shows the basic procedures:
Private Sub sTestHiddenData()
Call WriteHiddenData("Variable", "")
MsgBox ReadHiddenData("Variable")
Call DeleteHiddenData("Variable")
End Sub
Private Sub WriteHiddenData(ByRef VarName As String, _
Optional ByRef VarValue As String = vbNullString)
' creates and assigns a value to a data item in Excel's hidden data store
' or
' assigns a value to an existing named item in the hidden data store
Application.ExecuteExcel4Macro "SET.NAME(""" & VarName & """, """ & VarValue & """)"
End Sub
Private Function ReadHiddenData(ByRef VarName As String) As String
' reads a data value from Excel's hidden data store
ReadHiddenData = Application.ExecuteExcel4Macro(VarName)
End Function
Private Sub DeleteHiddenData(ByRef VarName As String)
' deletes a data value from Excel's hidden data store
Application.ExecuteExcel4Macro "SET.NAME(""" & VarName & """)"
End Sub
From Mikael Katajamäki blog, I take a piece of code and corrected it “severely”, as it was not workingOption Explicit
' common text file for results from all Excel threads
'Private Const resultsFilePathName As String = VBA.Environ$("UserProfile") & "\Documents\shared.txt"
Dim resultsFilePathName As String
Public Sub CreateExcelThreads()
' create (and execute) Excel workbook threads
Dim XlThreadhsPath As String
Dim nThreads As Integer
Dim XlThreadName As String
Dim i As Integer
Dim strExt As String
XlThreadhsPath = VBA.Environ$("UserProfile") & "\Documents\"
resultsFilePathName = XlThreadhsPath & "shared.txt"
' clean results text file
If VBA.Dir(resultsFilePathName) <> vbNullString Then Kill resultsFilePathName
nThreads = 1
For i = 1 To nThreads
strExt = "xls"
XlThreadName = "XlThread_" & VBA.CStr(i)
ExecuteExcelThread "SomeComplexAlgorithm", XlThreadName, XlThreadhsPath
Next i
End Sub
Public Function ExecuteExcelThread(ByVal ProcedureName As String, _
ByVal XlThreadName As String, _
ByVal XlThreadhsPath As String, _
Optional ByVal strExt As String = "xls")
Dim ExcelThreadFilePathName As String
Dim VBScriptFilePathName As String
Dim s As String
' save a copy of current active workbook
ExcelThreadFilePathName = XlThreadhsPath & XlThreadName & "." & strExt
ProcedureName = XlThreadName & "." & strExt & "!" & ProcedureName
' If procedure is Public declared, then it can be called just by: ProcedureName = ProcedureName
VBScriptFilePathName = XlThreadhsPath & XlThreadName & ".vbs"
ActiveWorkbook.SaveCopyAs ExcelThreadFilePathName
' re-open previously saved Excel workbook
s = s & "Set oXLApp = CreateObject(""Excel.Application"")" & vbLf
s = s & "Set oXLWbk = oXLApp.Workbooks.Open(""" & ExcelThreadFilePathName & """)" & vbLf
s = s & "oXLApp.Visible = True" & vbLf
' run target VBA program and close Excel workbook
s = s & "oXLWbk.Application.Run """ & ProcedureName & """" & vbLf
s = s & "oXLApp.ActiveWorkbook.Close True" & vbLf
s = s & "oXLApp.Application.Quit" & vbLf
' delete copies of Excel workbook and VB script
s = s & "CreateObject(""Scripting.FileSystemObject"").DeleteFile (""" & ExcelThreadFilePathName & """)" & vbLf
s = s & "CreateObject(""Scripting.FileSystemObject"").DeleteFile (""" & VBScriptFilePathName & """)" & vbLf
Dim iFileVBS As Integer
iFileVBS = VBA.FreeFile()
Open VBScriptFilePathName For Output Shared As #iFileVBS
Print #iFileVBS, s
Close #iFileVBS
' execute VB script
Dim oWSh As Object
Set oWSh = VBA.CreateObject("WScript.Shell")
oWSh.Run VBScriptFilePathName
Set oWSh = Nothing
End Function
'-------------
Public Sub SomeComplexAlgorithm()
' this is target program to be executed by Excel thread
' program creates N random numbers between 1 and 10, stores these into
' collection and finally prints the content into a specific text file
Dim simulationResult As New Collection
Dim i As Integer
For i = 1 To 25
' due to brevity reasons, we just simulate some time-consuming algorithm
Dim delayTime As Long
delayTime = WorksheetFunction.RandBetween(1, 10)
Sleep delayTime * 1000
' store one simulated result (random delay time) into collection
simulationResult.Add delayTime
Next i
' print result collection into a specific text file
' we have to be prepared for the case in which multiple users (Excel threads)
' are accessing the same specific text file at the same time
recoveryPoint:
On Error GoTo errorHandler
' if the file is in use, error will be thrown below here
Dim iFileOut As Integer
iFileOut = VBA.FreeFile()
Open resultsFilePathName For Append As #iFileOut
For i = 1 To simulationResult.Count
Print #iFileOut, ActiveWorkbook.Name & "=" & VBA.CStr(simulationResult(i))
Next i
Close #iFileOut
Set simulationResult = Nothing
Exit Sub
'
errorHandler:
' get one second delay and re-access text file
Sleep 1000
Resume recoveryPoint
End Sub
Do not overload system with Excel instances
Aside from calling the threads through new Excel instaces, we can get the same effect launching the threads as pure VBScript code. But to achieve this, we need to convert any threadable VBA code to a “string of code”, just to create the VB template procedure awaiting the VBE to send that chunck of code to the VBScript or to be properly run in another independent thread.
So here is my last share, a macro that can load any procedure (or even an entire module), of pure VBA code and get it “stringified”.
Private Function fVBAToString(ByRef aLine() As String) As String
' convert a procedure to VBScript
Dim aTmp() As String
Dim strLine As String
Dim lgLine As Long
Dim lgCode As Long
Dim lgPos As Long
Dim lgComment As Long
Dim bComment As Boolean
' Join multiline
For lgLine = UBound(aLine) To LBound(aLine) + 1 Step -1
strLine = VBA.RTrim$(aLine(lgLine - 1))
If VBA.Right$(strLine, 2) = " _" Then
aLine(lgLine - 1) = VBA.Mid$(strLine, 1, VBA.Len(strLine) - 1) & VBA.Trim$(aLine(lgLine))
aLine(lgLine) = "'¤"
End If
Next lgLine
lgCode = -1
For lgLine = LBound(aLine) To UBound(aLine)
If Not aLine(lgLine) Like "'¤" Then
lgCode = lgCode + 1
ReDim Preserve aTmp(0 To lgCode)
aTmp(lgCode) = aLine(lgLine)
End If
Next lgLine
aLine() = aTmp()
Erase aTmp()
strLine = vbNullString
For lgLine = LBound(aLine) To UBound(aLine)
' In aLine(lgLine), replace ["] chars out of comments
lgComment = 0
bComment = False
lgPos = 1
Do Until lgPos > VBA.Len(aLine(lgLine))
If VBA.Mid$(aLine(lgLine), lgPos, 1) = """" Then
aLine(lgLine) = VBA.Mid$(aLine(lgLine), 1, lgPos) _
& """" _
& VBA.Mid$(aLine(lgLine), lgPos + 1)
lgPos = lgPos + 1
If Not bComment Then
lgComment = lgComment + 1
'If (lgComment - 1) Mod 2 = 0 Then
' Opens comment ... whatever is next is comment
'Else
' Closes comment ... whatever is next is code
'End If
End If
ElseIf VBA.Mid$(aLine(lgLine), lgPos, 1) = "'" Then
If lgComment Mod 2 = 0 Then
' Opens comment ... whatever is next is comment
bComment = True
End If
End If
lgPos = lgPos + 1
Loop
aLine(lgLine) = """" & aLine(lgLine) & """"
Next lgLine
fVBAToString = " s = s & " & VBA.Join(aLine, " & vbCrLf" & vbCrLf & " s = s & ")
End Function