Option Explicit
Main
Sub Main()
Dim arrUrls, objWnd, lWidth, lHeight, i, objNode, j, sIp, sRt
' get top 50 websites urls array from similarweb.com
arrUrls = GetTopSites()
' 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 = ""
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
' ping each url, create divs in window document, output results
On Error Resume Next
For i = 1 To UBound(arrUrls)
' create div
Set objNode = objWnd.Document.CreateElement("div")
objWnd.output.AppendChild objNode
objNode.innerHTML = "" & arrUrls(i) & ""
' make ping
Ping arrUrls(i), sIp, sRt
' output result
If sRt = "" Then
objNode.innerHTML = objNode.innerHTML & "n/a"
Else
objNode.innerHTML = objNode.innerHTML & sIp & " " & sRt & " msec"
End If
If TypeName(objWnd) = "Object" Then Exit For ' window closed
Next
End sub
Function GetTopSites()
Dim arrUrls, i
' request rating from similarweb
With CreateObject("Msxml2.ServerXMLHTTP.3.0")
.SetOption 2, 13056 ' SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS
.Open "GET", "https://www.similarweb.com/global", False
.Send
' parse response to array
arrUrls = Split(.ResponseText, "
""")
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