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
343 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
  • 7
  • 6
  • 4
17 Comments
 
LVL 26

Accepted Solution

by:
MacroShadow earned 350 total points
Comment Utility
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
Comment Utility
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
Comment Utility
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
 
LVL 26

Expert Comment

by:MacroShadow
Comment Utility
@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
Comment Utility
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 26

Expert Comment

by:MacroShadow
Comment Utility
Let's wait till the OP picks up.
0
 

Author Comment

by:Dov_B
Comment Utility
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 26

Expert Comment

by:MacroShadow
Comment Utility
Which code are you using?
0
IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

 

Author Comment

by:Dov_B
Comment Utility
yours MacroShadow
0
 

Author Comment

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

Expert Comment

by:MacroShadow
Comment Utility
Interesting, on my machine it works as I posted it.
0
 

Author Comment

by:Dov_B
Comment Utility
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
Comment Utility
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 26

Expert Comment

by:MacroShadow
Comment Utility
Wow, what a long "three four hours".
0
 

Author Comment

by:Dov_B
Comment Utility
woops sorry about that. Juggling to many things.
0
 

Author Comment

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

Author Comment

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

Featured Post

Highfive Gives IT Their Time Back

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

Suggested Solutions

If you work with Word a lot, you probably use styles. If you use styles a lot, you've probably balled your fist more often than not when working with the ribbon. In Word 2007/2010, one of the things that I find missing when using styles is a quic…
This is written from a 'VBA for MS Word' perspective, but I am sure it applies to most other MS Office components where VBA is used.  One thing that really bugs me is slow code, ESPECIALLY when it's mine!  In programming there are so many ways to…
In this video, we show how to convert an image-only PDF file into a PDF Searchable Image file, that is, a file with both the image (typically from scanning) and text, which is created in an automated fashion with Optical Character Recognition (OCR) …
The viewer will learn how to make their project stand out over others by learning how to change colors and shapes, add spaces, change directions, and add bullets to their charts.

743 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

Need Help in Real-Time?

Connect with top rated Experts

17 Experts available now in Live!

Get 1:1 Help Now