0

我正在尝试开发一个 VBA 脚本，该脚本从 excel 2010 电子表格中获取期刊标题的 ISSN 编号，并查询 Sherpa/Romeo 网络服务（版权政策数据库）。然后，它使用每个标题的自存档策略填充电子表格。

虽然它适用于我的测试电子表格中的大多数行，但我似乎无法获得一堆期刊标题的信息。巧合的是，他们都是一个出版商，我不确定它是否会有所作为，因为它是 XML。我认为我的代码一定有问题，但我无法确定为什么当存在日志标签时它认为 "resp.getElementsByTagName("journal").Length" 为 0。这是未按预期工作的 ISSN 的 XML 结果的链接。我试图将它与那些有效的结果进行比较，我看不出有任何区别。

我对这一切都很陌生，任何提示将不胜感激。我希望有人能帮帮忙 ：）

这是一个 ISSN 列表，我把 ** 放在那些在“期刊”标签中有数据但没有被选中的那些旁边。

0387-7604 **
1864-7782
1932-6203
0927-5568
0302-9743
1687-725X
0302-9743
0387-7604
0302-9743
1871-5192 **
1448-0220
1550-2783
1466-853X **
1438-4639 **
1642-431X
0142-0615
0096-140X
1746-1391
1096-3480
1065-9471
0260-2938
1055-9965
1084-8045 **

我的代码： 

Private Sub btnCopyright_Click()
Dim wsISSN As Worksheet
Set wsISSN = ThisWorkbook.Sheets("ISSN_2")
Dim ISSN As String
Dim URL As String
Dim baseURL As String
baseURL = "http://www.sherpa.ac.uk/romeo/api29.php?" 'I removed my API key' 

Dim i As Integer
Dim Last As Integer

i = 1
Last = wsISSN.Range("D6000").End(xlUp).Row
If Last = 1 Then Exit Sub

For i = 2 To Last 'second row to last row'
    Dim req As New xmlhttp
    ISSN = Cells(i, 4).Value

    If ISSN = "Invalid" Or ISSN = "" Then
        GoTo skipISSN
    End If

    URL = baseURL & "&issn=" & ISSN
    req.Open "GET", URL, False
    req.Send
    Debug.Print (req.ResponseText)

    Dim resp As New DOMDocument
    resp.LoadXML req.ResponseText
    Debug.Print (resp.getElementsByTagName("journal").Length)

    If resp.getElementsByTagName("journal").Length = 0 Then
        Cells(i, 5).Value = "unknown"
        Cells(i, 6).Value = "unknown"
        Cells(i, 7).Value = "unknown"
        Cells(i, 8).Value = "unknown"
        Cells(i, 9).Value = "unknown"
        Cells(i, 10).Value = "unknown"
        Cells(i, 11).Value = "unknown"
        GoTo skipISSN
    End If

        Dim preprint As String
        Dim preRest As String

        Debug.Print (resp.getElementsByTagName("prearchiving").Length)
        If resp.getElementsByTagName("prearchiving").Length = 0 Then
            Cells(i, 5).Value = "-"
        Else
            preprint = resp.SelectSingleNode("//preprints/prearchiving").Text
            If preprint = "can" Then
                Cells(i, 5).Value = "Yes"
            ElseIf preprint = "restricted" Then
                Cells(i, 5).Value = "restricted"
            Else
                Cells(i, 5).Value = "unknown"
            End If
        End If

        'any restrictions for archiving preprint?'
        Debug.Print (resp.getElementsByTagName("prerestrictions").Length)
        If resp.getElementsByTagName("prerestrictions").Length = 0 Then
            Cells(i, 6).Value = "-"
        Else
            preRest = resp.SelectSingleNode("//preprints/prerestrictions").Text
            Debug.Print (preRest)
            If preRest <> "" Then
                Cells(i, 6).Value = preRest
            Else
                Cells(i, 6).Value = "none"
            End If
        End If

        'is postprint allowed?'
        Dim postprint As String
        Dim postRest As String
        Debug.Print (resp.getElementsByTagName("postarchiving").Length)
        If resp.getElementsByTagName("postarchiving").Length = 0 Then
            Cells(i, 7).Value = "-"
        Else
            postprint = resp.SelectSingleNode("//postprints/postarchiving").Text
            If postprint = "can" Then
                Cells(i, 7).Value = "Yes"
            ElseIf postprint = "restricted" Then
                Cells(i, 7).Value = "restricted"
            Else
                Cells(i, 7).Value = "unknown"
            End If
        End If

        'any restrictions for archiving postprint?'
        Debug.Print (resp.getElementsByTagName("postrestrictions").Length)
        If resp.getElementsByTagName("postrestrictions").Length = 0 Then
            Cells(i, 8).Value = "-"
        Else
            postRest = resp.SelectSingleNode("//postprints/postrestrictions").Text
            Debug.Print (postRest)
            If postRest <> "" Then
                Cells(i, 8).Value = postRest
            Else
                Cells(i, 8).Value = "none"
            End If
        End If

        'is publishers version allowed?'

        Dim allCond As String

        Debug.Print (resp.getElementsByTagName("condition").Length)
        If resp.getElementsByTagName("condition").Length = 0 Then
            Cells(i, 9).Value = "-"
            Cells(i, 10).Value = "-"
            Cells(i, 11).Value = "-"
        Else
            allCond = resp.SelectSingleNode("//conditions").Text
            Debug.Print (allCond)
                If InStr(allCond, "embargo") > 0 Then
                    Cells(i, 9).Value = "maybe"
                    Cells(i, 10).Value = "yes"
                    Cells(i, 11).Value = allCond
                ElseIf InStr(allCond, "Publisher's version/PDF may be used") = 0 Then
                    Cells(i, 9).Value = "no"
                    Cells(i, 10).Value = "-"
                    Cells(i, 11).Value = allCond
                ElseIf InStr(allCond, "Publisher's version/PDF may be used") > 0 Then
                    Cells(i, 9).Value = "yes"
                    Cells(i, 10).Value = "-"
                    Cells(i, 11).Value = allCond
                ElseIf allCond = "" Then
                    Cells(i, 9).Value = "-"
                    Cells(i, 10).Value = "-"
                    Cells(i, 11).Value = "-"
                Else
                    Cells(i, 9).Value = "-"
                    Cells(i, 10).Value = "-"
                    Cells(i, 11).Value = allCond
                End If
            End If

skipISSN:

    Next i
End Sub
4

1 回答 1

0

要解决这个特定的无效编码问题，请尝试调整此代码：

Sub foo()

Dim URL As String
' access key removed - see link in question for value to use
URL = "http://sherpa.ac.uk/romeo/api29.php?ak=...&issn=0387-7604"

Dim req As New XMLHTTP60
req.Open "GET", URL, False
req.send

Dim resp As New DOMDocument60
resp.validateOnParse = False
resp.setProperty "ProhibitDTD", False

resp.loadXML StrConv(req.responseBody, vbUnicode)
Debug.Print resp.getElementsByTagName("journal").Item(0).XML

Set resp = Nothing
Set req = Nothing

End Sub

重要部分如下：

  • 使用“Microsoft XML, v6.0”对象 -XMLHTTP60和DOMDocument60- 而不是 v3.0 对象 -XMLHTTP和DOMDocument
  • 由于使用DOMDocument60，需要明确允许 DTD。还有，关validateOnParse
  • 而不是使用ResponseTextfromXMLHTTP60对象，使用responseBody（字节数组）然后使用StrConv将系统的默认代码页转换为 Unicode

此代码也适用于通过问题中给出的代码成功检索的 ISSN

于 2013-07-11T08:29:40.530 回答