Solved

How can I modify this code so that instead of replcaing text with apicture it places the picture after the text or floats it above the text

Posted on 2013-06-26
17
384 Views
Last Modified: 2013-06-30
The amazing MacroShadow provided this code.
How can I modify this code so that instead of replcaing text with apicture it places the picture after the text or floats it above the text
Option Explicit

Sub ProcessAll(strTxtToReplace As String, strImgPath As String)

    Dim WdDoc As Document, strFile As String, strPath As String

    strPath = PickFolder '("C:\Test") In this optional parameter you can add the starting directory for the f

    strFile = Dir(strPath & "*.docx")
    'Loop through all .docx files in that path
    Do While strFile <> ""
        Set WdDoc = Application.Documents.Open(strPath & strFile)

        'Do your Search/Replace
        ReplaceTextWithImage strTxtToReplace, strImgPath

        'Save it
        WdDoc.Close wdSaveChanges
        strFile = Dir
    Loop
End Sub

Sub ReplaceTextWithImage(strTextToReplace As String, strImagePath As String)

    Dim rngPicture As Range
    Dim strPicture As String
    Dim i As Integer
    Selection.HomeKey wdStory
    Selection.Find.ClearFormatting
    With Selection.Find
        Do While .Execute(FindText:=strTextToReplace, Forward:=True, MatchWholeWord:=False, _
                          MatchWildcards:=False, Wrap:=wdFindStop, MatchCase:=False) = True
            Set rngPicture = Selection.Range
            strImagePath = Replace(strImagePath, "\", "/")
            rngPicture.Text = ""
            ActiveDocument.Fields.Add rngPicture, wdFieldEmpty, "IncludePicture " & Chr(34) & strImagePath & Chr(34)
        Loop
    End With
    With ActiveDocument
        For i = .Fields.Count To 1 Step -1
            If .Fields(i).Type = wdFieldIncludePicture Then
                .Fields(i).Unlink
            End If
        Next i
    End With
    
End Sub

Function PickFolder(Optional strStartDir As Variant) As String
    Dim SA As Object, f As Object
    Set SA = CreateObject("Shell.Application")
    If Len(strStartDir) > 2 Then
        Set f = SA.BrowseForFolder(0, "Choose a folder", 16 + 32 + 64, strStartDir)
    Else
        Set f = SA.BrowseForFolder(0, "Choose a folder", 16 + 32 + 64)
    End If
    If (Not f Is Nothing) Then
        PickFolder = f.Items.Item.Path & "\"
    End If
    Set f = Nothing
    Set SA = Nothing
End Function

Open in new window

0
Comment
Question by:Dov_B
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 7
  • 6
  • 4
17 Comments
 
LVL 27

Accepted Solution

by:
MacroShadow earned 350 total points
ID: 39280720
Try this, I added a third parameter intMode.
0 = Replace text with picture
1 = Put picture before text
2 = Put picture after text
3 = Float picture on top of text

'Option Explicit

Sub ProcessAll(strTxtToReplace As String, strImgPath As String)

    Dim WdDoc As Document, strFile As String, strPath As String

    strPath = PickFolder '("C:\Test") In this optional parameter you can add the starting directory for the folder picker

    strFile = Dir(strPath & "*.docx")
    'Loop through all .docx files in that path
    Do While strFile <> ""
        Set WdDoc = Application.Documents.Open(strPath & strFile)

        'Do your Search/Replace
        ReplaceTextWithImage strTxtToReplace, strImgPath ' Don't forget the third parameter if you don't want the text replaced by the picture

        'Save it
        WdDoc.Close wdSaveChanges
        strFile = Dir
    Loop
End Sub

Sub ReplaceTextWithImage(strTextToFind As String, strImagePath As String, Optional intMode As Integer = 0)

    Const c_PlaceHolder As String = "@@##@@"

    Dim rngPicture As Range
    Dim strPicture As String
    Dim i As Integer, x As Integer

    Selection.HomeKey wdStory
    Selection.Find.ClearFormatting

    Select Case intMode
        Case 0    ' Replace text with picture
            ' Skip the select case structure, and continue with the code execution
        Case 1    ' Put picture before text
            With Selection.Find
                .Text = strTextToFind
                .Replacement.Text = c_PlaceHolder & strTextToFind
                .Forward = True
                .MatchWholeWord = False
                .Execute Replace:=wdReplaceAll
            End With
            strTextToFind = c_PlaceHolder
        Case 2    ' Put picture after text
            With Selection.Find
                .Text = strTextToFind
                .Replacement.Text = strTextToFind & c_PlaceHolder
                .Forward = True
                .MatchWholeWord = False
                .Execute Replace:=wdReplaceAll
            End With
            strTextToFind = c_PlaceHolder
        Case 3    ' Float picture on top of text
            x = 1
            With Selection.Find
                Do While .Execute(FindText:=strTextToFind, Forward:=True, MatchWholeWord:=False, Wrap:=wdFindStop) = True
                    Selection.MoveLeft Unit:=wdWord, Count:=1
                    With ActiveDocument
                        .Bookmarks.Add Name:="BMK" & x, Range:=Selection.Range
                        .Bookmarks("BMK" & x).Range.InlineShapes.AddPicture FileName:=strImagePath
                        .Bookmarks("BMK" & x).Select
                        .InlineShapes(1).ConvertToShape
                        .Bookmarks("BMK" & x).Delete
                    End With
                    Selection.MoveRight Unit:=wdWord, Count:=1
                    x = x + 1
                Loop
            End With
            Exit Sub
        Case Else
            MsgBox "Selected mode not supported." & vbCrLf & "Exiting Sub-Routine now...", vbCritical
            Exit Sub
    End Select

    Selection.HomeKey wdStory
    Selection.Find.ClearFormatting
    With Selection.Find
        Do While .Execute(FindText:=strTextToFind, Forward:=True, MatchWholeWord:=False, _
                          MatchWildcards:=False, Wrap:=wdFindStop, MatchCase:=False) = True
            Set rngPicture = Selection.Range
            strImagePath = Replace(strImagePath, "\", "/")
            rngPicture.Text = ""
            ActiveDocument.Fields.Add rngPicture, wdFieldEmpty, "IncludePicture " & Chr(34) & strImagePath & Chr(34)
        Loop
    End With

    With ActiveDocument
        For i = .Fields.Count To 1 Step -1
            If .Fields(i).Type = wdFieldIncludePicture Then
                .Fields(i).Unlink
            End If
        Next i
    End With

End Sub

Function PickFolder(Optional strStartDir As Variant) As String
    Dim SA As Object, f As Object
    Set SA = CreateObject("Shell.Application")
    If Len(strStartDir) > 2 Then
        Set f = SA.BrowseForFolder(0, "Choose a folder", 16 + 32 + 64, strStartDir)
    Else
        Set f = SA.BrowseForFolder(0, "Choose a folder", 16 + 32 + 64)
    End If
    If (Not f Is Nothing) Then
        PickFolder = f.Items.Item.Path & "\"
    End If
    Set f = Nothing
    Set SA = Nothing
End Function

Open in new window

0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 39280879
Try this
Sub AddPictures(strFolder As String, strText As String, strPictureName As String)

    Dim doc As Document
    Dim strFile As String
    Dim strPath As String

    strFile = Dir(strFolder & "\*.doc*")
    Do While strFile <> ""
        Set doc = Documents.Open(strFolder & "\" & strFile)
        AppendImage strText, strPictureName
        doc.Close wdSaveChanges
        strFile = Dir()
    Loop
End Sub

Sub AppendImage(strMarkerText As String, strImagePath As String)

    Dim rngPicture As Range
    Dim strPicture As String
    Dim i As Integer
    Dim rng As Range
    Set rng = ActiveDocument.Range
    With rng.Find
        .Text = strMarkerText
   
        Do While .Execute
            Set rngPicture = rng.Duplicate
            rngPicture.Collapse wdCollapseEnd
            ActiveDocument.InlineShapes.AddPicture strImagePath, False, True, rngPicture
        Loop
    End With
   
End Sub
0
 
LVL 76

Assisted Solution

by:GrahamSkan
GrahamSkan earned 150 total points
ID: 39280896
Oops. Should have refreshed this page before posting.
Also, you might appreciate a procedure to collect the three parameters form the user:
Here is my whole effort:
Option Explicit

Sub CallAddPictures()
Dim fd As FileDialog
Dim strDocFolder  As String
Dim strPictureFile As String
Dim strTargetText As String
  
   strTargetText = InputBox("Please enter the marker text to precede the picture")
   If Len(strTargetText) > 0 Then
   
        Set fd = Application.FileDialog(msoFileDialogFilePicker)
        fd.InitialFileName = "C:\MyPictures\*.jpg"
        fd.AllowMultiSelect = False
        fd.Title = "Select the picture"
        fd.Filters.Add "Images", "*.gif; *.jpg; *.jpeg", 1

         If fd.Show Then
            strPictureFile = fd.SelectedItems(1)
            Set fd = Application.FileDialog(msoFileDialogFolderPicker)
            With fd
                .Title = "Choose folder with documents"
                If .Show Then
                    strDocFolder = fd.SelectedItems(1)
                End If
            End With
        End If
    End If
    AddPictures strDocFolder, strTargetText, strPictureFile
End Sub

Sub AddPictures(strFolder As String, strText As String, strPictureName As String)

    Dim doc As Document
    Dim strFile As String
    Dim strPath As String

    strFile = Dir(strFolder & "\*.doc*")
    Do While strFile <> ""
        Set doc = Documents.Open(strFolder & "\" & strFile)
        AppendImage strText, strPictureName
        doc.Close wdSaveChanges
        strFile = Dir()
    Loop
End Sub

Sub AppendImage(strMarkerText As String, strImagePath As String)

    Dim rngPicture As Range
    Dim strPicture As String
    Dim rng As Range
    
    Set rng = ActiveDocument.Range
    With rng.Find
        .Text = strMarkerText
    
        Do While .Execute
            Set rngPicture = rng.Duplicate
            rngPicture.Collapse wdCollapseEnd
            ActiveDocument.InlineShapes.AddPicture strImagePath, False, True, rngPicture
        Loop
    End With
    
End Sub

Open in new window

0
Free Tool: Subnet Calculator

The subnet calculator helps you design networks by taking an IP address and network mask and returning information such as network, broadcast address, and host range.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

 
LVL 27

Expert Comment

by:MacroShadow
ID: 39280938
@GrahamSkan

Nice, but this only solves the first half of the question.

Also, instead of using the msoFileDialogFilePicker I think the folder picker in my example is more intuitive.
0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 39280976
Perhaps I misinterpreted the question, thinking that the asker wanted to know either how to create an inline shape, or how to create and accurately position a floating shape. Since many users get confused when further editing repositions a floating shape, I thought that the former would be the better choice.
0
 
LVL 27

Expert Comment

by:MacroShadow
ID: 39280979
Let's wait till the OP picks up.
0
 

Author Comment

by:Dov_B
ID: 39280986
Thanks to both of you I have completely updated win xp still get the error without settingg compatability mode as such
ActiveDocument.SetCompatibilityMode wdWord2003
even then get error when converting inline to floating I think its getting the wrong index on line 64 I also changed line 67 1 to 2 otherwise gets stuck in a loop
0
 
LVL 27

Expert Comment

by:MacroShadow
ID: 39280991
Which code are you using?
0
 

Author Comment

by:Dov_B
ID: 39280993
yours MacroShadow
0
 

Author Comment

by:Dov_B
ID: 39281012
online 64 I changed the index from 1 to x and that seems to have fixed it(MacroShadows code)
0
 
LVL 27

Expert Comment

by:MacroShadow
ID: 39281014
Interesting, on my machine it works as I posted it.
0
 

Author Comment

by:Dov_B
ID: 39281044
I have to go for about three four hours.  I am a teacher and this code will really help so many students with learning challenges. May G-d Bless the 2 of you many times over! A guten zoomer!
will b back!
0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 39281076
I think it's best to capture the newly-inserted inline shape into a variable and use that variable in the conversion.
Here is my attempt with the float option added.
Option Explicit

Sub CallAddPictures()
    Dim fd As FileDialog
    Dim strDocFolder  As String
    Dim strPictureFile As String
    Dim strTargetText As String
    Dim bFloat As Boolean

    strTargetText = InputBox("Please enter the marker text to precede the picture")
    Select Case MsgBox("Do you want the picture to float", vbYesNoCancel)
        Case vbCancel
            Exit Sub
        Case vbYes
            bFloat = True
    End Select
   
   If Len(strTargetText) > 0 Then
   
        Set fd = Application.FileDialog(msoFileDialogFilePicker)
        fd.InitialFileName = "C:\MyPictures\*.jpg"
        fd.AllowMultiSelect = False
        fd.Title = "Select the picture"
        fd.Filters.Add "Images", "*.gif; *.jpg; *.jpeg", 1

         If fd.Show Then
            strPictureFile = fd.SelectedItems(1)
            Set fd = Application.FileDialog(msoFileDialogFolderPicker)
            With fd
                .Title = "Choose folder with documents"
                If .Show Then
                    strDocFolder = fd.SelectedItems(1)
                End If
            End With
        End If
    End If
    AddPictures strDocFolder, strTargetText, strPictureFile, bFloat
End Sub

Sub AddPictures(strFolder As String, strText As String, strPictureName As String, bFloat As Boolean)

    Dim doc As Document
    Dim strFile As String
    Dim strPath As String

    strFile = Dir(strFolder & "\*.doc*")
    Do While strFile <> ""
        Set doc = Documents.Open(strFolder & "\" & strFile)
        AppendImage strText, strPictureName, bFloat
        doc.Close wdSaveChanges
        strFile = Dir()
    Loop
End Sub

Sub AppendImage(strMarkerText As String, strImagePath As String, bFloat As Boolean)

    Dim rngPicture As Range
    Dim strPicture As String
    Dim rng As Range
    Dim ilsh As InlineShape
    Set rng = ActiveDocument.Range
    With rng.Find
        .Text = strMarkerText
    
        Do While .Execute
            Set rngPicture = rng.Duplicate
            rngPicture.Collapse wdCollapseEnd
            Set ilsh = ActiveDocument.InlineShapes.AddPicture(strImagePath, False, True, rngPicture)
            If bFloat Then
                ilsh.ConvertToShape
            End If
        Loop
    End With
    
End Sub

Open in new window

0
 
LVL 27

Expert Comment

by:MacroShadow
ID: 39288088
Wow, what a long "three four hours".
0
 

Author Comment

by:Dov_B
ID: 39288161
woops sorry about that. Juggling to many things.
0
 

Author Comment

by:Dov_B
ID: 39288201
darn gettinthat Run-time error '-2147467259(80004005)'"
when converting to shape in with compatibilty mde set to 2003
0
 

Author Comment

by:Dov_B
ID: 39288211
Ok figured out the issue on my sytsem the inlineshape must be selected befor conversion
0

Featured Post

On Demand Webinar - Networking for the Cloud Era

This webinar discusses:
-Common barriers companies experience when moving to the cloud
-How SD-WAN changes the way we look at networks
-Best practices customers should employ moving forward with cloud migration
-What happens behind the scenes of SteelConnect’s one-click button

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Introduction Authors who set out to write any sort of lengthy piece for online submission—be it a long question or comment on a technical form, an article, or a substantial blog entry—often find it useful to work up a draft in an editor other t…
Shortcuts in Word Just the other day I had a training for Microsoft and they wanted me to show how well the new Windows and Office behaved on a touch device, which by the way is great, but it was only then that I realized that using keyboard shortc…
This video shows the viewer how to set up and create Footnotes in their document. Click on the References tab: Select "Insert Footnote": Type in desired text:
In a previous video Micro Tutorial here at Experts Exchange (http://www.experts-exchange.com/videos/1358/How-to-get-a-free-trial-of-Office-365-with-the-Office-2016-desktop-applications.html), I explained how to get a free, one-month trial of Office …

730 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question