MS Word VBA宏查找文本，使用文本下载图像，并用图像替换文本

Question

我一直试图让宏观方法让我做以下事情：

1. 找到一个SMILES（化学）序列，它包含在前面的“///”和单词文档中1个单元格表格的后面和内部的“////”
2. 将该序列用作在线化学结构生成器的搜索条目
3. 下载生成的图像并将SMILES序列文本替换为图像
4. 对文档中的所有其他序列重复此操作

这是我到目前为止所拥有的。这让我可以用图片替换SMILES。我只需要它重复/循环，直到没有更多的发现。

Sub Macro()
'Find a SMILES string between "///" and "////"
    With ActiveDocument
        Selection.Find.ClearFormatting

        With Selection.Find
            .Text = "///*////"
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchAllWordForms = False
            .MatchSoundsLike = False
            .MatchWildcards = True
        End With
        If Selection.Find.Execute Then
'Use found term as a search string for the online structure generator
        Dim name As String
        name = Selection.Range.Text
        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
        ActiveDocument.InlineShapes.AddPicture FileName:=imgURL, _
    LinkToFile:=False, SaveWithDocument:=True, Range:=Selection.Range
'Resize
With .InlineShapes(1)
    'this will convert to 'in front of text'
    .ConvertToShape
    'this will keep ratio
    .LockAspectRatio = msoTrue
    'this will adjust width to 2.0 inch
    .Width = InchesToPoints(2#)
End With
Selection.Range.Delete
        End If
        End If
 End With
 End Sub

并且宏观结果的一个例子here。我非常感谢任何帮助。

编辑：示例SMILES序列CCC1（C（= O）NCNC1 = O）C1 = CC = CC = C1和generated image for example structure edit2：随进度更新

Answer 1

笔记：

• 将搜索代码移动到单独的函数以获得更大的灵活性（代码重用！）
• 如果你只想要HTTP状态结果，你应该使用HEAD代替GET：如果你不需要它，没有必要要求完整的响应......

码：

Sub SmilesToImage()
    Const URL As String = "http://cactus.nci.nih.gov/chemical/structure/{smiles}/image"

    Dim smiles As String, colMatches As Collection, m As Range, imgUrl

    Set colMatches = GetMatches(ActiveDocument, "///*////")

    If colMatches.Count > 0 Then
        Dim XMLhttp: Set XMLhttp = CreateObject("MSXML2.ServerXMLHTTP")
        For Each m In colMatches
            Debug.Print m.Text
            imgUrl = Replace(URL, "{smiles}", m.Text)
            XMLhttp.Open "HEAD", imgUrl, False '<<< use HEAD as you only need the status result
            XMLhttp.send
            If XMLhttp.Status = 200 Then
                'm.Text = "" '<< uncomment if you want to remove the SMILES
                ActiveDocument.InlineShapes.AddPicture FileName:=imgUrl, _
                    LinkToFile:=False, SaveWithDocument:=True, Range:=m
            End If
        Next m
    End If
End Sub

 'Get a collection of Ranges matching the passed search pattern
 Function GetMatches(doc As Document, sPattern As String)
    Dim rv As New Collection, rng As Range
    Set rng = doc.Range
    With rng.Find
        .ClearFormatting
        .Forward = True
        .MatchWildcards = True
        .Text = sPattern
        Do While .Execute
            rv.Add doc.Range(rng.Start, rng.End)
            rng.Collapse Direction:=wdCollapseEnd
        Loop
    End With
    Set GetMatches = rv
End Function