Question

根据this site给出的代码（见下文），我想调整一些VBA Excel宏，使用NCI化学标识符解析器在http://cactus.nci.nih.gov/chemical/structure将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

而不是两次下载图像，而只是使用错误处理程序捕获未找到图像的时间。

<强>参考：

<强>更新

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

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

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

1 个答案:

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

1 个答案:

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