VBSCRIPT上的多维数组。插入到excel

时间：2017-08-04 14:22:06

标签： arrays excel vbscript soapui

所以我必须将数据从SOAPUI插入到Excel中，但是我有一个问题，直到数据到达买方价格，这里是图片。

Problem picture

如何在buyprice之后将数据插入excel？我需要多维数组吗？

    in_result = 1
    'arrResult(iResult) = header

    data = 0
    kolom = 1
    Dim kolom
    For iResult = 1 To total_arrResult-1 Step 1
        Hasil = Replace(Replace(Replace(Replace(Replace(arrResult(iResult + 1), """", ""), chr(10), ""), "}", ""), "]", ""), " ", "")
        wait(0.2)
        arrHasil = Split(Hasil, ",")
        wait(0.2)
        ' =================== get "countryCode", "alpha3Code", "numericCode", "shortName" ==================="
        arrcountryCode      = Split(arrHasil(0), ",")
        arrcountryCode2     = Split(arrcountryCode(0), ":")
        strcountryCode      = Trim(arrcountryCode2(0))
        value_countryCode   = Trim(arrcountryCode2(1))
        wait(0.2)
        arrbuyprice         = Split(arrHasil(17), ",")
        arrbuyprice2        = Split(arrbuyprice(0), ":")
        arrbuyprice3        = Split(arrbuyprice2(0), "[")
        strbuyprice         = Trim(arrbuyprice3(0))
        value_buyprice      = Trim(arrbuyprice3(0))
        wait(0.2)



        '' ======================================================================"
        kolom = kolom + 1
        urutan = iLoop + 1
        Call REPORT_EXCEL(No, CaptureFolder, strpathdt, strdt, value_ErrCode, value_ErrMsg, RowCount1, RowCount2, strcountryCode, stralpha3Code, strnumericCode, strshortName, strlastName, strgender, strbirthdate, strcitizenship, stridentno, stridentexp, strbirthplace, strmother, strtax,  strmailtwo, strmailthree, strmailfour, strmobile, stremail, strbuyQuota, strsellQuota, value_countryCode, value_alpha3Code,  value_mailfour, value_mobile, value_email, value_buyQuota, value_sellQuota, value_ErrResult, kolom, urutan)
        wait(1)
        data = 1

    Next

1 个答案:

答案 0 :(得分：2)

虽然它在技术上可能适用于您的示例数据，但JSON并不一定非常适合每个字段的换行符。使用Replace()和Split()解析数据非常脆弱，我建议使用像VbsJson这样的工具正确解析JSON。这是一个用日语编写的非常旧的页面，但是在评论中提到的一些小错误修正之后，代码本身对于我使用的一些系统非常有效。为方便起见，我在此处添加了VBSJson的修改版本。

Class VbsJson
    ' Author: Demon
    ' Date: 2012/5/3
    ' Website: http://demon.tw/my-work/vbs-json.html
    Private Whitespace, NumberRegex, StringChunk
    Private b, f, r, n, t

    Private Sub Class_Initialize
        Whitespace = " " & vbTab & vbCr & vbLf
        b = ChrW(8)
        f = vbFormFeed
        r = vbCr
        n = vbLf
        t = vbTab

        Set NumberRegex = New RegExp
        NumberRegex.Pattern = "(-?(?:0|[1-9]\d*))(\.\d+)?([eE][-+]?\d+)?"
        NumberRegex.Global = False
        NumberRegex.MultiLine = True
        NumberRegex.IgnoreCase = True

        Set StringChunk = New RegExp
        StringChunk.Pattern = "([\s\S]*?)([""\\\x00-\x1f])"
        StringChunk.Global = False
        StringChunk.MultiLine = True
        StringChunk.IgnoreCase = True
    End Sub

    ' Return a JSON string representation of a VBScript data structure
    ' Supports the following objects and types
    ' +-------------------+---------------+
    ' | VBScript          | JSON          |
    ' +===================+===============+
    ' | Dictionary        | object        |
    ' | Array             | array         |
    ' | String            | string        |
    ' | Number            | number        |
    ' | True              | true          |
    ' | False             | false         |
    ' | Null              | null          |
    ' +-------------------+---------------+
    Public Function Encode(ByRef obj)
        Dim buf, i, c, g
        Set buf = CreateObject("Scripting.Dictionary")
        Select Case VarType(obj)
            Case vbNull
                buf.Add buf.Count, "null"
            Case vbBoolean
                If obj Then
                    buf.Add buf.Count, "true"
                Else
                    buf.Add buf.Count, "false"
                End If
            Case vbInteger, vbLong, vbSingle, vbDouble
                buf.Add buf.Count, obj
            Case vbString
                buf.Add buf.Count, """"
                For i = 1 To Len(obj)
                    c = Mid(obj, i, 1)
                    Select Case c
                        Case """" buf.Add buf.Count, "\"""
                        Case "\"  buf.Add buf.Count, "\\"
                        Case "/"  buf.Add buf.Count, "/"
                        Case b    buf.Add buf.Count, "\b"
                        Case f    buf.Add buf.Count, "\f"
                        Case r    buf.Add buf.Count, "\r"
                        Case n    buf.Add buf.Count, "\n"
                        Case t    buf.Add buf.Count, "\t"
                        Case Else
                            If AscW(c) >= 0 And AscW(c) <= 31 Then
                                c = Right("0" & Hex(AscW(c)), 2)
                                buf.Add buf.Count, "\u00" & c
                            Else
                                buf.Add buf.Count, c
                            End If
                    End Select
                Next
                buf.Add buf.Count, """"
            Case vbArray + vbVariant
                g = True
                buf.Add buf.Count, "["
                For Each i In obj
                    If g Then g = False Else buf.Add buf.Count, ","
                    buf.Add buf.Count, Encode(i)
                Next
                buf.Add buf.Count, "]"
            Case vbObject
                If TypeName(obj) = "Dictionary" Then
                    g = True
                    buf.Add buf.Count, "{"
                    For Each i In obj
                        If g Then g = False Else buf.Add buf.Count, ","
                        buf.Add buf.Count, """" & i & """" & ":" & Encode(obj(i))
                    Next
                    buf.Add buf.Count, "}"
                Else
                    Err.Raise 8732,,"None dictionary object"
                End If
            Case Else
                buf.Add buf.Count, """" & CStr(obj) & """"
        End Select
        Encode = Join(buf.Items, "")
    End Function

    ' Return the VBScript representation of ``str(``
    ' Performs the following translations in decoding
    ' +---------------+-------------------+
    ' | JSON          | VBScript          |
    ' +===============+===================+
    ' | object        | Dictionary        |
    ' | array         | Array             |
    ' | string        | String            |
    ' | number        | Double            |
    ' | true          | True              |
    ' | false         | False             |
    ' | null          | Null              |
    ' +---------------+-------------------+
    Public Function Decode(ByRef str)
        Dim idx
        idx = SkipWhitespace(str, 1)

        If Mid(str, idx, 1) = "{" Then
            Set Decode = ScanOnce(str, 1)
        Else
            Decode = ScanOnce(str, 1)
        End If
    End Function

    Private Function ScanOnce(ByRef str, ByRef idx)
        Dim c, ms

        idx = SkipWhitespace(str, idx)
        c = Mid(str, idx, 1)

        If c = "{" Then
            idx = idx + 1
            Set ScanOnce = ParseObject(str, idx)
            Exit Function
        ElseIf c = "[" Then
            idx = idx + 1
            ScanOnce = ParseArray(str, idx)
            Exit Function
        ElseIf c = """" Then
            idx = idx + 1
            ScanOnce = ParseString(str, idx)
            Exit Function
        ElseIf c = "n" And StrComp("null", Mid(str, idx, 4)) = 0 Then
            idx = idx + 4
            ScanOnce = Null
            Exit Function
        ElseIf c = "t" And StrComp("true", Mid(str, idx, 4)) = 0 Then
            idx = idx + 4
            ScanOnce = True
            Exit Function
        ElseIf c = "f" And StrComp("false", Mid(str, idx, 5)) = 0 Then
            idx = idx + 5
            ScanOnce = False
            Exit Function
        End If

        Set ms = NumberRegex.Execute(Mid(str, idx))
        If ms.Count = 1 Then
            idx = idx + ms(0).Length
            ScanOnce = CDbl(ms(0))
            Exit Function
        End If

        Err.Raise 8732,,"No JSON object could be ScanOnced"
    End Function

    Private Function ParseObject(ByRef str, ByRef idx)
        Dim c, key, value
        Set ParseObject = CreateObject("Scripting.Dictionary")
        idx = SkipWhitespace(str, idx)
        c = Mid(str, idx, 1)

        If c = "}" Then
            Exit Function
        ElseIf c <> """" Then
            Err.Raise 8732,,"Expecting property name"
        End If

        idx = idx + 1

        Do
            key = ParseString(str, idx)

            idx = SkipWhitespace(str, idx)
            If Mid(str, idx, 1) <> ":" Then
                Err.Raise 8732,,"Expecting : delimiter"
            End If

            idx = SkipWhitespace(str, idx + 1)
            If Mid(str, idx, 1) = "{" Then
                Set value = ScanOnce(str, idx)
            Else
                value = ScanOnce(str, idx)
            End If
            ParseObject.Add key, value

            idx = SkipWhitespace(str, idx)
            c = Mid(str, idx, 1)
            If c = "}" Then
                Exit Do
            ElseIf c <> "," Then
                Err.Raise 8732,,"Expecting , delimiter. Got " & c & " at " & idx
            End If

            idx = SkipWhitespace(str, idx + 1)
            c = Mid(str, idx, 1)
            If c <> """" Then
                Err.Raise 8732,,"Expecting property name"
            End If

            idx = idx + 1
        Loop

        idx = idx + 1
    End Function

    Private Function ParseArray(ByRef str, ByRef idx)
        Dim c, values, value
        Set values = CreateObject("Scripting.Dictionary")
        idx = SkipWhitespace(str, idx)
        c = Mid(str, idx, 1)

        If c = "]" Then
            idx = idx + 1
            ParseArray = values.Items
            Exit Function
        End If

        Do
            idx = SkipWhitespace(str, idx)
            If Mid(str, idx, 1) = "{" Then
                Set value = ScanOnce(str, idx)
            Else
                value = ScanOnce(str, idx)
            End If
            values.Add values.Count, value

            idx = SkipWhitespace(str, idx)
            c = Mid(str, idx, 1)
            If c = "]" Then
                Exit Do
            ElseIf c <> "," Then
                Err.Raise 8732,,"Expecting , delimiter"
            End If

            idx = idx + 1
        Loop

        idx = idx + 1
        ParseArray = values.Items
    End Function

    Private Function ParseString(ByRef str, ByRef idx)
        Dim chunks, content, terminator, ms, esc, char
        Set chunks = CreateObject("Scripting.Dictionary")

        Do
            Set ms = StringChunk.Execute(Mid(str, idx))
            If ms.Count = 0 Then
                Err.Raise 8732,,"Unterminated string starting"
            End If

            content = ms(0).Submatches(0)
            terminator = ms(0).Submatches(1)
            If Len(content) > 0 Then
                chunks.Add chunks.Count, content
            End If

            idx = idx + ms(0).Length

            If terminator = """" Then
                Exit Do
            ElseIf terminator <> "\" Then
                Err.Raise 8732,,"Invalid control character"
            End If

            esc = Mid(str, idx, 1)

            If esc <> "u" Then
                Select Case esc
                    Case """" char = """"
                    Case "\"  char = "\"
                    Case "/"  char = "/"
                    Case "b"  char = b
                    Case "f"  char = f
                    Case "n"  char = n
                    Case "r"  char = r
                    Case "t"  char = t
                    Case Else Err.Raise 8732,,"Invalid escape"
                End Select
                idx = idx + 1
            Else
                char = ChrW("&H" & Mid(str, idx + 1, 4))
                idx = idx + 5
            End If

            chunks.Add chunks.Count, char
        Loop

        ParseString = Join(chunks.Items, "")
    End Function

    Private Function SkipWhitespace(ByRef str, ByVal idx)
        Do While idx <= Len(str) And _
            InStr(Whitespace, Mid(str, idx, 1)) > 0
            idx = idx + 1
        Loop
        SkipWhitespace = idx
    End Function

End Class

是的，这是很多代码，但这将允许您解析您喜欢的任何 JSON数据。如代码注释中所述，它将对象转换为VB字典，将数组转换为vbArrays，依此类推。要使用它，你要写...... 

Dim data
Set data = (new VbsJson).Decode(rawinput)

（在这种情况下，您必须使用Set，因为返回的值将是一个字典，它是一个Object引用。）

然后你可以拿出特定字段，例如＆＃34; errCode＆＃34;通过要求词典条目data("errCode")。

当你走得那么远时，你会发现buyPrice是一个对象数组，所以如果你尝试做data("buyPrice")(1)之类的事情，那么你需要使用{ {1}}再次。当涉及到这样的多级对象/数组时，VBScript非常差，因此您可能需要在此过程中构建一些额外的变量，例如迭代buyPrice数组。

如果您设法解析JSON并需要额外的帮助来遍历生成的对象，请通过将其添加到您的问题中让我更​​详细地了解。

相关问题
最新问题