VB6 调用谷歌翻译API进行文章单词翻译

软件测试地址：
https://www.lanzous.com/i5upp6b

https://translate.google.cn/translate_a/single?client=webapp&sl=auto&tl=en&hl=zh-CN&dt=at&dt=bd&dt=ex&dt=ld&dt=md&dt=qca&dt=rw&dt=rm&dt=ss&dt=t&dt=gt&source=bh&ssel=0&tsel=0&kc=1&tk=841392.684795&q=%E6%98%8E%E6%9C%88%E5%

''计算TK
Function TK(t As String, TKK As String) As String
    Dim js As Object
    Set js = CreateObject("ScriptControl")
    js.Language = "JScript"
    js.addcode ("function b(a, b) {for (var d = 0; d < b.length - 2; d += 3) {var c = b.charAt(d + 2)," & _
        "c = 'a' <= c ? c.charCodeAt(0) - 87 : Number(c),c = '+' == b.charAt(d + 1) ? a >>> c : a " & _
        "<< c,a = '+' == b.charAt(d) ? a + c & 4294967295 : a ^ c}return a};function tk(a, TKK) {for " & _
        "(var e = TKK.split('.'), h = Number(e[0]) || 0, g = [], d = 0, f = 0; f < a.length; f++) {var c =" & _
        " a.charCodeAt(f);128 > c ?g[d++] = c : (2048 > c ?g[d++] = c >> 6 | 192 : (55296 == (c & 64512) && " & _
        "f + 1 < a.length && 56320 == (a.charCodeAt(f + 1) & 64512) ?(c = 65536 + ((c & 1023) << 10) +" & _
        " (a.charCodeAt(++f) & 1023), g[d++] = c >> 18 | 240, g[d++] = c >> 12 & 63 | 128) : g[d++] = c >> " & _
        "12 | 224, g[d++] = c >> 6 & 63 | 128), g[d++] = c & 63 | 128)}a = h;for (d = 0; d < g.length; d++)a " & _
        "+= g[d], a = b(a, '+-a^+6');a = b(a, '+-3^+b+-f');a ^= Number(e[1]) || 0;0 > a && (a = (a & 2147483647) " & _
        "+ 2147483648);a %= 1E6;return a.toString() + '.' + (a ^ h)}")
    TK = js.eval("tk('" & t & "','" & TKK & "')")
End Function

''地址转换
Function URLEncodeGbk(nstr As String) As String
    Dim js As Object
    Set js = CreateObject("ScriptControl")
    js.Language = "JScript"
    js.addcode ("function b(a) {return encodeURIComponent(a)}")
    URLEncodeGbk = js.eval("b('" & nstr & "')")
End Function

''正则表达式函数
Function get_regdata(ByVal str As Variant, ByVal rex_data As String) As Variant
    Dim mRegExp As Object
    Dim mMatches As Object
    Dim mMatch As Object
    Dim arr() As Variant
    Set mRegExp = CreateObject("Vbscript.Regexp")
    With mRegExp
        .Global = True
        .IgnoreCase = True
        .Pattern = rex_data
        Set mMatches = .Execute(str)
        ReDim arr(mMatches.Count)
        Dim i As Integer
        i = 0
        For Each mMatch In mMatches
            arr(i) = mMatch.Value
            i = i + 1
        Next
    End With
    get_regdata = arr
    Set mRegExp = Nothing
    Set mMatches = Nothing
End Function

''GET形式获取数据
Public Function GetData(ByVal url As String) As Variant
    On Error GoTo ERR:
    Dim XMLHTTP As Object
    Dim zflx As String
    Dim bty() As Byte
    Set XMLHTTP = CreateObject("Microsoft.XMLHTTP")
    XMLHTTP.Open "get", url, True
    XMLHTTP.setrequestheader "Content-Type", "application/x-www-form-urlencoded"
    XMLHTTP.setrequestheader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:66.0) Gecko/20100101 Firefox/66.0"
    XMLHTTP.send
    While XMLHTTP.ReadyState <> 4
        DoEvents
    Wend
    zflx = XMLHTTP.ResponseText
    GetData = zflx
    Set XMLHTTP = Nothing
    Exit Function
ERR:
    GetData = ""
End Function

''地址拼接
Function GOOGLEURL() As String
    Dim TKK As String
    TKK = Split(get_regdata(GetData("https://translate.google.cn"), "tkk:.*?,")(0), "'")(1)
    Dim U As String, data As String
    data = Replace(RichTextBox1.Text, vbCrLf, "\r\n")
    U = "https://translate.google.cn/translate_a/single?client=webapp&sl=auto&tl=en&hl=zh-CN&dt=at&dt=bd&dt=ex&dt=ld&dt=md&" & _
        "dt=qca&dt=rw&dt=rm&dt=ss&dt=t&dt=gt&source=bh&ssel=0&tsel=0&kc=1&tk=" & TK(data, TKK) & _
        "&q=" & URLEncodeGbk(data)
    GOOGLEURL = U
End Function

‘’解析数据
Private Sub Command1_Click()
    RichTextBox2.Text = GetData(GOOGLEURL)
    'Command2_Click
    Dim j As Object, i As Integer
    Set j = jso.parse(RichTextBox2.Text)
    For i = 1 To j(1)(1).Count
        RichTextBox3.Text = RichTextBox3.Text & j(1)(i)(1)
    Next
End Sub

cStringBuilder.bas

Option Explicit

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
      (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
      
      
Private m_sString As String
Private m_iChunkSize As Long
Private m_iPos As Long
Private m_iLen As Long

Public Property Get Length() As Long
   Length = m_iPos \ 2
End Property

Public Property Get Capacity() As Long
   Capacity = m_iLen \ 2
End Property

Public Property Get ChunkSize() As Long
   ChunkSize = m_iChunkSize \ 2
End Property

Public Property Let ChunkSize(ByVal iChunkSize As Long)
   m_iChunkSize = iChunkSize * 2
End Property

Public Property Get toString() As String
   If m_iPos > 0 Then
      toString = Left$(m_sString, m_iPos \ 2)
   End If
End Property

Public Property Let TheString(ByRef sThis As String)
   Dim lLen As Long
   lLen = LenB(sThis)
   If lLen = 0 Then
      m_sString = ""
      m_iPos = 0
      m_iLen = 0
   Else
      If m_iLen < lLen Then
         Do
            m_sString = m_sString & Space$(m_iChunkSize \ 2)
            m_iLen = m_iLen + m_iChunkSize
         Loop While m_iLen < lLen
      End If
      CopyMemory ByVal StrPtr(m_sString), ByVal StrPtr(sThis), lLen
      m_iPos = lLen
   End If
   
End Property

Public Sub Clear()
   m_sString = ""
   m_iPos = 0
   m_iLen = 0
End Sub

Public Sub AppendNL(ByRef sThis As String)
   Append sThis
   Append vbCrLf
End Sub

Public Sub Append(ByRef sThis As String)
   Dim lLen As Long
   Dim lLenPlusPos As Long
   lLen = LenB(sThis)
   lLenPlusPos = lLen + m_iPos
   If lLenPlusPos > m_iLen Then
      Dim lTemp As Long
      
      lTemp = m_iLen
      Do While lTemp < lLenPlusPos
         lTemp = lTemp + m_iChunkSize
      Loop
      
      m_sString = m_sString & Space$((lTemp - m_iLen) \ 2)
      m_iLen = lTemp
   End If
   
   CopyMemory ByVal UnsignedAdd(StrPtr(m_sString), m_iPos), ByVal StrPtr(sThis), lLen
   m_iPos = m_iPos + lLen
End Sub

Public Sub AppendByVal(ByVal sThis As String)
   Append sThis
End Sub

Public Sub Insert(ByVal iIndex As Long, ByRef sThis As String)
   Dim lLen As Long
   Dim lPos As Long
   Dim lSize As Long
   If (iIndex * 2 > m_iPos) Then
      ERR.Raise 9
   Else
   
      lLen = LenB(sThis)
      If (m_iPos + lLen) > m_iLen Then
         m_sString = m_sString & Space$(m_iChunkSize \ 2)
         m_iLen = m_iLen + m_iChunkSize
      End If
      lPos = UnsignedAdd(StrPtr(m_sString), iIndex * 2)
      lSize = m_iPos - iIndex * 2
      CopyMemory ByVal UnsignedAdd(lPos, lLen), ByVal lPos, lSize
      CopyMemory ByVal lPos, ByVal StrPtr(sThis), lLen
      
      m_iPos = m_iPos + lLen
   End If
End Sub

Public Sub InsertByVal(ByVal iIndex As Long, ByVal sThis As String)
   Insert iIndex, sThis
End Sub

Public Sub Remove(ByVal iIndex As Long, ByVal lLen As Long)
   Dim lSrc As Long
   Dim lDst As Long
   Dim lSize As Long

   If (iIndex * 2 > m_iPos) Then
      ERR.Raise 9
   Else
      If ((iIndex + lLen) * 2 > m_iPos) Then
         ERR.Raise 9
      Else
         lSrc = UnsignedAdd(StrPtr(m_sString), (iIndex + lLen) * 2)
         lDst = UnsignedAdd(StrPtr(m_sString), iIndex * 2)
         lSize = (m_iPos - (iIndex + lLen) * 2)
         CopyMemory ByVal lDst, ByVal lSrc, lSize
         m_iPos = m_iPos - lLen * 2
      End If
   End If
End Sub

Public Function Find(ByVal sToFind As String, _
   Optional ByVal lStartIndex As Long = 1, _
   Optional ByVal compare As VbCompareMethod = vbTextCompare _
   ) As Long
   
   Dim lInstr As Long
   If (lStartIndex > 0) Then
      lInstr = InStr(lStartIndex, m_sString, sToFind, compare)
   Else
      lInstr = InStr(m_sString, sToFind, compare)
   End If
   If (lInstr < m_iPos \ 2) Then
      Find = lInstr
   End If
End Function

Public Sub HeapMinimize()
   Dim iLen As Long
   If (m_iLen - m_iPos) > m_iChunkSize Then
      iLen = m_iLen
      Do While (iLen - m_iPos) > m_iChunkSize
         iLen = iLen - m_iChunkSize
      Loop
      m_sString = Left$(m_sString, iLen \ 2)
      m_iLen = iLen
   End If
   
End Sub
Private Function UnsignedAdd(Start As Long, Incr As Long) As Long

   If Start And &H80000000 Then
      UnsignedAdd = Start + Incr
   ElseIf (Start Or &H80000000) < -Incr Then
      UnsignedAdd = Start + Incr
   Else
      UnsignedAdd = (Start + &H80000000) + (Incr + &H80000000)
   End If
   
End Function
Private Sub Class_Initialize()
   m_iChunkSize = 16384
End Sub

'将json的花括号转化为vba的字典，将方括号转化为vba的集合
Option Explicit

Const INVALID_JSON As Long = 1
Const INVALID_OBJECT As Long = 2
Const INVALID_ARRAY As Long = 3
Const INVALID_BOOLEAN As Long = 4
Const INVALID_NULL As Long = 5
Const INVALID_KEY As Long = 6
Const INVALID_RPC_CALL As Long = 7

Private psErrors As String

Public Function GetParserErrors() As String
    GetParserErrors = psErrors
End Function

Public Function ClearParserErrors() As String
    psErrors = ""
End Function


'
'   parse string and create JSON object
'
Public Function parse(ByVal str As String) As Object

    Dim index As Long
    index = 1
    psErrors = ""
    On Error Resume Next
    Call skipChar(str, index)
    Select Case Mid(str, index, 1)
    Case "{"
        Set parse = parseObject(str, index)
    Case "["
        Set parse = parseArray(str, index)
    Case Else
        psErrors = "Invalid JSON"
    End Select


End Function

'
'   parse collection of key/value
'
Private Function parseObject(ByRef str As String, ByRef index As Long) As Object

    Set parseObject = CreateObject("Scripting.Dictionary")
    Dim sKey As String

    ' "{"
    Call skipChar(str, index)
    If Mid(str, index, 1) <> "{" Then
        psErrors = psErrors & "Invalid Object at position " & index & " : " & Mid(str, index) & vbCrLf
        Exit Function
    End If

    index = index + 1

    Do
        Call skipChar(str, index)
        If "}" = Mid(str, index, 1) Then
            index = index + 1
            Exit Do
        ElseIf "," = Mid(str, index, 1) Then
            index = index + 1
            Call skipChar(str, index)
        ElseIf index > Len(str) Then
            psErrors = psErrors & "Missing '}': " & Right(str, 20) & vbCrLf
            Exit Do
        End If


        ' add key/value pair
        sKey = parseKey(str, index)
        On Error Resume Next

        parseObject.Add sKey, parseValue(str, index)
        If ERR.Number <> 0 Then
            psErrors = psErrors & ERR.Description & ": " & sKey & vbCrLf
            Exit Do
        End If
    Loop
eh:

End Function

'
'   parse list
'
Private Function parseArray(ByRef str As String, ByRef index As Long) As Collection

    Set parseArray = New Collection

    ' "["
    Call skipChar(str, index)
    If Mid(str, index, 1) <> "[" Then
        psErrors = psErrors & "Invalid Array at position " & index & " : " + Mid(str, index, 20) & vbCrLf
        Exit Function
    End If

    index = index + 1

    Do

        Call skipChar(str, index)
        If "]" = Mid(str, index, 1) Then
            index = index + 1
            Exit Do
        ElseIf "," = Mid(str, index, 1) Then
            index = index + 1
            Call skipChar(str, index)
        ElseIf index > Len(str) Then
            psErrors = psErrors & "Missing ']': " & Right(str, 20) & vbCrLf
            Exit Do
        End If

        ' add value
        On Error Resume Next
        parseArray.Add parseValue(str, index)
        If ERR.Number <> 0 Then
            psErrors = psErrors & ERR.Description & ": " & Mid(str, index, 20) & vbCrLf
            Exit Do
        End If
    Loop

End Function

'
'   parse string / number / object / array / true / false / null
'
Private Function parseValue(ByRef str As String, ByRef index As Long)

    Call skipChar(str, index)

    Select Case Mid(str, index, 1)
    Case "{"
        Set parseValue = parseObject(str, index)
    Case "["
        Set parseValue = parseArray(str, index)
    Case """", "'"
        parseValue = parseString(str, index)
    Case "t", "f"
        parseValue = parseBoolean(str, index)
    Case "n"
        parseValue = parseNull(str, index)
    Case Else
        parseValue = parseNumber(str, index)
    End Select

End Function

'
'   parse string
'
Private Function parseString(ByRef str As String, ByRef index As Long) As String

    Dim quote As String
    Dim Char As String
    Dim Code As String

    Dim SB As New cStringBuilder

    Call skipChar(str, index)
    quote = Mid(str, index, 1)
    index = index + 1

    Do While index > 0 And index <= Len(str)
        Char = Mid(str, index, 1)
        Select Case (Char)
        Case "\"
            index = index + 1
            Char = Mid(str, index, 1)
            Select Case (Char)
            Case """", "\", "/", "'"
                SB.Append Char
                index = index + 1
            Case "b"
                SB.Append vbBack
                index = index + 1
            Case "f"
                SB.Append vbFormFeed
                index = index + 1
            Case "n"
                SB.Append vbLf
                index = index + 1
            Case "r"
                SB.Append vbCr
                index = index + 1
            Case "t"
                SB.Append vbTab
                index = index + 1
            Case "u"
                index = index + 1
                Code = Mid(str, index, 4)
                SB.Append ChrW(Val("&h" + Code))
                index = index + 4
            End Select
        Case quote
            index = index + 1

            parseString = SB.toString
            Set SB = Nothing

            Exit Function

        Case Else
            SB.Append Char
            index = index + 1
        End Select
    Loop

    parseString = SB.toString
    Set SB = Nothing

End Function

'
'   parse number
'
Private Function parseNumber(ByRef str As String, ByRef index As Long)

    Dim Value As String
    Dim Char As String

    Call skipChar(str, index)
    Do While index > 0 And index <= Len(str)
        Char = Mid(str, index, 1)
        If InStr("+-0123456789.eE", Char) Then
            Value = Value & Char
            index = index + 1
        Else
            parseNumber = CDec(Value)
            Exit Function
        End If
    Loop
End Function

'
'   parse true / false
'
Private Function parseBoolean(ByRef str As String, ByRef index As Long) As Boolean

    Call skipChar(str, index)
    If Mid(str, index, 4) = "true" Then
        parseBoolean = True
        index = index + 4
    ElseIf Mid(str, index, 5) = "false" Then
        parseBoolean = False
        index = index + 5
    Else
        psErrors = psErrors & "Invalid Boolean at position " & index & " : " & Mid(str, index) & vbCrLf
    End If

End Function

'
'   parse null
'
Private Function parseNull(ByRef str As String, ByRef index As Long)

    Call skipChar(str, index)
    If Mid(str, index, 4) = "null" Then
        parseNull = Null
        index = index + 4
    Else
        psErrors = psErrors & "Invalid null value at position " & index & " : " & Mid(str, index) & vbCrLf
    End If

End Function

Private Function parseKey(ByRef str As String, ByRef index As Long) As String

    Dim dquote As Boolean
    Dim squote As Boolean
    Dim Char As String

    Call skipChar(str, index)
    Do While index > 0 And index <= Len(str)
        Char = Mid(str, index, 1)
        Select Case (Char)
        Case """"
            dquote = Not dquote
            index = index + 1
            If Not dquote Then
                Call skipChar(str, index)
                If Mid(str, index, 1) <> ":" Then
                    psErrors = psErrors & "Invalid Key at position " & index & " : " & parseKey & vbCrLf
                    Exit Do
                End If
            End If
        Case "'"
            squote = Not squote
            index = index + 1
            If Not squote Then
                Call skipChar(str, index)
                If Mid(str, index, 1) <> ":" Then
                    psErrors = psErrors & "Invalid Key at position " & index & " : " & parseKey & vbCrLf
                    Exit Do
                End If
            End If
        Case ":"
            index = index + 1
            If Not dquote And Not squote Then
                Exit Do
            Else
                parseKey = parseKey & Char
            End If
        Case Else
            If InStr(vbCrLf & vbCr & vbLf & vbTab & " ", Char) Then
            Else
                parseKey = parseKey & Char
            End If
            index = index + 1
        End Select
    Loop

End Function

'
'   skip special character
'
Private Sub skipChar(ByRef str As String, ByRef index As Long)
    Dim bComment As Boolean
    Dim bStartComment As Boolean
    Dim bLongComment As Boolean
    Do While index > 0 And index <= Len(str)
        Select Case Mid(str, index, 1)
        Case vbCr, vbLf
            If Not bLongComment Then
                bStartComment = False
                bComment = False
            End If

        Case vbTab, " ", "(", ")"

        Case "/"
            If Not bLongComment Then
                If bStartComment Then
                    bStartComment = False
                    bComment = True
                Else
                    bStartComment = True
                    bComment = False
                    bLongComment = False
                End If
            Else
                If bStartComment Then
                    bLongComment = False
                    bStartComment = False
                    bComment = False
                End If
            End If

        Case "*"
            If bStartComment Then
                bStartComment = False
                bComment = True
                bLongComment = True
            Else
                bStartComment = True
            End If

        Case Else
            If Not bComment Then
                Exit Do
            End If
        End Select

        index = index + 1
    Loop

End Sub

Public Function toString(ByRef obj As Variant) As String
    Dim SB As New cStringBuilder
    Select Case VarType(obj)
    Case vbNull
        SB.Append "null"
    Case vbDate
        SB.Append """" & CStr(obj) & """"
    Case vbString
        SB.Append """" & Encode(obj) & """"
    Case vbObject

        Dim bFI As Boolean
        Dim i As Long

        bFI = True
        If TypeName(obj) = "Dictionary" Then

            SB.Append "{"
            Dim keys
            keys = obj.keys
            For i = 0 To obj.Count - 1
                If bFI Then bFI = False Else SB.Append ","
                Dim key
                key = keys(i)
                SB.Append """" & key & """:" & toString(obj.Item(key))
            Next i
            SB.Append "}"

        ElseIf TypeName(obj) = "Collection" Then

            SB.Append "["
            Dim Value
            For Each Value In obj
                If bFI Then bFI = False Else SB.Append ","
                SB.Append toString(Value)
            Next Value
            SB.Append "]"

        End If
    Case vbBoolean
        If obj Then SB.Append "true" Else SB.Append "false"
    Case vbVariant, vbArray, vbArray + vbVariant
        Dim sEB
        SB.Append multiArray(obj, 1, "", sEB)
    Case Else
        SB.Append Replace(obj, ",", ".")
    End Select

    toString = SB.toString
    Set SB = Nothing

End Function

Private Function Encode(str) As String

    Dim SB As New cStringBuilder
    Dim i As Long
    Dim j As Long
    Dim aL1 As Variant
    Dim aL2 As Variant
    Dim c As String
    Dim p As Boolean

    aL1 = Array(&H22, &H5C, &H2F, &H8, &HC, &HA, &HD, &H9)
    aL2 = Array(&H22, &H5C, &H2F, &H62, &H66, &H6E, &H72, &H74)
    For i = 1 To Len(str)
        p = True
        c = Mid(str, i, 1)
        For j = 0 To 7
            If c = Chr(aL1(j)) Then
                SB.Append "\" & Chr(aL2(j))
                p = False
                Exit For
            End If
        Next

        If p Then
            Dim a
            a = AscW(c)
            If a > 31 And a < 127 Then
                SB.Append c
            ElseIf a > -1 Or a < 65535 Then
                SB.Append "\u" & String(4 - Len(Hex(a)), "0") & Hex(a)
            End If
        End If
    Next

    Encode = SB.toString
    Set SB = Nothing

End Function

Private Function multiArray(aBD, iBC, sPS, ByRef sPT)   ' Array BoDy, Integer BaseCount, String PoSition

    Dim iDU As Long
    Dim iDL As Long
    Dim i As Long

    On Error Resume Next
    iDL = LBound(aBD, iBC)
    iDU = UBound(aBD, iBC)

    Dim SB As New cStringBuilder

    Dim sPB1, sPB2  ' String PointBuffer1, String PointBuffer2
    If ERR.Number = 9 Then
        sPB1 = sPT & sPS
        For i = 1 To Len(sPB1)
            If i <> 1 Then sPB2 = sPB2 & ","
            sPB2 = sPB2 & Mid(sPB1, i, 1)
        Next
        '        multiArray = multiArray & toString(Eval("aBD(" & sPB2 & ")"))
        SB.Append toString(aBD(sPB2))
    Else
        sPT = sPT & sPS
        SB.Append "["
        For i = iDL To iDU
            SB.Append multiArray(aBD, iBC + 1, i, sPT)
            If i < iDU Then SB.Append ","
        Next
        SB.Append "]"
        sPT = Left(sPT, iBC - 2)
    End If
    ERR.Clear
    multiArray = SB.toString

    Set SB = Nothing
End Function

' Miscellaneous JSON functions

Public Function StringToJSON(st As String) As String

    Const FIELD_SEP = "~"
    Const RECORD_SEP = "|"

    Dim sFlds As String
    Dim sRecs As New cStringBuilder
    Dim lRecCnt As Long
    Dim lFld As Long
    Dim fld As Variant
    Dim rows As Variant

    lRecCnt = 0
    If st = "" Then
        StringToJSON = "null"
    Else
        rows = Split(st, RECORD_SEP)
        For lRecCnt = LBound(rows) To UBound(rows)
            sFlds = ""
            fld = Split(rows(lRecCnt), FIELD_SEP)
            For lFld = LBound(fld) To UBound(fld) Step 2
                sFlds = (sFlds & IIf(sFlds <> "", ",", "") & """" & fld(lFld) & """:""" & toUnicode(fld(lFld + 1) & "") & """")
            Next    'fld
            sRecs.Append IIf((Trim(sRecs.toString) <> ""), "," & vbCrLf, "") & "{" & sFlds & "}"
        Next    'rec
        StringToJSON = ("( {""Records"": [" & vbCrLf & sRecs.toString & vbCrLf & "], " & """RecordCount"":""" & lRecCnt & """ } )")
    End If
End Function


Public Function RStoJSON(rs As Object) As String
    On Error GoTo errHandler
    Dim sFlds As String
    Dim sRecs As New cStringBuilder
    Dim lRecCnt As Long
    Dim fld As ADODB.Field

    lRecCnt = 0
    If rs.State = adStateClosed Then
        RStoJSON = "null"
    Else
        If rs.EOF Or rs.BOF Then
            RStoJSON = "null"
        Else
            Do While Not rs.EOF And Not rs.BOF
                lRecCnt = lRecCnt + 1
                sFlds = ""
                For Each fld In rs.Fields
                    sFlds = (sFlds & IIf(sFlds <> "", ",", "") & """" & fld.Name & """:""" & toUnicode(fld.Value & "") & """")
                Next    'fld
                sRecs.Append IIf((Trim(sRecs.toString) <> ""), "," & vbCrLf, "") & "{" & sFlds & "}"
                rs.MoveNext
            Loop
            RStoJSON = ("( {""Records"": [" & vbCrLf & sRecs.toString & vbCrLf & "], " & """RecordCount"":""" & lRecCnt & """ } )")
        End If
    End If

    Exit Function
errHandler:

End Function

'Public Function JsonRpcCall(url As String, methName As String, args(), Optional user As String, Optional pwd As String) As Object
'    Dim r As Object
'    Dim cli As Object
'    Dim pText As String
'    Static reqId As Integer
'
'    reqId = reqId + 1
'
'    Set r = CreateObject("Scripting.Dictionary")
'    r("jsonrpc") = "2.0"
'    r("method") = methName
'    r("params") = args
'    r("id") = reqId
'
'    pText = toString(r)
'
'    Set cli = CreateObject("MSXML2.XMLHTTP.6.0")
'   ' Set cli = New MSXML2.XMLHTTP60
'    If Len(user) > 0 Then   ' If Not IsMissing(user) Then
'        cli.Open "POST", url, False, user, pwd
'    Else
'        cli.Open "POST", url, False
'    End If
'    cli.setRequestHeader "Content-Type", "application/json"
'    cli.Send pText
'
'    If cli.Status <> 200 Then
'        Err.Raise vbObjectError + INVALID_RPC_CALL + cli.Status, , cli.statusText
'    End If
'
'    Set r = parse(cli.responseText)
'    Set cli = Nothing
'
'    If r("id") <> reqId Then Err.Raise vbObjectError + INVALID_RPC_CALL, , "Bad Response id"
'
'    If r.Exists("error") Or Not r.Exists("result") Then
'        Err.Raise vbObjectError + INVALID_RPC_CALL, , "Json-Rpc Response error: " & r("error")("message")
'    End If
'
'    If Not r.Exists("result") Then Err.Raise vbObjectError + INVALID_RPC_CALL, , "Bad Response, missing result"
'
'    Set JsonRpcCall = r("result")
'End Function




Public Function toUnicode(str As String) As String

    Dim x As Long
    Dim uStr As New cStringBuilder
    Dim uChrCode As Integer

    For x = 1 To Len(str)
        uChrCode = Asc(Mid(str, x, 1))
        Select Case uChrCode
        Case 8:    ' backspace
            uStr.Append "\b"
        Case 9:    ' tab
            uStr.Append "\t"
        Case 10:    ' line feed
            uStr.Append "\n"
        Case 12:    ' formfeed
            uStr.Append "\f"
        Case 13:    ' carriage return
            uStr.Append "\r"
        Case 34:    ' quote
            uStr.Append "\"""
        Case 39:    ' apostrophe
            uStr.Append "\'"
        Case 92:    ' backslash
            uStr.Append "\\"
        Case 123, 125:    ' "{" and "}"
            uStr.Append ("\u" & Right("0000" & Hex(uChrCode), 4))
        Case Is < 32, Is > 127:    ' non-ascii characters
            uStr.Append ("\u" & Right("0000" & Hex(uChrCode), 4))
        Case Else
            uStr.Append Chr$(uChrCode)
        End Select
    Next
    toUnicode = uStr.toString
    Exit Function

End Function

Private Sub Class_Initialize()
    psErrors = ""
End Sub