Question

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

查找包含在＆＃34; ///＆＃34;中的SMILES（化学）序列在前面和＆＃34; ////＆＃34;在word文档中的1个单元格表的后面和内部
将该序列用作在线化学结构生成器的搜索条目
下载生成的图像并使用图像替换SMILES序列文本
对文档

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

＆＃13;

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

＆＃13;

宏观结果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

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

1 个答案: