excel - 在 Excel 中使用 VBA 宏从 NCI 化学标识符解析器中检索化学结构的图像

Question

基于 this site 给出的代码(见下文)我想调整一些 VBA Excel 宏，以便使用位于 http://cactus.nci.nih.gov/chemical/structure 的 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

Answer 1

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

    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

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

引用:

Can I use VBA to import images (gifs) from the web into Excel?

http://msdn.microsoft.com/en-us/library/microsoft.office.interop.excel.shapes.addpicture.ASPX

更新:

使用事件表，宽度和高度为 300 像素:

 ActiveSheet.Shapes.AddPicture imgURL, msoFalse, msoTrue, 100, 100, 300, 300