Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- 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 = "<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
- ' 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 = "<span style='width: 200px;'>" & arrUrls(i) & "</span>"
- ' make ping
- Ping arrUrls(i), sIp, sRt
- ' output result
- If sRt = "" Then
- objNode.innerHTML = objNode.innerHTML & "<span style='color: red;'>n/a</span>"
- 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, "<tr id=""")
- 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
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
