1

根据本网站给出的代码（见下文），我想调整一些 VBA Excel 宏，以使用http://cactus.nci.nih.gov/chemical上的 NCI 化学标识符解析器将化学名称转换为 Excel 中的化学结构/结构体

特别是，我想扩展代码以具有一个附加函数来返回结构的图像（GIF），应该从中检索结构的图像

  XMLhttp.Open "GET", "http://cactus.nci.nih.gov/chemical/structure/" + name + "/image", False

然后应将其保存在调用公式的位置的 Excel 工作表中（可能还调整行的大小以适合返回的图像）。有没有想过如何做到这一点？

任何建议将不胜感激！

干杯，汤姆

Private Function strip(ByVal str As String) As String
  Dim last

  For i = 1 To Len(str) Step 1
    If Asc(Mid(str, i, 1)) < 33 Then
      last = i
    End If
  Next i

  If last > 0 Then
    strip = Mid(str, 1, last - 1)
  Else
    strip = str
  End If
End Function

Public Function getSMILES(ByVal name As String) As String
  Dim XMLhttp: Set XMLhttp = CreateObject("MSXML2.ServerXMLHTTP")
  XMLhttp.setTimeouts 2000, 2000, 2000, 2000
  XMLhttp.Open "GET", "http://cactus.nci.nih.gov/chemical/structure/" + name + "/smiles", False
  XMLhttp.send

  If XMLhttp.Status = 200 Then
    getSMILES = strip(XMLhttp.responsetext)
  Else
    getSMILES = ""
  End If
End Function
Public Function getInChIKey(ByVal name As String) As String
  Dim XMLhttp: Set XMLhttp = CreateObject("MSXML2.ServerXMLHTTP")
  XMLhttp.setTimeouts 1000, 1000, 1000, 1000
  XMLhttp.Open "GET", "http://cactus.nci.nih.gov/chemical/structure/" + name + "/stdinchikey", False
  XMLhttp.send

  If XMLhttp.Status = 200 Then
    getInChIKey = Mid(strip(XMLhttp.responsetext), 10)
  Else
    getInChIKey = ""
  End If
End Function
Public Function getIUPAC(ByVal name As String) As String
  Dim XMLhttp: Set XMLhttp = CreateObject("MSXML2.ServerXMLHTTP")
  XMLhttp.setTimeouts 1000, 1000, 1000, 1000
  XMLhttp.Open "GET", "http://cactus.nci.nih.gov/chemical/structure/" + name + "/iupac_name", False
  XMLhttp.send

  If XMLhttp.Status = 200 Then
    getIUPAC = strip(XMLhttp.responsetext)
  Else
    getIUPAC = ""
  End If
End Function
Public Function getCAS(ByVal name As String) As String
  Dim XMLhttp: Set XMLhttp = CreateObject("MSXML2.ServerXMLHTTP")
  XMLhttp.setTimeouts 1000, 1000, 1000, 1000
  XMLhttp.Open "GET", "http://cactus.nci.nih.gov/chemical/structure/" + name + "/cas", False
  XMLhttp.send

  If XMLhttp.Status = 200 Then
    getCAS = Mid(XMLhttp.responsetext, 1, InStr(XMLhttp.responsetext, Chr(10)) - 1)
  Else
    getCAS = ""
  End If
End Function
Public Function getCASnrs(ByVal name As String) As String
  Dim XMLhttp: Set XMLhttp = CreateObject("MSXML2.ServerXMLHTTP")
  XMLhttp.setTimeouts 1000, 1000, 1000, 1000
  XMLhttp.Open "GET", "http://cactus.nci.nih.gov/chemical/structure/" + name + "/cas", False
  XMLhttp.send

  If XMLhttp.Status = 200 Then
    getCASnrs = Replace(XMLhttp.responsetext, Chr(10), "; ")
  Else
    getCASnrs = ""
  End If
End Function
Public Function getSYNONYMS(ByVal name As String) As String
  Dim XMLhttp: Set XMLhttp = CreateObject("MSXML2.ServerXMLHTTP")
  XMLhttp.setTimeouts 1000, 1000, 1000, 1000
  XMLhttp.Open "GET", "http://cactus.nci.nih.gov/chemical/structure/" + name + "/names", False
  XMLhttp.send

  If XMLhttp.Status = 200 Then
    getSYNONYMS = Replace(XMLhttp.responsetext, Chr(10), "; ")
  Else
    getSYNONYMS = ""
  End If
End Function
4

1 回答 1

3

您可以使用类似于以下内容的方式获取图像：

    Sub Run()
getImage ("iron")
End Sub

Public Function getImage(ByVal name As String) As String
  Dim imgURL As String
  Dim XMLhttp: Set XMLhttp = CreateObject("MSXML2.ServerXMLHTTP")
  XMLhttp.setTimeouts 1000, 1000, 1000, 1000
  imgURL = "http://cactus.nci.nih.gov/chemical/structure/" + name + "/image"

  XMLhttp.Open "GET", imgURL, False
  XMLhttp.send

  If XMLhttp.Status = 200 Then
   'It exists so get the image
    Sheets(1).Shapes.AddPicture imgURL, msoFalse, msoTrue, 100, 100, 250, 250
  Else
    '
  End If
End Function

我相信这可以进一步简化为仅使用

Sheets(1).Shapes.AddPicture imgURL, msoFalse, msoTrue, 100, 100, 300, 300

而不是两次下载图像，而是简单地使用错误处理程序来捕获找不到图像。

参考：

更新：

使用活动表，宽度和高度为 300 像素：

 ActiveSheet.Shapes.AddPicture imgURL, msoFalse, msoTrue, 100, 100, 300, 300
于 2013-12-16T18:49:26.077 回答