I am trying to consume a web service in VB6. The service - which I control - currently can return a SOAP/XML message or JSON. I am having a really difficult time figuring out if VB6's SOAP type (version 1) can handle a returned object - as opposed to simple types like string, int, etc. So far I cannot figure out what I need to do to get VB6 to play with returned objects.
So I thought I might serialize the response in the web service as a JSON string. Does a JSON parser exist for VB6?
Check out JSON.org for an up-to-date list (see bottom of main page) of JSON parsers in many different languages. As of the time of this writing, you'll see a link to several different JSON parsers there, but only one is for VB6/VBA (the others are .NET):
VB-JSON
When I tried to download the zip file, Windows said the data was corrupt. However, I was able to use 7-zip to pull the files out. It turns out that the main "folder" in the zip file isn't recognized as a folder by Windows, by 7-zip can see the contents of that main "folder," so you can open that up and then extract the files accordingly.
The actual syntax for this VB JSON library is really simple:
Dim p As Object
Set p = JSON.parse(strFormattedJSON)
'Print the text of a nested property '
Debug.Print p.Item("AddressClassification").Item("Description")
'Print the text of a property within an array '
Debug.Print p.Item("Candidates")(4).Item("ZipCode")
Note: I had to add the "Microsoft Scripting Runtime" and "Microsoft ActiveX Data Objects 2.8" library as references via Tools > References in the VBA editor.
Note: VBJSON code is actually based on a google code project vba-json. However, VBJSON promises several bug fixes from the original version.
Building on ozmike solution, which did not work for me (Excel 2013 and IE10).
The reason is that I could not call the methods on the exposed JSON object.
So its methods are now exposed through functions attached to a DOMElement.
Didn't know this is possible (must be that IDispatch-thing), thank you ozmike.
As ozmike stated, no 3rd-party libs, just 30 lines of code.
Option Explicit
Public JSON As Object
Private ie As Object
Public Sub initJson()
Dim html As String
html = "<!DOCTYPE html><head><script>" & _
"Object.prototype.getItem=function( key ) { return this[key] }; " & _
"Object.prototype.setItem=function( key, value ) { this[key]=value }; " & _
"Object.prototype.getKeys=function( dummy ) { keys=[]; for (var key in this) if (typeof(this[key]) !== 'function') keys.push(key); return keys; }; " & _
"window.onload = function() { " & _
"document.body.parse = function(json) { return JSON.parse(json); }; " & _
"document.body.stringify = function(obj, space) { return JSON.stringify(obj, null, space); }" & _
"}" & _
"</script></head><html><body id='JSONElem'></body></html>"
Set ie = CreateObject("InternetExplorer.Application")
With ie
.navigate "about:blank"
Do While .Busy: DoEvents: Loop
Do While .readyState <> 4: DoEvents: Loop
.Visible = False
.document.Write html
.document.Close
End With
' This is the body element, we call it JSON:)
Set JSON = ie.document.getElementById("JSONElem")
End Sub
Public Function closeJSON()
ie.Quit
End Function
The following test constructs a JavaScript Object from scratch, then stringifies it.
Then it parses the object back and iterates over its keys.
Sub testJson()
Call initJson
Dim jsObj As Object
Dim jsArray As Object
Debug.Print "Construction JS object ..."
Set jsObj = JSON.Parse("{}")
Call jsObj.setItem("a", 1)
Set jsArray = JSON.Parse("[]")
Call jsArray.setItem(0, 13)
Call jsArray.setItem(1, Math.Sqr(2))
Call jsArray.setItem(2, 15)
Call jsObj.setItem("b", jsArray)
Debug.Print "Object: " & JSON.stringify(jsObj, 4)
Debug.Print "Parsing JS object ..."
Set jsObj = JSON.Parse("{""a"":1,""b"":[13,1.4142135623730951,15]}")
Debug.Print "a: " & jsObj.getItem("a")
Set jsArray = jsObj.getItem("b")
Debug.Print "Length of b: " & jsArray.getItem("length")
Debug.Print "Second element of b: "; jsArray.getItem(1)
Debug.Print "Iterate over all keys ..."
Dim keys As Object
Set keys = jsObj.getKeys("all")
Dim i As Integer
For i = 0 To keys.getItem("length") - 1
Debug.Print keys.getItem(i) & ": " & jsObj.getItem(keys.getItem(i))
Next i
Call closeJSON
End Sub
outputs
Construction JS object ...
Object: {
"a": 1,
"b": [
13,
1.4142135623730951,
15
]
}
Parsing JS object ...
a: 1
Length of b: 3
Second element of b: 1,4142135623731
Iterate over all keys ...
a: 1
b: 13,1.4142135623730951,15
As Json is nothing but strings so it can easily be handled if we can manipulate it the right way, no matter how complex the structure is. I don't think it is necessary to use any external library or converter to do the trick. Here is an example where I've parsed json data using string manipulation.
Sub GetJsonContent()
Dim http As New XMLHTTP60, itm As Variant
With http
.Open "GET", "http://jsonplaceholder.typicode.com/users", False
.send
itm = Split(.responseText, "id"":")
End With
x = UBound(itm)
For y = 1 To x
Cells(y, 1) = Split(Split(itm(y), "name"": """)(1), """")(0)
Cells(y, 2) = Split(Split(itm(y), "username"": """)(1), """")(0)
Cells(y, 3) = Split(Split(itm(y), "email"": """)(1), """")(0)
Cells(y, 4) = Split(Split(itm(y), "street"": """)(1), """")(0)
Next y
End Sub
Hopefully this will be a big help to others who keep on coming to this page after searching for "vba json".
I found this page to be very helpful. It provides several Excel-compatible VBA classes that deal with processing data in JSON format.
VBA-JSON by Tim Hall, MIT licensed and on GitHub. It's another fork of vba-json that emerged end of 2014. Claims to work on Mac Office and Windows 32bit and 64bit.
UPDATE: Found a safer way of parsing JSON than using Eval, this blog post shows the dangers of Eval ... http://exceldevelopmentplatform.blogspot.com/2018/01/vba-parse-json-safer-with-jsonparse-and.html
Late to this party but sorry guys but by far the easiest way is to use Microsoft Script Control. Some sample code which uses VBA.CallByName to drill in
'Tools->References->
'Microsoft Script Control 1.0; {0E59F1D2-1FBE-11D0-8FF2-00A0D10038BC}; C:\Windows\SysWOW64\msscript.ocx
Private Sub TestJSONParsingWithCallByName()
Dim oScriptEngine As ScriptControl
Set oScriptEngine = New ScriptControl
oScriptEngine.Language = "JScript"
Dim sJsonString As String
sJsonString = "{'key1': 'value1' ,'key2': { 'key3': 'value3' } }"
Dim objJSON As Object
Set objJSON = oScriptEngine.Eval("(" + sJsonString + ")")
Debug.Assert VBA.CallByName(objJSON, "key1", VbGet) = "value1"
Debug.Assert VBA.CallByName(VBA.CallByName(objJSON, "key2", VbGet), "key3", VbGet) = "value3"
End Sub
I have actually done a series of Q&As which explore JSON/VBA related topics.
Q1 In Excel VBA on Windows, how to mitigate issue of dot syntax traversal of parsed JSON broken by IDE's capitalisation behaviour?
Q2 In Excel VBA on Windows, how to loop through a JSON array parsed?
Q3 In Excel VBA on Windows, how to get stringified JSON respresentation instead of “[object Object]” for parsed JSON variables?
Q4 In Windows Excel VBA,how to get JSON keys to pre-empt “Run-time error '438': Object doesn't support this property or method”?
Q5 In Excel VBA on Windows, for parsed JSON variables what is this JScriptTypeInfo anyway?
Here is a "Native" VB JSON library.
It is possible to use JSON that is already in IE8+. This way your not dependent on a third party library that gets out of date and is untested.
see amedeus' alternative version here
Sub myJSONtest()
Dim oJson As Object
Set oJson = oIE_JSON() ' See below gets IE.JSON object
' using json objects
Debug.Print oJson.parse("{ ""hello"": ""world"" }").hello ' world
Debug.Print oJson.stringify(oJson.parse("{ ""hello"": ""world"" }")) ' {"hello":"world"}
' getting items
Debug.Print oJson.parse("{ ""key1"": ""value1"" }").key1 ' value1
Debug.Print oJson.parse("{ ""key1"": ""value1"" }").itemGet("key1") ' value1
Debug.Print oJson.parse("[ 1234, 4567]").itemGet(1) ' 4567
' change properties
Dim o As Object
Set o = oJson.parse("{ ""key1"": ""value1"" }")
o.propSetStr "key1", "value\""2"
Debug.Print o.itemGet("key1") ' value\"2
Debug.Print oJson.stringify(o) ' {"key1":"value\\\"2"}
o.propSetNum "key1", 123
Debug.Print o.itemGet("key1") ' 123
Debug.Print oJson.stringify(o) ' {"key1":123}
' add properties
o.propSetNum "newkey", 123 ' addkey! JS MAGIC
Debug.Print o.itemGet("newkey") ' 123
Debug.Print oJson.stringify(o) ' {"key1":123,"newkey":123}
' assign JSON 'objects' to properties
Dim o2 As Object
Set o2 = oJson.parse("{ ""object2"": ""object2value"" }")
o.propSetJSON "newkey", oJson.stringify(o2) ' set object
Debug.Print oJson.stringify(o) ' {"key1":123,"newkey":{"object2":"object2value"}}
Debug.Print o.itemGet("newkey").itemGet("object2") ' object2value
' change array items
Set o = oJson.parse("[ 1234, 4567]") '
Debug.Print oJson.stringify(o) ' [1234,4567]
Debug.Print o.itemGet(1)
o.itemSetStr 1, "234"
Debug.Print o.itemGet(1)
Debug.Print oJson.stringify(o) ' [1234,"234"]
o.itemSetNum 1, 234
Debug.Print o.itemGet(1)
Debug.Print oJson.stringify(o) ' [1234,234]
' add array items
o.itemSetNum 5, 234 ' add items! JS Magic
Debug.Print o.itemGet(5) ' 234
Debug.Print oJson.stringify(o) ' [1234,234,null,null,null,234]
' assign JSON object to array item
o.itemSetJSON 3, oJson.stringify(o2) ' assign object
Debug.Print o.itemGet(3) '[object Object]
Debug.Print oJson.stringify(o.itemGet(3)) ' {"object2":"object2value"}
Debug.Print oJson.stringify(o) ' [1234,234,null,{"object2":"object2value"},null,234]
oIE_JSON_Quit ' quit IE, must shut down or the IE sessions remain.
Debug.Print oJson.stringify(o) ' can use after but but IE server will shutdown... soon
End Sub
You can bridge to IE.JSON from VB.
Create a function oIE_JSON
Public g_IE As Object ' global
Public Function oIE_JSON() As Object
' for array access o.itemGet(0) o.itemGet("key1")
JSON_COM_extentions = "" & _
" Object.prototype.itemGet =function( i ) { return this[i] } ; " & _
" Object.prototype.propSetStr =function( prop , val ) { eval('this.' + prop + ' = ""' + protectDoubleQuotes (val) + '""' ) } ; " & _
" Object.prototype.propSetNum =function( prop , val ) { eval('this.' + prop + ' = ' + val + '') } ; " & _
" Object.prototype.propSetJSON =function( prop , val ) { eval('this.' + prop + ' = ' + val + '') } ; " & _
" Object.prototype.itemSetStr =function( prop , val ) { eval('this[' + prop + '] = ""' + protectDoubleQuotes (val) + '""' ) } ; " & _
" Object.prototype.itemSetNum =function( prop , val ) { eval('this[' + prop + '] = ' + val ) } ; " & _
" Object.prototype.itemSetJSON =function( prop , val ) { eval('this[' + prop + '] = ' + val ) } ; " & _
" function protectDoubleQuotes (str) { return str.replace(/\\/g, '\\\\').replace(/""/g,'\\""'); }"
' document.parentwindow.eval dosen't work some versions of ie eg ie10?
IEEvalworkaroundjs = "" & _
" function IEEvalWorkAroundInit () { " & _
" var x=document.getElementById(""myIEEvalWorkAround"");" & _
" x.IEEval= function( s ) { return eval(s) } ; } ;"
g_JS_framework = "" & _
JSON_COM_extentions & _
IEEvalworkaroundjs
' need IE8 and DOC type
g_JS_HTML = "<!DOCTYPE html> " & _
" <script>" & g_JS_framework & _
"</script>" & _
" <body>" & _
"<script id=""myIEEvalWorkAround"" onclick=""IEEvalWorkAroundInit()"" ></script> " & _
" HEllo</body>"
On Error GoTo error_handler
' Create InternetExplorer Object
Set g_IE = CreateObject("InternetExplorer.Application")
With g_IE
.navigate "about:blank"
Do While .Busy: DoEvents: Loop
Do While .ReadyState <> 4: DoEvents: Loop
.Visible = False ' control IE interface window
.Document.Write g_JS_HTML
End With
Set objID = g_IE.Document.getElementById("myIEEvalWorkAround")
objID.Click ' create eval
Dim oJson As Object
'Set oJson = g_IE.Document.parentWindow.Eval("JSON") ' dosen't work some versions of IE
Set oJson = objID.IEEval("JSON")
Set objID = Nothing
Set oIE_JSON = oJson
Exit Function
error_handler:
MsgBox ("Unexpected Error, I'm quitting. " & Err.Description & ". " & Err.Number)
g_IE.Quit
Set g_IE = Nothing
End Function
Public Function oIE_JSON_Quit()
g_IE.Quit
Exit Function
End Function
Up vote if you find useful
VB6 - JsonBag, Another JSON Parser/Generator should also be importable into VBA with little trouble.
I would suggest using a .Net component. You can use .Net components from VB6 via Interop - here's a tutorial. My guess is that .Net components will be more reliable and better supported than anything produced for VB6.
There are components in the Microsoft .Net framework like DataContractJsonSerializer or JavaScriptSerializer. You could also use third party libraries like JSON.NET.
You could write an Excel-DNA Add-in in VB.NET. Excel-DNA is a thin library that lets you write XLLs in .NET. This way you get access to the entire .NET universe and can use stuff like http://james.newtonking.com/json - a JSON framework that deserializes JSON in any custom class.
If you are interested, here's a write up of how to build a generic Excel JSON client for Excel using VB.NET:
http://optionexplicitvba.com/2014/05/09/developing-a-json-excel-add-in-with-vb-net/
And here's the link to the code: https://github.com/spreadgit/excel-json-client/blob/master/excel-json-client.dna
Understand this is an old post, but I recently stumbled upon it while adding web service consumption to an old VB6 app. The accepted answer (VB-JSON) is still valid and appears to work. However, I discovered that Chilkat has been updated to include REST and JSON functionality, making it a one-stop (though paid) tool for me. They even have an online code generator that generates the code to parse pasted JSON data.
JsonObject link
Code Generator link
Whether you need it for VB6, VBA, VB.NET, C#, Delphi or pretty much any other programming language on the Windows platform, check JSON Essentials. Its capabilities go well beyond just parsing and querying JSON. Using JSON Essentials you can serialize objects into JSON, make JSON HTTP calls and get parsed JSON DOM in response if you need it, re-formatting JSON, using files, registry, memory streams, or HTTP/HTTPS for writing and loading JSON data in UTF-8/16/32 and ASCII/EASCII encodings, and it comes with JSON Schema support. On top of that it's exceptionally fast, stable, standard compliant, being actively developed and supported. And it has a free license too.
Here are some quick samples, the first one shows how to parse and query JSON:
' Create JSON document object.
Dim document As JsonDocument
Set document = New JsonDocument
' Parse JSON.
document.parse "{""a"":true,""b"":123,""c"":{},""d"":[""abc""]}"
' Select the first node of the 'd' node using JSON Pointer
' starting from the root document node.
Dim node_abc As IJsonNode
Set node_abc = document.root.select("/d/0")
' Select node 'a' starting from the previously selected
' first child node of node 'd' and traversing first up to
' the root node and then down to node 'a' using Relative
' JSON Pointer.
Dim node_a As IJsonNode
Set node_a = node_abc.select("rel:2/a")
The next one is about saving/loading a file:
' Load JSON from a UTF-16 file in the current directory
document.load "file://test.json", "utf-16"
' Save document to the current directory using UTF-8 encoding.
document.save "file://test.json", "utf-8"
That's how simple to make an HTTP JSON request using JSON Essentials:
' Load document from HTTP response.
Dim status As IJsonStatus
Set status = document.load("http://postman-echo.com/get")
And that's how to make complex HTTP JSON requests and and parse JSON responses:
' Create and fill a new document model object.
Dim model As SomeDocumentModel
Set model = New SomeDocumentModel
model.a = True
model.b = 123
Set model.c = New EmptyDocumentModel
model.d = Array("abc")
' Load JSON data from a document model object.
document.load model
Dim request As String
' Specify HTTP method explicitly.
request = "json://{" + _
"""method"" : ""PUT"","
' Add custom HTTP query parameters.
request = request + _
"""query"" : {" + _
"""a"" : ""#a""," + _
"""b"" : ""#b""," + _
"""c"" : ""#c""" + _
"},"
' Add custom HTTP form data parameters.
request = request + _
"""form"" : {" + _
"""d"" : ""#d""," + _
"""e"" : ""#e""," + _
"""f"" : ""#f""" + _
"},"
' Add custom HTTP headers.
request = request + _
"""form"" : {" + _
"""a"" : ""#1""," + _
"""b"" : ""#2""," + _
"""c"" : ""#3""" + _
"},"
' Override default TCP timeouts.
request = request + _
"""timeouts"" : {" + _
"""connect"" : 5000," + _
"""resolve"" : 5000," + _
"""send"" : 5000," + _
"""receive"" : 5000" + _
"},"
' Require response JSON document to contains HTTP response status code,
' HTTP response headers and HTTP response body nested as JSON.
request = request + _
"""response"" : {" + _
"""status"" : true," + _
"""headers"" : true," + _
"""body"" : ""json""" + _
"}" + _
"}"
' Save JSON document to the specified endpoint as HTTP PUT request
' that is encoded in UTF-8.
Dim status As IJsonStatus
Set status = document.save("http://postman-echo.com/put", "utf-8", request)
' Print JSON data of the parsed JSON response
Debug.Print status.response.json
And finally here's how to create a JSON Schema and perform JSON document validation:
' Create schema JSON document object.
Dim schemaDoc As JsonDocument
Set schemaDoc = New JsonDocument
' Load JSON schema that requires a node to be an array of numeric values.
schemaDoc.parse _
"{" + _
"""$id"": ""json:numeric_array""," + _
"""type"": ""array""," + _
"""items"": {" + _
"""type"": ""number""" + _
"}" + _
"}"
' Create schema collection and add the schema document to it.
Dim schemas As JsonSchemas
Set schemas = New JsonSchemas
Dim schema As IJsonSchema
Set schema = schemas.Add(schemaDoc, "json:numeric_array")
' Create JSON document object.
Dim instanceDoc As JsonDocument
Set instanceDoc = New JsonDocument
' Load JSON, an array of numeric values that is expected to
' satisfy schema requirements.
instanceDoc.load Array(0, 1, 2)
' Validate JSON instance document against the added schema.
Dim status As IJsonStatus
Set status = schema.validate(instanceDoc)
' Ensure the validation passed successfully.
Debug.Print IIf(status.success, "Validated", "Not-validated")
Using JavaScript features of parsing JSON, on top of ScriptControl, we can create a parser in VBA which will list each and every data point inside the JSON. No matter how nested or complex the data structure is, as long as we provide a valid JSON, this parser will return a complete tree structure.
JavaScript’s Eval, getKeys and getProperty methods provide building blocks for validating and reading JSON.
Coupled with a recursive function in VBA we can iterate through all the keys (up to nth level) in a JSON string. Then using a Tree control (used in this article) or a dictionary or even on a simple worksheet, we can arrange the JSON data as required.
Full VBA Code here.Using JavaScript features of parsing JSON, on top of ScriptControl, we can create a parser in VBA which will list each and every data point inside the JSON. No matter how nested or complex the data structure is, as long as we provide a valid JSON, this parser will return a complete tree structure.
JavaScript’s Eval, getKeys and getProperty methods provide building blocks for validating and reading JSON.
Coupled with a recursive function in VBA we can iterate through all the keys (up to nth level) in a JSON string. Then using a Tree control (used in this article) or a dictionary or even on a simple worksheet, we can arrange the JSON data as required.
Full VBA Code here.
Formula in an EXCEL CELL
=JSON2("{mykey:1111, mykey2:{keyinternal1:22.1,keyinternal2:22.2}, mykey3:3333}", "mykey2", "keyinternal2")
DISPLAYS: 22.2
=JSON("{mykey:1111,mykey2:2222,mykey3:3333}", "mykey2")
DISPLAYS: 2222
INSTRUCTIONS:
Step1. press ALT+F11
Step2. Insert -> Module
Step3. tools -> references -> tick Microsoft Script Control 1.0
Step4. paste this below.
Step5. ALT+Q close VBA window.
Tools -> References -> Microsoft Script Control 1.0; {0E59F1D2-1FBE-11D0-8FF2-00A0D10038BC}; C:\Windows\SysWOW64\msscript.ocx
Public Function JSON(sJsonString As String, Key As String) As String
On Error GoTo err_handler
Dim oScriptEngine As ScriptControl
Set oScriptEngine = New ScriptControl
oScriptEngine.Language = "JScript"
Dim objJSON As Object
Set objJSON = oScriptEngine.Eval("(" + sJsonString + ")")
JSON = VBA.CallByName(objJSON, Key, VbGet)
Err_Exit:
Exit Function
err_handler:
JSON = "Error: " & Err.Description
Resume Err_Exit
End Function
Public Function JSON2(sJsonString As String, Key1 As String, Key2 As String) As String
On Error GoTo err_handler
Dim oScriptEngine As ScriptControl
Set oScriptEngine = New ScriptControl
oScriptEngine.Language = "JScript"
Dim objJSON As Object
Set objJSON = oScriptEngine.Eval("(" + sJsonString + ")")
JSON2 = VBA.CallByName(VBA.CallByName(objJSON, Key1, VbGet), Key2, VbGet)
Err_Exit:
Exit Function
err_handler:
JSON2 = "Error: " & Err.Description
Resume Err_Exit
End Function
this is vb6 example code, tested ok,works done
from the above good examples, i made changes and got this good result
it can read keys {} and arrays []
Option Explicit
'in vb6 click "Tools"->"References" then
'check the box "Microsoft Script Control 1.0";
Dim oScriptEngine As New ScriptControl
Dim objJSON As Object
''to use it
Private Sub Command1_Click()
Dim json$
json="{'key1': 'value1' ,'key2': { 'key3': 'value3' } }"
MsgBox JsonGet("key1", json) 'result = value1
json="{'key1': 'value1' ,'key2': { 'key3': 'value3' } }"
MsgBox JsonGet("key2.key3",json ) 'result = value3
json="{'result':[{'Bid':0.00004718,'Ask':0.00004799}]}"
MsgBox JsonGet("result.0.Ask", json) 'result = 0.00004799
json="{key1:1111, key2:{k1: 2222 , k2: 3333}, key3:4444}"
MsgBox JsonGet("key2.k1", json) 'result = 2222
json="{'usd_rur':{'bids':[[1111,2222],[3333,4444]]}}"
MsgBox JsonGet("usd_rur.bids.0.0", json) 'result = 1111
MsgBox JsonGet("usd_rur.bids.0.1", json) 'result = 2222
MsgBox JsonGet("usd_rur.bids.1.0", json) 'result = 3333
MsgBox JsonGet("usd_rur.bids.1.1", json) 'result = 4444
End Sub
Public Function JsonGet(eKey$, eJsonString$, Optional eDlim$ = ".") As String
Dim tmp$()
Static sJsonString$
On Error GoTo err
If Trim(eKey$) = "" Or Trim(eJsonString$) = "" Then Exit Function
If sJsonString <> eJsonString Then
sJsonString = eJsonString
oScriptEngine.Language = "JScript"
Set objJSON = oScriptEngine.Eval("(" + eJsonString + ")")
End If
tmp = Split(eKey, eDlim)
If UBound(tmp) = 0 Then JsonGet = VBA.CallByName(objJSON, eKey, VbGet): Exit Function
Dim i&, o As Object
Set o = objJSON
For i = 0 To UBound(tmp) - 1
Set o = VBA.CallByName(o, tmp(i), VbGet)
Next i
JsonGet = VBA.CallByName(o, tmp(i), VbGet)
Set o = Nothing
err: 'if key not found, result = "" empty string
End Function
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Set objJSON = Nothing
Set oScriptEngine = Nothing
End Sub
Here is a new one: [VB6/VBA] JSON parsing to built-in VBA.Collections with JSON Path support
It's a single self-contained module (no classes), parses JSON to nested built-in Collections (fast and lean) and supports practical subset of JSON Path (aka XPath for JSON) to retrieve values.
This means that there is no need to madly nest Item calls like
oJson.Item("first").Item("second").Item("array").Item(0)`
. . . but to access nested values can just use a single call to
JsonValue(oJson, "$.first.second.array[0]")
. . . and retrieve data from as deep in the hierarchy as needed.
Related
Using Excel VBA, i have to scrape some data from this website.
Since the relevant website objects dont contain an id, I cannot use HTML.Document.GetElementById.
However, I noticed that the relevant information is always stored in a <div>-section like the following:
<div style="padding:7px 12px">Basler Versicherung AG Özmen</div>
Question:
Is it possible to construct a RegExp that, probably in a Loop, returns the contents inside <div style="padding:7px 12px"> and the next </div>?
What I have so far is the complete InnerHtml of the container, obviously I need to add some code to loop over the yet-to-be-constructed RegExp.
Private Function GetInnerHTML(url As String) As String
Dim i As Long
Dim Doc As Object
Dim objElement As Object
Dim objCollection As Object
On Error GoTo catch
'Internet Explorer Object is already assigned
With ie
.Navigate url
While .Busy
DoEvents
Wend
GetInnerHTML = .document.getelementbyId("cphContent_sectionCoreProperties").innerHTML
End With
Exit Function
catch:
GetInnerHTML = Err.Number & " " & Err.Description
End Function
Another way you can achieve the same using XMLHTTP request method. Give it a go:
Sub Fetch_Data()
Dim S$, I&
With New XMLHTTP60
.Open "GET", "https://www.uid.admin.ch/Detail.aspx?uid_id=CHE-105.805.649", False
.send
S = .responseText
End With
With New HTMLDocument
.body.innerHTML = S
With .querySelectorAll("#cphContent_sectionCoreProperties label[id^='cphContent_ct']")
For I = 0 To .Length - 1
Cells(I + 1, 1) = .Item(I).innerText
Cells(I + 1, 2) = .Item(I).NextSibling.FirstChild.innerText
Next I
End With
End With
End Sub
Reference to add to the library before executing the above script:
Microsoft HTML Object Library
Microsoft XML, V6.0
I don't think you need Regular expressions to find the content on the page. You can use the relative positions of the elements to find the content I believe you are after.
Code
Option Explicit
Public Sub GetContent()
Dim URL As String: URL = "https://www.uid.admin.ch/Detail.aspx?uid_id=CHE-105.805.649"
Dim IE As Object: Set IE = CreateObject("InternetExplorer.Application")
Dim Labels As Object
Dim Label As Variant
Dim Values As Variant: ReDim Values(0 To 1, 0 To 5000)
Dim i As Long
With IE
.Navigate URL
.Visible = False
'Load the page
Do Until IE.busy = False And IE.readystate = 4
DoEvents
Loop
'Find all labels in the table
Set Labels = IE.document.getElementByID("cphContent_pnlDetails").getElementsByTagName("label")
'Iterate the labels, then find the divs relative to these
For Each Label In Labels
Values(0, i) = Label.InnerText
Values(1, i) = Label.NextSibling.Children(0).InnerText
i = i + 1
Next
End With
'Dump the values to Excel
ReDim Preserve Values(0 To 1, 0 To i - 1)
ThisWorkbook.Sheets(1).Range("A1:B" & i) = WorksheetFunction.Transpose(Values)
'Close IE
IE.Quit
End Sub
Is there any way to use named groups with regular expressions in VBA?
I would like to write a an Excel VBA Sub that matches the dates in file names and decrements these dates by a specified amount. I need to be able to distinguish between dd/mm and mm/dd formats -- among other irregularities -- and using named groups something like this would solve the problem:
(?:<month>\d\d)(?:<day>\d\d)
Advice is appreciated
Nope, no named groups in VBScript regular expressions.
VBScript uses the same regexp engine that JScript uses, so it's compatible with JavaScript regex, which also doesn't have named groups.
You have to use unnamed groups and just go by the order they appear on the expression to retrieve them by index after running it.
In general, dd/mm and mm/dd can't be automatically distinguished since there are valid dates that could be either. (e.g. 01/04 could be January 4th or April 1st). I don't think you'd be able to solve this with a regular expression.
Here is an implementation of named groups using VBA I made today. Hopefully this will be useful to someone else!:
'Description:
' An implementation of Regex which includes Named Groups
' and caching implemented in VBA
'Example:
' Dim match as Object
' set match = RegexMatch("01/01/2019","(?<month>\d\d)\/(?<day>\d\d)\/(?<year>\d\d\d\d)")
' debug.print match("day") & "/" & match("month") & "/" & match("year")
'Options:
' "i" = IgnoreCase
'Return value:
' A dictionary object with the following keys:
' 0 = Whole match
' 1,2,3,... = Submatch 1,2,3,...
' "Count" stores the count of matches
' "<<NAME>>" stores the match of a specified name
Function RegexMatch(ByVal haystack As String, ByVal pattern As String, Optional ByVal options As String) As Object
'Cache regexes for optimisation
Static CachedRegex As Object
Static CachedNames As Object
If CachedRegex Is Nothing Then Set CachedRegex = CreateObject("Scripting.Dictionary")
If CachedNames Is Nothing Then Set CachedNames = CreateObject("Scripting.Dictionary")
'Named regexp used to detect capturing groups and named capturing groups
Static NamedRegexp As Object
If NamedRegexp Is Nothing Then
Set NamedRegexp = CreateObject("VBScript.RegExp")
NamedRegexp.pattern = "\((?:\?\<(.*?)\>)?"
NamedRegexp.Global = True
End If
'If cached pattern doesn't exist, create it
If Not CachedRegex(pattern) Then
'Create names/capture group object
Dim testPattern As String, oNames As Object
testPattern = pattern
testPattern = Replace(testPattern, "\\", "asdasd")
testPattern = Replace(testPattern, "\(", "asdasd")
'Store names for optimisation
Set CachedNames(options & ")" & pattern) = NamedRegexp.Execute(testPattern)
'Create new VBA valid pattern
Dim newPattern As String
newPattern = NamedRegexp.Replace(pattern, "(")
'Create regexp from new pattern
Dim oRegexp As Object
Set oRegexp = CreateObject("VBScript.RegExp")
oRegexp.pattern = newPattern
'Set regex options
Dim i As Integer
For i = 1 To Len(flags)
Select Case Mid(flags, i, 1)
Case "i"
oRegexp.ignoreCase = True
Case "g"
oRegexp.Global = True
End Select
Next
'Store regex for optimisation
Set CachedRegex(options & ")" & pattern) = oRegexp
End If
'Get matches object
Dim oMatches As Object
Set oMatches = CachedRegex(options & ")" & pattern).Execute(haystack)
'Get names object
Dim CName As Object
Set CName = CachedNames(options & ")" & pattern)
'Create dictionary to return
Dim oRet As Object
Set oRet = CreateObject("Scripting.Dictionary")
'Fill dictionary with names and indexes
'0 = Whole match
'1,2,3,... = Submatch 1,2,3,...
'"Count" stores the count of matches
'"<<NAME>>" stores the match of a specified name
For i = 1 To CName.Count
oRet(i) = oMatches(0).Submatches(i - 1)
If Not IsEmpty(CName(i - 1).Submatches(0)) Then oRet(CName(i - 1).Submatches(0)) = oMatches(0).Submatches(i - 1)
Next i
oRet(0) = oMatches(0)
oRet("Count") = CName.Count
Set RegexMatch = oRet
End Function
P.S. for a Regex library (built by myself) which has this additional functionality, check out stdRegex. The equivalent can be done with:
set match = stdRegex.Create("(?:<month>\d\d)(?:<day>\d\d)").Match(sSomeString)
Debug.print match("month")
There are also more features of stdRegex, than VBScript's standard object. See the test suite for more info.
Thanks #Sancarn for his code!
For a few reasons I've revised it. The changes I've made are documented inside the code:
' Procedure for testing 'RegexMatch'.
' - It shows how to convert a date from 'mm/dd/yyyy' to 'dd.mm.yyyy' format.
' - It shows how to retrieve named groups by real name: 'Match.Item("group name")'
' as well as by number: 'Match.Items(group number)'.
' - It shows how to retrieve unnamed groups by number-generated name as well as by number.
' - It shows how to retrieve group count and the whole match by number-generated name as well as by number.
' - It shows that non-capturing groups like '(?:y)?' won't be listed.
' - It shows that left parenthesis inside a character class like '([x(])?' won't disturbe.
' Take notice of:
' - the small difference between 'Item' and 'Items'
' - the quotes in 'Match.Item("number of an unnamed group")'
Sub TestRegexMatch()
Dim Match As Scripting.Dictionary
Set Match = RegexMatch("01/23/2019z", "(?<month>\d\d)\/([x(])?(?<day>\d\d)\/(?:y)?(?<year>\d\d\d\d)(z)?")
Debug.Print Match.Item("day") & "." & Match.Item("month") & "." & Match.Item("year") & " vs. " & Match.Items(2) & "." & Match.Items(0) & "." & Match.Items(3)
Debug.Print "'" & Match.Item("1") & "'" & ", '" & Match.Item("4") & "' vs. '" & Match.Items(1) & "', '" & Match.Items(4) & "'"
Debug.Print Match.Item("98") & " vs. " & Match.Items(Match.Count - 2)
Debug.Print Match.Item("99") & " vs. " & Match.Items(Match.Count - 1)
End Sub
' An implementation of regex which includes named groups and caching implemented in VBA.
' The 'Microsoft VBScript Regular Expressions 5.5' library must be referenced (in VBA-editor: Tools -> References).
' Parameters:
' - haystack: the string the regex is applied on.
' - originalPattern: the regex pattern with or without named groups.
' The group naming has to follow .net regex syntax: '(?<group name>group content)'.
' Group names may contain the following characters: a-z, A-Z, _ (underscore).
' Group names must not be an empty string.
' - options: a string that may contain:
' - 'i' (the regex will work case-insensitive)
' - 'g' (the regex will work globally)
' - 'm' (the regex will work in multi-line mode)
' or any combination of these.
' Returned value: a Scripting.Dictionary object with the following entries:
' - Item 0 or "0", 1 or "1" ... for the groups content/submatches,
' following the convention of VBScript_RegExp_55.SubMatches collection, which is 0-based.
' - Item Match.Count - 2 or "98" for the whole match, assuming that the number of groups is below.
' - Item Match.Count - 1 or "99" for number of groups/submatches.
' Changes compared to the original version:
' - Handles non-capturing and positive and negative lookahead groups.
' - Handles left parenthesis inside a character class.
' - Named groups do not count twice.
' E.g. in the original version the second named group occupies items 3 and 4 of the returned
' dictionary, in this revised version only item 1 (item 0 is the first named group).
' - Additional 'm' option.
' - Fixed fetching cached regexes.
' - Early binding.
' - Some code cleaning.
' For an example take a look at the 'TestRegexMatch' procedure above.
Function RegexMatch(ByVal haystack As String, ByVal originalPattern As String, Optional ByVal options As String) As Scripting.Dictionary
Dim GroupsPattern As String
Dim RealPattern As String
Dim RealRegExp As VBScript_RegExp_55.RegExp
Dim RealMatches As VBScript_RegExp_55.MatchCollection
Dim ReturnData As Scripting.Dictionary
Dim GroupNames As VBScript_RegExp_55.MatchCollection
Dim Ctr As Integer
' Cache regexes and group names for optimisation.
Static CachedRegExps As Scripting.Dictionary
Static CachedGroupNames As Scripting.Dictionary
' Group 'meta'-regex used to detect named and unnamed capturing groups.
Static GroupsRegExp As VBScript_RegExp_55.RegExp
If CachedRegExps Is Nothing Then Set CachedRegExps = New Scripting.Dictionary
If CachedGroupNames Is Nothing Then Set CachedGroupNames = New Scripting.Dictionary
If GroupsRegExp Is Nothing Then
Set GroupsRegExp = New VBScript_RegExp_55.RegExp
' Original version: GroupsRegExp.Pattern = "\((?:\?\<(.*?)\>)?"
GroupsRegExp.Pattern = "\((?!(?:\?:|\?=|\?!|[^\]\[]*?\]))(?:\?<([a-zA-Z0-9_]+?)>)?"
GroupsRegExp.Global = True
End If
' If the pattern isn't cached, create it.
If Not CachedRegExps.Exists("(" & options & ")" & originalPattern) Then
' Prepare the pattern for retrieving named and unnamed groups.
GroupsPattern = Replace(Replace(Replace(Replace(originalPattern, "\\", "X"), "\(", "X"), "\[", "X"), "\]", "X")
' Store group names for optimisation.
CachedGroupNames.Add "(" & options & ")" & originalPattern, GroupsRegExp.Execute(GroupsPattern)
' Create new VBScript regex valid pattern and set regex for this pattern.
RealPattern = GroupsRegExp.Replace(originalPattern, "(")
Set RealRegExp = New VBScript_RegExp_55.RegExp
RealRegExp.Pattern = RealPattern
' Set regex options.
For Ctr = 1 To Len(options)
Select Case Mid(options, Ctr, 1)
Case "i"
RealRegExp.IgnoreCase = True
Case "g"
RealRegExp.Global = True
Case "m"
RealRegExp.MultiLine = True
End Select
Next
' Store this regex for optimisation.
CachedRegExps.Add "(" & options & ")" & originalPattern, RealRegExp
End If
' Get matches.
Set RealMatches = CachedRegExps.Item("(" & options & ")" & originalPattern).Execute(haystack)
' Get group names.
Set GroupNames = CachedGroupNames.Item("(" & options & ")" & originalPattern)
' Create dictionary to return.
Set ReturnData = New Scripting.Dictionary
' Fill dictionary with names and indexes as descibed in the remarks introducing this procedure.
For Ctr = 1 To GroupNames.Count
If IsEmpty(GroupNames(Ctr - 1).SubMatches(0)) Then
ReturnData.Add CStr(Ctr - 1), RealMatches(0).SubMatches(Ctr - 1)
Else
ReturnData.Add GroupNames(Ctr - 1).SubMatches(0), RealMatches(0).SubMatches(Ctr - 1)
End If
Next
ReturnData.Add "98", RealMatches.Item(0)
ReturnData.Add "99", GroupNames.Count
' Return the result.
Set RegexMatch = ReturnData
End Function
For further improvement this code could be the base of a class module for replacement of the VBScript regex.
I'm trying to remove some text between two tags [ & ]
[13:00:00]
I want to remove 13:00:00 from [] tags.
This number is not the same any time.
Its always a time of the day so, only Integer and : symbols.
Someone can help me?
UPDATE:
I forgot to say something. The time (13:00:00) was picked from a log file. Looks like that:
[10:56:49] [Client thread/ERROR]: Item entity 26367127 has no item?!
[10:57:25] [Dbutant] misterflo13 : ils coute chere les enchent aura de feu et T2 du spawn??*
[10:57:35] [Amateur] firebow ?.SkyLegend.? : ouai 0
[10:57:38] [Novice] iPasteque : ils sont gratuit me
[10:57:41] [Novice] iPasteque : ils sont gratuit mec *
[10:57:46] [Dbutant] misterflo13 : on ma dit k'ils etait payent :o
[10:57:57] [Novice] iPasteque : on t'a mytho alors
Ignore the other text I juste want to remove the time between [ & ] (need to looks like []. The time between [ & ] is updated every second.
It looks like your log has specific format. And you seem want to get rid of the time and keep all other information. Ok - read in comments
I didn't test it but it should work
' Read log
Dim logLines() As String = File.ReadAllLines("File_path")
If logLines.Length = 0 Then Return
' prepare array to fill sliced data
Dim lines(logLines.Length - 1) As String
For i As Integer = 0 To logLines.Count - 1
' just cut off time part and add empty brackets for each line
lines(i) = "[]" & logLines(i).Substring(10)
Next
What you see above - if you know that your file comes in certain format, just use position in the string where to cut it off.
Note: Code above can be done in 1 line using LINQ
If you want to actually get the data out of it, use IndexOf. Since you looking for first occurrence of "[" or "]", just use start index "0"
' get position of open bracket in string
Dim openBracketPos As Integer = myString.IndexOf("[", 0, StringComparison.OrdinalIgnoreCase)
' get position of close bracket in string
Dim closeBracketPos As Integer = myString.IndexOf("]", 0, StringComparison.OrdinalIgnoreCase)
' get string between open and close bracket
Dim data As String = myString.Substring(openBracketPos + 1, closeBracketPos - 1)
This is another possibility using Regex:
Public Function ReplaceTime(ByVal Input As String) As String
Dim m As Match = Regex.Match(Input, "(\[)(\d{1,2}\:\d{1,2}(\:\d{1,2})?)(\])(.+)")
Return m.Groups(1).Value & m.Groups(4).Value & m.Groups(5).Value
End Function
It's more of a readability nightmare but it's efficient and it takes only the brackets containing a time value.
I also took the liberty of making it match for example 13:47 as well as 13:47:12.
Test: http://ideone.com/yogWfD
(EDIT) Multiline example:
You can combine this with File.ReadAllLines() (if that's what you prefer) and a For loop to get the replacement done.
Public Function ReplaceTimeMultiline(ByVal TextLines() As String) As String
For x = 0 To TextLines.Length - 1
TextLines(x) = ReplaceTime(TextLines(x))
Next
Return String.Join(Environment.NewLine, TextLines)
End Function
Above code usage:
Dim FinalT As String = ReplaceTimeMultiline(File.ReadAllLines(<file path here>))
Another multiline example:
Public Function ReplaceTimeMultiline(ByVal Input As String) As String
Dim ReturnString As String = ""
Dim Parts() As String = Input.Split(Environment.NewLine)
For x = 0 To Parts.Length - 1
ReturnString &= ReplaceTime(Parts(x)) & If(x < (Parts.Length - 1), Environment.NewLine, "")
Next
Return ReturnString
End Function
Multiline test: http://ideone.com/nKZQHm
If your problem is to remove numeric strings in the format of 99:99:99 that appear inside [], I would do:
//assuming you want to replace the [......] numeric string with an empty []. Should you want to completely remove the tag, just replace with string.Empty
Here's a demo (in C#, not VB, but you get the point (you need the regex, not the syntax anyway)
List<string> list = new List<string>
{
"[13:00:00]",
"[4:5:0]",
"[5d2hu2d]",
"[1:1:1000]",
"[1:00:00]",
"[512341]"
};
string s = string.Join("\n", list);
Console.WriteLine("Original input string:");
Console.WriteLine(s);
Regex r = new Regex(#"\[\d{1,2}?:\d{1,2}?:\d{1,2}?\]");
foreach (Match m in r.Matches(s))
{
Console.WriteLine("{0} is a match.", m.Value);
}
Console.WriteLine();
Console.WriteLine("String with occurrences replaced with an empty string:");
Console.WriteLine(r.Replace(s, string.Empty).Trim());
I am using the code below to create output showing how many emails were in a defined folder per day. This all works fine... My question is in the section with XXXXX, how do I reference each mail item so that I can do a regex for a word pattern? The end goal is to find out how many emails contained a keyword on a given day. The desired output is something like this:
,,
2015-01-01,15,2,5
2015-01-01,23,22,0
...
...
I'm ok to figure out the code on determining the number of emails based on the keyword, just not certain how to reference the email messages based on the code as is today...
Thanks for your advice.
Sub HowManyEmails()
Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim EmailCount As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
On Error Resume Next
Set objFolder = objnSpace.Folders("Personal Folders").Folders("Inbox").Folders("jobs.keep")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
EmailCount = objFolder.Items.Count
MsgBox "Number of emails in the folder: " & EmailCount, , "email count"
Dim dateStr As String
Dim myItems As Outlook.Items
Dim dict As Object
Dim msg As String
Set dict = CreateObject("Scripting.Dictionary")
Set myItems = objFolder.Items
myItems.SetColumns ("SentOn")
' Determine date of each message:
For Each myItem In myItems
xxxxxxx
xxxxxxx
xxxxxxx
dateStr = GetDate(myItem.SentOn)
If Not dict.Exists(dateStr) Then
dict(dateStr) = 0
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem
'Write output to file
Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
FILEPATH = enviro & "\Desktop\emails.csv"
Open FILEPATH For Output As 1
msg = ""
For Each o In dict.Keys
msg = msg & o & "," & dict(o) & vbCrLf
'MsgBox msg
Next
Print #1, msg
Close #1
'Write output to file
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
End Sub
Function GetDate(dt As Date) As String
GetDate = Year(dt) & "-" & Month(dt) & "-" & Day(dt)
End Function
You need to check the type of item in your code:
Dim myMailItem As Outlook.mailItem
....
For each myItem in myItems
If TypeOf myItem Is MailItem Then
Set myMailItem = myItem
XXXXXXXXXXX and rest of code here use myMailItem instead of myItem to get info
End If
Next myItem
First of all, I'd recommend using the Find/FindNext or Restrict methods of the Items class to find the subset of items that match to the specified condition. Iterating through all items in the folder may take a lot of time.
objnSpace.Folders("Personal Folders").Folders("Inbox")
Use the GetDefaultFolder method of the Namespace class to get a folder that represents the default folder of the requested type for the current profile.
Outlook uses EntryID values for identifying Outlook items uniquely. See Working with EntryIDs and StoreIDs for more information. If you know the IDs of an item and the folder it's stored in, you can directly reference the item using the NameSpace.GetItemFromID method.
I've currently got a string which contains a URL, and I need to get the base URL.
The string I have is http://www.test.com/test-page/category.html
I am looking for a RegEx that will effectively remove any page/folder names at the end. The issue is that some people may enter the domain in the following formats:
http://www.test.com
www.test.co.uk/
www.test.info/test-page.html
www.test.gov/test-folder/test-page.html
It must return http://www.websitename.ext/ each time i.e. the domain name and extension (e.g. .info .com .co.uk etc) with a forward slash at the end.
Effectively it needs to return the base URL, without any page/folder names. Is there any easy way to do with with a Regular Expression?
Thanks.
My approach: Use a RegEx to extract the domain name. Then add http: to the front and / to the end. Here's the RegEx:
^(?:http:\/\/)?([\w_]+(?:\.[\w_]+)+)(?=(?:\/|$))
Also see this answer to the question Extract root domain name from string. (It left me somewhat disatisfied, although pointed out the need to account for https, the port number, and user authentication info which my RegEx does not do.)
Here is an implementation in VBScript. I put the RegEx in a constant and defined a function named GetDomainName(). You should be able to incorporate that function in your ASP page like this:
normalizedUrl = "http://" & GetDomainName(url) & "/"
You can also test my script from the command prompt by saving the code to a file named test.vbs and then passing it to cscript:
cscript test.vbs
Test Program
Option Explicit
Const REGEXPR = "^(?:http:\/\/)?([\w_]+(?:\.[\w_]+)+)(?=(?:\/|$))"
' ^^^^^^^^^ ^^^^^^ ^^^^^^^^^^ ^^^^
' A B1 B2 C
'
' A - An optional 'http://' scheme
' B1 - Followed by one or more alpha-numeric characters
' B2 - Followed optionally by one or more occurences of a string
' that begins with a period that is followed by
' one or more alphanumeric characters, and
' C - Terminated by a slash or nothing.
Function GetDomainName(sUrl)
Dim oRegex, oMatch, oMatches, oSubMatch
Set oRegex = New RegExp
oRegex.Pattern = REGEXPR
oRegex.IgnoreCase = True
oRegex.Global = False
Set oMatches = oRegex.Execute(sUrl)
If oMatches.Count > 0 Then
GetDomainName = oMatches(0).SubMatches(0)
Else
GetDomainName = ""
End If
End Function
Dim Data : Data = _
Array( _
"xhttp://www.test.com" _
, "http://www..test.com" _
, "http://www.test.com." _
, "http://www.test.com" _
, "www.test.co.uk/" _
, "www.test.co.uk/?q=42" _
, "www.test.info/test-page.html" _
, "www.test.gov/test-folder/test-page.html" _
, ".www.test.co.uk/" _
)
Dim sUrl, sDomainName
For Each sUrl In Data
sDomainName = GetDomainName(sUrl)
If sDomainName = "" Then
WScript.Echo "[ ] [" & sUrl & "]"
Else
WScript.Echo "[*] [" & sUrl & "] => [" & sDomainName & "]"
End If
Next
Expected Output:
[ ] [xhttp://www.test.com]
[ ] [http://www..test.com]
[ ] [http://www.test.com.]
[*] [http://www.test.com] => [www.test.com]
[*] [www.test.co.uk/] => [www.test.co.uk]
[*] [www.test.co.uk/?q=42] => [www.test.co.uk]
[*] [www.test.info/test-page.html] => [www.test.info]
[*] [www.test.gov/test-folder/test-page.html] => [www.test.gov]
[ ] [.www.test.co.uk/]
I haven't coded Classic ASP in 12 years and this is totally untested.
result = "http://" & Split(Replace(url, "http://",""),"/")(0) & "/"