MS Word VBA Macro to find text, use text to download an image, and replace the text with the image

Question

I've been trying to get a macro going that lets me do the following:

1. Find a SMILES (chemistry) sequence that is wrapped in "///" at the front and "////" at the back and inside of a 1 cell table in a word document
2. Use that sequence as a search entry for an online chemical structure generator
3. Download the generated image and Replace SMILES sequence text with the image
4. Repeat this for all other sequences in the Document

Here is what I have so far. This lets me replace the SMILES with the picture. I just need it to repeat/loop until there is no more finds.

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

And an example of the macro result here. I would greatly appreciate any help.

edit: example SMILES sequence CCC1(C(=O)NCNC1=O)C1=CC=CC=C1 and generated image for example structure edit2: updated with progress

Answer 1

Notes:

• Moved the Search code to a separate function for more flexibility (code re-use!)
• You should use HEAD in place of GET if you only want the HTTP status result: no point in asking for a full response if you don't need it...

Code:

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