test_mproclite_top_50_ping.vbs

Option Explicit
Launch "Main"

' main programm section

Sub Main()

    Dim arrUrls, objWnd, lWidth, lHeight, i, objNode, j

    ' create window for output
    Set objWnd = CreateWindow()
    ' set up window
    With objWnd
        With .Document
            .GetElementsByTagName("head")(0).AppendChild .CreateElement("style")
            .stylesheets(0).cssText = "body, #output {font-family: consolas, courier new; font-size: 9pt;} body {background-color: buttonface;} #output {height: 100%; width: 100%; overflow: scroll; background: #FFF;}"
            .Title = "similarweb.com Top 50 Pings"
            .Body.InnerHtml = "<div id='output'></div>"
        End With
        lWidth = CInt(.Screen.AvailWidth * 0.75)
        lHeight = CInt(.Screen.AvailHeight * 0.75)
        .ResizeTo .Screen.AvailWidth, .Screen.AvailHeight
        .ResizeTo lWidth + .Screen.AvailWidth - .Document.Body.OffsetWidth, lHeight + .Screen.AvailHeight - .Document.Body.OffsetHeight
        .MoveTo CInt((.Screen.AvailWidth - lWidth) / 2), CInt((.Screen.AvailHeight - lHeight) / 2)
    End With
    ' get top 50 websites urls array from similarweb.com
    arrUrls = GetTopSites()
    ' create divs in window document, put urls into divs, add to array divs object where to output results
    For i = 1 To UBound(arrUrls)
        Set objNode = objWnd.Document.CreateElement("div")
        objNode.innerHTML = "<span style='width: 200px;'>" & arrUrls(i) & "</span>"
        objWnd.output.AppendChild objNode
        arrUrls(i) = Array(objNode, arrUrls(i))
    Next
    ' launch separate procs to ping urls
    For i = 1 To 15
        CreateProc "CheckPing"
    Next
    ' wait procs until initialized
    Joint "CheckPing", 4, 0
    ' ping each url
    For i = 1 To UBound(arrUrls)
    ' For i = UBound(arrUrls) To 0 Step -1
        Do
            If TypeName(objWnd) = "Object" Then Exit For ' window closed
            ' find not busy proc
            For j = 1 To Jobs.Count - 1
                Select Case True
                    Case Jobs(j).SubName <> "CheckPing"
                    Case Jobs(j).Busy
                    Case Else
                        ' push task to proc
                        Set Jobs(j).Node = arrUrls(i)(0)
                        Jobs(j).Url = arrUrls(i)(1)
                        Jobs(j).Busy = True
                        Exit Do
                End Select
            Next
            WScript.Sleep 1
        Loop
    Next
    ' release all ping procs
    Free "CheckPing"
    ' wait procs until terminated
    Joint "CheckPing", 64, 0
    ' release main sub procs
    Free Id
End sub

Sub CheckPing()
    Dim Ip, Rt
    NewVar "Url"
    NewVar "Node"
    NewVar "Busy"
    Busy = False
    On Error Resume Next
    Do
        ' wait until task is received
        Do Until Busy Or Release
            WScript.Sleep 1
        Loop
        If Release Then Exit Do ' all urls pings are completed
        ' make ping
        Ping Url, Ip, Rt
        ' output result
        If Rt = "" Then
            Node.innerHTML = Node.innerHTML & "<span style='color: red;'>n/a</span>"
        Else
            Node.innerHTML = Node.innerHTML & "IP " & Ip & ", Ping " & Rt & " msec"
        End If
        If Err.Number <> 0 Then ' window closed
            Release = True
            Exit Do
        End If
        Busy = False
    Loop
End Sub

Function GetTopSites()
    Dim arrUrls, i
    ' request rating from similarweb
    With CreateObject("Msxml2.ServerXMLHTTP.6.0")
        .SetOption 2, 13056 ' SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS
        .Open "GET", "https://www.similarweb.com/top-websites", False
        .Send
        ' parse response to array
        arrUrls = Split(.ResponseText, "data-shorturl=""")
    End With
    For i = 1 To UBound(arrUrls)
        arrUrls(i) = Split(arrUrls(i), """", 2)(0)
    Next
    GetTopSites = arrUrls
End Function

Function CreateWindow()
    ' source http://forum.script-coding.com/viewtopic.php?pid=75356#p75356
    Dim sSignature, oShellWnd, oProc
    On Error Resume Next
    sSignature = Left(CreateObject("Scriptlet.TypeLib").Guid, 38)
    Do
        Set oProc = CreateObject("WScript.Shell").Exec("mshta about:""about:<head><script>moveTo(-32000,-32000);document.title=' '</script><hta:application id=app border=thick minimizebutton=no maximizebutton=no scroll=no showintaskbar=yes contextmenu=no selection=yes innerborder=no icon=""""/><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & sSignature & "',document.parentWindow);</script></head>""")
        Do
            If oProc.Status > 0 Then Exit Do
            For Each oShellWnd In CreateObject("Shell.Application").Windows
                Set CreateWindow = oShellWnd.GetProperty(sSignature)
                If Err.Number = 0 Then Exit Function
                Err.Clear
            Next
        Loop
    Loop
End Function

Sub Ping(strUrl, strProtocolAddress, lngResponseTime)
    Dim objStatus
    For Each objStatus In GetObject("winmgmts:\\.\root\cimv2").ExecQuery("Select * From Win32_PingStatus Where Address = '" & strUrl & "'")
        Select Case True
            Case IsNull(objStatus.StatusCode)
            Case objStatus.StatusCode <> 0
            Case Else
                strProtocolAddress = objStatus.ProtocolAddress
                lngResponseTime = objStatus.ResponseTime
        End Select
    Next
End Sub

' do not modify service section

sub launch(byval destination)
    dim job
    executeglobal "dim scene, container, signature, subname, jobs, id, state, release"
    release = false
    if not wscript.arguments.named.exists("task") then
        dim elt
        executeglobal "dim found, lost"
        id = 0
        found = 0
        lost = 0
        signature = ""
        randomize
        do
            signature = signature & hex(rnd * 16)
        loop while len(signature) < 16
        set scene = me
        set jobs = createobject("Scripting.Dictionary")
        set jobs(0) = scene
        set container = getobject("new:{C08AFD90-F2A1-11D1-8455-00A0C91F3880}")
        container.putproperty signature, scene
        startproc destination
        on error resume next
        do until (lost >= found) or release
            for elt = found to 1 step -1
                if typename(jobs(elt)) = "Object" then
                    lost = lost + 1
                    jobs(elt) = empty
                end if
                err.clear
                wscript.sleep 1
            next
        loop
        release = true
        executeglobal "scene_beforeterminate"
        for elt = found to 1 step -1
            if typename(jobs(elt)) = "VBScriptTypeInfo" then
                jobs(elt).wscript.timeout = 1
                jobs(elt).wscript.quit
                err.clear
                nojobs = false
            end if
            wscript.sleep 1
        next
        container.quit
        createobject("wscript.shell").popup "scenequit", 1, "primary", 64
    else
        job = split(wscript.arguments.named("task"), ";")
        signature = cstr(job(0))
        id = clng(job(1))
        subname = cstr(job(2))
        do
            for each container in createobject("Shell.Application").windows
                if isobject(container.getproperty(signature)) then
                    exit do
                end if
            next
            wscript.sleep 1
        loop
        set scene = container.getproperty(signature)
        set jobs = scene.jobs
        set jobs(id) = me
        state = 4
        executeglobal subname
        state = 24
        do until release
            wscript.sleep 10
        loop
        state = 28
    end if
end sub

function startproc(subname)
    startproc = createproc(subname)
    joint startproc, 4, 0
    REM do while getstate(startproc) < 4
        REM wscript.sleep 10
    REM loop
end function

function createproc(subname)
    if me is scene then
        if not release then
            found = found + 1
            createproc = found
            set jobs(createproc) = nothing
            createobject("WScript.Shell").exec("""" & wscript.fullname & """ """ & wscript.scriptfullname & """ ""/task:" & join(array(signature, createproc, subname), ";") & """")
        end if
    else
        createproc = scene.createproc(subname)
    end if
end function

function getjob(target)
    on error resume next
    if jobs.exists(target) then
        set getjob = jobs(target)
        if err.number = 0 then exit function
        err.clear
    end if
    set getjob = nothing
end function

sub share(varname, value)
    scene.newvar varname
    if isobject(value) then
        execute "set scene." & varname & " = value"
    else
        execute "scene." & varname & " = value"
    end if
end sub

sub newvar(varname)
    executecommand "dim " & varname
end sub

sub executecommand(command)
    executeglobal command
end sub

function getstate(target)
    dim elt
    if jobs.exists(target) then
        on error resume next
        set elt = jobs(target)
        getstate = elt.state
        if err.number <> 0 then
            if not(elt is nothing) then
                getstate = 64
            else
                getstate = 1
            end if
        end if
        set elt = nothing
    else
        getstate = 64
    end if
end function

function isresponsive(target)
    isresponsive = cbool(getstate(target) and 28)
end function

sub free(target)
    if jobs.exists(target) then
        on error resume next
        jobs(target).release = true
    else
        dim elt
        for elt = scene.found to 1 step -1
            on error resume next
            if jobs(elt).subname = target then
                free jobs(elt).id
            end if
            err.clear
        next
    end if
end sub

function joint(target, state, timeout)
    dim reftime
    reftime = timer
    on error resume next
    if isnumeric(target) then
        if jobs.exists(target) then
            do while getstate(target) < state
                if timeisout(timeout, reftime) then
                    joint = false
                    exit function
                end if
                wscript.sleep 10
            loop
        end if
    else
        dim elt
        for elt = scene.found to 1 step -1
            err.clear
            if jobs(elt).subname = target then
                do while getstate(elt) < state
                    if timeisout(timeout, reftime) then
                        joint = false
                        exit function
                    end if
                    wscript.sleep 10
                loop
            end if
            err.clear
        next
    end if
    joint = true
end function

function timeisout(timeout, reftime)
    if timeout > 0 then
        dim delta
        delta = timer - reftime
        if delta < 0 then delta = delta + 86400
        if delta > timeout then
            timeisout = true
        end if
    else
        timeisout = false
    end if
end function

sub interrupt(target, timeout)
    if jobs.exists(target) then
        on error resume next
        jobs(target).wscript.timeout = timeout
        jobs(target).wscript.quit
    else
        dim elt, subname
        for elt = scene.found to 1 step -1
            on error resume next
            subname = jobs(elt).subname
            if subname = target then
                interrupt jobs(elt).id
            end if
            err.clear
        next
    end if
end sub

sub push(name, value)
    container.putproperty name, value
end sub

function pop(name)
    on error resume next
    if isobject(container.getproperty(name)) then
        set pop = container.getproperty(name)
    else
        pop = container.getproperty(name)
    end if
end function