使用Excel中的VBAmacros从NCI Chemical Identifier Resolver中检索化学结构的图像

基于本网站给出的代码（见下文），我想调整一些VBA Excelmacros来将化学名称转换成Excel中的化学结构，使用NCI Chemical Identifier Resolver， url为http://cactus.nci.nih.gov/chemical /结构体

具体来说，我想扩展代码，使其有一个额外的函数来返回结构的图像（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 

而不是下载图像的两倍，并简单地使用error handling程序来捕捉图像未find。

参考：

• 我可以使用VBA将图像（GIF）从networking导入到Excel中吗？
• http://msdn.microsoft.com/en-us/library/microsoft.office.interop.excel.shapes.addpicture.ASPX

更新：

使用activesheet和300像素的宽度和高度：

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