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

百度百科:

Google 翻译是谷歌公司提供一项免费的翻译服务,可提供103 种语言之间的即时翻译,支持任意两种语言之间的字词、句子和网页翻译。可分析的人工翻译文档越多,译文的质量就会越高。

Google 翻译生成译文时,会在数百万篇文档中查找各种模式,以便决定最佳翻译。Google 翻译通过在经过人工翻译的文档中检测各种模式,进行合理的猜测,然后得出适当的翻译。这种在大量文本中查找各种范例的过程称为“统计机器翻译”。由于译文是由机器生成的,因此并不是所有的译文都是完美的。

从百度百科上我们了解到谷歌翻译是非常强大的!

《声明》

本制作只做技术交流,切勿用作非法用途,商业用途等违法行为!如发现有以上行为均已本人无关,请自行承担后果!大家且行且珍惜。

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

谷歌翻译是以GET形式返回数据

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秘钥和一个字符串转换后的内容去申请json结果集

--------------------------------------------------------------------------------

既然知道这两个关键参数那么我们直接计算tk 和转换地址即可

--------------------------------------------------------------------------------


至于怎么找js函数详细过程就不一一详说了直接上源码吧(有需要可以后台联系本人):

''计算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

以上为关键代码,接下来是json类(来自Excelhome的解析类)

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类

'将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





今天教程就到此结束了!

本文分享自微信公众号 - VB小源码(vb_xym)

原文出处及转载信息见文内详细说明,如有侵权,请联系 yunjia_community@tencent.com 删除。

原始发表时间:2019-08-28

本文参与腾讯云自媒体分享计划,欢迎正在阅读的你也加入,一起分享。

发表于

我来说两句

0 条评论
登录 后参与评论

相关文章

来自专栏品茗IT

SpringBoot入门建站全系列(十二)Spring Security使用token做认证

Spring 是一个非常流行和成功的 Java 应用开发框架。Spring Security 基于 Spring 框架,提供了一套 Web 应用安全性的完整解决...

43840
来自专栏佛系编程人

一键查询物流信息

百度上搜到一个'快递100'的网站,可以查询货物的物流信息,所以选择了它作为这次的小白鼠

17820
来自专栏佛系编程人

爬虫练习 | 利用有道翻译,做个自己的翻译程序

11630
来自专栏学海无涯

30.Swift学习之Codable协议

开发中推荐使用Paste JSON as Code • quicktype软件,可以根据JSON快速生成Model文件

8220
来自专栏葡萄城控件技术团队

七天学会NodeJS——第一天

Node.js 是一个能够在服务器端运行JavaScript的开放源代码、跨平台JavaScript运行环境。Node.js采用Google开发的V8内核运行代...

8820
来自专栏Android小知识

Android 快速解析xml

相信我们Android开发和后台请求回来的数据大部分都是json格式 但是如果后台返回给我们的数据时xml格式的怎么办呢 没错你可以选择SAX解析、PULL...

15520
来自专栏java 微风

Docker logs 查看实时日志(日志最后的N行、某刻后日志)

当我们输入 docker logs 的时候会转化为 Docker Client 向 Docker Daemon 发起请求,。

59930
来自专栏Java研发军团

SpringBoot整合WebSocket打造在线聊天室实战!!!

1、WebSocket是HTML5开始提供的一种在单个 TCP 连接上进行全双工通讯的协议。在WebSocket API中,浏览器和服务器只需要做一个握手的动作...

22630
来自专栏开发架构二三事

shiro实战之改造成token格式的无状态restful api

通过调用context.setSessionCreationEnabled(false)表示不创建会话;如果之后调用Subject.getSession()将抛...

1.1K20
来自专栏Java那些事

AJAX入门!

Ajax(Asynchronous JavaScript and XML) 异步JavaScript和XML

14720

扫码关注云+社区

领取腾讯云代金券

年度创作总结 领取年终奖励