• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 386
  • Last Modified:

powerpoint not saving as in function search and replace in VB

Hi,
I have a function that goes through documents, recognises types and then does a search and replace. tha Word part works fine but the powerpoint isn't really working. at least it's not saving. I think I need expert eye at my humble code.
Dim strError As String
On Error GoTo EH
 
 
Dim wrd As Object
Dim ppt As Object
Dim strFileName As String
Dim strFilePath As String
Dim strSearchText As String
Dim strReplaceText As String
Dim strBeforeTag As String
Dim strAfterTag As String
Dim strSaveExtension As String
Dim strPrefix As String
Dim strSuffix As String
Dim strHighlightColor As Long
Dim strHighlightColorExtract As String
 
strBeforeTag = Me.ReplaceOptionTagBefore
strAfterTag = Me.ReplaceOptionTagAfter
strSearchText = [sbfrmProjectGlossary].Form.TargetLanguageTerm
strReplaceText = "^& " & strBeforeTag & [sbfrmProjectGlossary].Form.TargetLanguageCorrectedTerm & strAfterTag
 
 
strHighlightColorExtract = Right(Me!HighLightColour, Len(Me!HighLightColour) - InStrRev(Me!HighLightColour, ":") + 0)
 
If IsNull(strHighlightColorExtract) Then
strHighlightColor = 4
Else
strHighlightColor = strHighlightColorExtract
End If
 
strSaveExtension = Me.SaveAsExtension
 
'need to trap error if could not find document
'maybe even correct filename and path or reselect
 
 
  With [sbfrmReplacementProjectDocuments].Form.RecordsetClone
    .MoveFirst
    Do While .EOF = False
    strFileName = !ProjectDocumentName
    strPrefix = Left(strFileName, InStrRev(strFileName, ".") - 1)
    strSuffix = Right(strFileName, Len(strFileName) - InStrRev(strFileName, ".") + 1)
    strFilePath = !ProjectDocumentFilepath & "\"
 
Select Case strSuffix
Case ".doc", ".RTF", ".dot", ".docx"
 
' Beginning of Word section
 
'MsgBox "this is a Word document!" & strFileName & " suffix is" & strSuffix
 
 
    Set wrd = CreateObject("Word.Application")
      wrd.Documents.Open strFilePath & strFileName
                    'need to specify main form
                    If Me.ActivateTrackChanges = True Then
                    wrd.ActiveDocument.TrackRevisions = True
                    Else
                    wrd.ActiveDocument.TrackRevisions = False
                    End If
      wrd.Options.DefaultHighlightColorIndex = strHighlightColor
      wrd.Selection.Find.Replacement.ClearFormatting
      wrd.Selection.Find.Replacement.Highlight = True
    
    'start replacing list of words in glossary subform
    With [sbfrmProjectGlossary].Form.RecordsetClone
    .MoveFirst
    Do While .EOF = False
    wrd.Selection.Find.Execute FindText:=strSearchText, _
       ReplaceWith:=strReplaceText, _
        Format:=True, Replace:=2
       .MoveNext
    Loop
    End With
      
      wrd.ActiveDocument.SaveAs IncrementIfExists(strFilePath & strPrefix & strSaveExtension & strSuffix)
      DoEvents
      wrd.ActiveDocument.Close (True)
      DoEvents
      
      wrd.Quit
' end of Word section
 
Case Is = ".ppt"
'MsgBox "this is a ppt document!"
' Beginning of ppt section
 
    Dim oPres As Presentation
    Dim oSld As Slide
    Dim oShp As Shape
 
    Set ppt = CreateObject("PowerPoint.Application")
    ppt.Visible = False
    ppt.Presentations.Open strFilePath & strFileName
                
    'start replacing list of words in glossary subform
    With [sbfrmProjectGlossary].Form.RecordsetClone
    .MoveFirst
    Do While .EOF = False
    
    
    For Each oPres In ppt.Presentations
        For Each oSld In oPres.Slides
            For Each oShp In oSld.Shapes
                    Call ReplaceText(oShp, strSearchText, strReplaceText)
            Next oShp
        Next oSld
    Next oPres
    
    .MoveNext
    Loop
    End With
      
      
 
      ppt.ActivePresentation.SaveAs IncrementIfExists(strFilePath & strPrefix & strSaveExtension & strSuffix)
      DoEvents
      ppt.ActivePresentation.Close (True)
      DoEvents
    
    ppt.Quit
      Set ppt = Nothing
' end of ppt section
    
Case .xls
    MsgBox "this is an xls document!"
    'Call ManipulatePpt(filename)
 
Case .pdf
    MsgBox "this is a pdf document!"
    'Call ManipulatePpt(filename)
    
Case .txt Or .cvs
    MsgBox "this is a txt document!"
    'Call ManipulatePpt(filename)
    
Case Else
End Select
                     
    Set wrd = Nothing
        
      If booSuccess <> False Then
      .Edit
      !ReplacementResult = "strError"
      !ReplacementCompleted = Now()
      .Update
      Else
      .Edit
      !ReplacementResult = "Success"
      !ReplacementCompleted = Now()
      .Update
      End If
            
      .MoveNext
    Loop
  End With
 
 
MsgBox "Replacement Complete."
 
EH:
' Okay, your optimism was premature!
booSuccess = False
strError = "Error " & Err.Number & ": " & Err.Description
Resume Next

Open in new window

0
Shawn
Asked:
Shawn
  • 14
  • 14
1 Solution
 
ShawnAuthor Commented:
the replace text sub used is below just in case
Sub ReplaceText(oShp As Object, FindString As String, ReplaceString As String)
    Dim oTxtRng As TextRange
    Dim oTmpRng As TextRange
    Dim I As Integer
    Dim iRows As Integer
    Dim iCols As Integer
    Dim oShpTmp As Shape
 
 FindString = strSearchText
 ReplaceString = strReplaceText
 
    On Error Resume Next
    Select Case oShp.Type
Case 19    'msoTable
    For iRows = 1 To oShp.Table.Rows.Count
        For icol = 1 To oShp.Table.Rows(iRows).Cells.Count
            Set oShpTmp = oShp.Table.Rows(iRows).Cells(icol).Shape
            Call ReplaceText(oShpTmp, FindString, ReplaceString)
        Next
    Next
Case msoGroup    'Groups may contain shapes with text, so look within it
    For I = 1 To oShp.GroupItems.Count
        Call ReplaceText(oShp.GroupItems(I), FindString, ReplaceString)
    Next I
Case 21    ' msoDiagram
    For I = 1 To oShp.Diagram.Nodes.Count
        Call ReplaceText(oShp.Diagram.Nodes(I).TextShape, FindString, ReplaceString)
    Next I
Case Else
    If oShp.HasTextFrame Then
        If oShp.TextFrame.HasText Then
            Set oTxtRng = oShp.TextFrame.TextRange
            Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, _
                                          Replacewhat:=ReplaceString, WholeWords:=True)
            Do While Not oTmpRng Is Nothing
                Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, _
                                              Replacewhat:=ReplaceString, _
                                              After:=oTmpRng.Start + oTmpRng.Length, _
                                              WholeWords:=True)
            Loop
        End If
    End If
    End Select
End Sub

Open in new window

0
 
Chris BottomleyCommented:
Can't see at first sight ... do you hit your error output or does it simply not save?

If you get the error output then try removing the on error and see at which line it fails for a clue and paste here.

If not try putting a break in the PPT routine and see if it actually goes through , for example are you expecting it to process a PPS file.

Chris
0
 
ShawnAuthor Commented:
can't see any error - goes all the way. Not sure where the problem is.

0
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
Chris BottomleyCommented:
try stopping the script pre save and checking teh document to see if any changes have actually been made.

Chris
0
 
Chris BottomleyCommented:
I am however highly suspicious of lines 19:50.  They look to me as though most of them are word specific and therefore really ought to generating errors, or is the whole shebang run from a word file?

Any chance you can provide the host so I/we can evaluate the application .. if so recall you should not have anything sensitive as it will be publicly available.

Chris
0
 
ShawnAuthor Commented:
line 86 in my first post should be ppt specific. It starts like: Case Is = ".ppt".

before that there are some general declarations and the beginning of the documeent extension scanning. that should be it.

here is a test db...nothing sensitve in ther. the testdoc3.ppt.txt is really a ppt doc. you just have to take off the .txt  ext. Wouldn't upload as a ppt.
SearchAndReplaceProject.zip
0
 
ShawnAuthor Commented:
well I got it to open ppt and save as. It still doesn't perform the search and replace in between yet. Below is what I have so far.

btw the other thing is I had to make the ppt visible for it to save as. I think I need to change the ActivePresentation to something else for it to work without it being visible. Not a big deal right now. I could post this in another question if it is complicated.

just need the search and replace to work.
' Beginning of ppt section
 
    Dim oPres As Presentation
    Dim oSld As Slide
    Dim oShp As Shape
 
    Set ppt = CreateObject("PowerPoint.Application")
    ppt.Visible = True
    ppt.Presentations.Open strFilePath & strFileName, ReadOnly:=msoTrue
                
    'start replacing list of words in glossary subform
    With [sbfrmProjectGlossary].Form.RecordsetClone
    .MoveFirst
    Do While .EOF = False
    
    
    For Each oPres In ppt.ActivePresentation.Presentations
        For Each oSld In oPres.Slides
            For Each oShp In oSld.Shapes
                    Call ReplaceText(oShp, strSearchText, strReplaceText)
            Next oShp
        Next oSld
    Next oPres
    
    .MoveNext
    Loop
    End With
 
      ppt.ActivePresentation.SaveAs IncrementIfExists(strFilePath & strPrefix & strSaveExtension & strSuffix)
      DoEvents
      ppt.ActivePresentation.Close (True)
      DoEvents
    
    ppt.Quit
      Set ppt = Nothing
' end of ppt section

Open in new window

0
 
Chris BottomleyCommented:
Is it all shapes that are failing ... I am looking at the textframes and you do not seem to re-apply the changes to the textframe.  In the replace function you do the replace in oTmpRng but as far as I can see the changes are not applied to the textframe post replacement.

Chris
0
 
ShawnAuthor Commented:
yes I would say it is all shapes that are failiing. just tried adding a table and that is failing as well.

for the searce and replace part in powerpoint I got the majority of the code from here: http://skp.mvps.org/ppt00025.htm

I then integrated it into what I already had. In my opinion the problem is between the two. If you look at the code I just posted line 14 is my last line of code (pretty much the same as for Word above). Line 17 to 23 is the borrowed code. Line 25 my code resumes.
0
 
Chris BottomleyCommented:
I've stepped through for a text frame and confirmed my earlier belief:
In replacetext function

Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, _
                                          Replacewhat:=ReplaceString, WholeWords:=True)

Does not assign the replacement back top the shape.  I have modified the else clause accordingly and it now replaces text.  See what you think.

Chris
Sub ReplaceText(oShp As Object, FindString As String, ReplaceString As String)
    Dim oTxtRng As TextRange
    Dim oTmpRng As TextRange
    Dim I As Integer
    Dim iRows As Integer
    Dim iCols As Integer
    Dim oShpTmp As Shape
 
 FindString = strSearchText
 ReplaceString = strReplaceText
 
    On Error Resume Next
    Select Case oShp.Type
Case 19    'msoTable
    For iRows = 1 To oShp.Table.Rows.Count
        For icol = 1 To oShp.Table.Rows(iRows).Cells.Count
            Set oShpTmp = oShp.Table.Rows(iRows).Cells(icol).Shape
            Call ReplaceText(oShpTmp, FindString, ReplaceString)
        Next
    Next
Case msoGroup    'Groups may contain shapes with text, so look within it
    For I = 1 To oShp.GroupItems.Count
        Call ReplaceText(oShp.GroupItems(I), FindString, ReplaceString)
    Next I
Case 21    ' msoDiagram
    For I = 1 To oShp.Diagram.Nodes.Count
        Call ReplaceText(oShp.Diagram.Nodes(I).TextShape, FindString, ReplaceString)
    Next I
Case Else
    If oShp.HasTextFrame Then
        If oShp.TextFrame.HasText Then
            Set oTxtRng = oShp.TextFrame.TextRange
            oTxtRng = Replace(oTxtRng.Text, FindString, _
                                          ReplaceString)
        End If
    End If
    End Select
End Sub

Open in new window

0
 
ShawnAuthor Commented:
just tested and still doesn't replace. Uploading latest version
if you go to the form frmReplacementProject just click on the button "run replacement". Oh, you do have to etract on C drive and rename ppt (getting rid of .txt).

let me know what you think
SearchAndReplaceProject.zip
0
 
Chris BottomleyCommented:
Okay I did have to make two other changes which I had to do again so perhaps they weren't mistakes I made!

icols definition renamed as icol and I deleted the two assignments:
 FindString = strSearchText
 ReplaceString = strReplaceText

Since they are assigned in the sub call anyway.

Chris
Sub ReplaceText(oShp As Object, FindString As String, ReplaceString As String)
    Dim oTxtRng As TextRange
    Dim oTmpRng As TextRange
    Dim I As Integer
    Dim iRows As Integer
    Dim iCol As Integer
    Dim oShpTmp As Shape
 
' FindString = strSearchText
' ReplaceString = strReplaceText
 
    On Error Resume Next
    Select Case oShp.Type
Case 19    'msoTable
    For iRows = 1 To oShp.Table.Rows.Count
        For iCol = 1 To oShp.Table.Rows(iRows).Cells.Count
            Set oShpTmp = oShp.Table.Rows(iRows).Cells(iCol).Shape
            Call ReplaceText(oShpTmp, FindString, ReplaceString)
        Next
    Next
Case msoGroup    'Groups may contain shapes with text, so look within it
    For I = 1 To oShp.GroupItems.Count
        Call ReplaceText(oShp.GroupItems(I), FindString, ReplaceString)
    Next I
Case 21    ' msoDiagram
    For I = 1 To oShp.Diagram.Nodes.Count
        Call ReplaceText(oShp.Diagram.Nodes(I).TextShape, FindString, ReplaceString)
    Next I
Case Else
    If oShp.HasTextFrame Then
        If oShp.TextFrame.HasText Then
            Set oTxtRng = oShp.TextFrame.TextRange
            oTxtRng = Replace(oTxtRng.Text, FindString, _
                                          ReplaceString)
        End If
    End If
    End Select
End Sub

Open in new window

0
 
ShawnAuthor Commented:
good eye for icol though still no search and replace luck.

 I'm still convinced there's something wrong in my code above
0
 
Chris BottomleyCommented:
I've just looked at the code in your updated post, it doesn't have the correction for the text replacement block I posted before it?

Chris
0
 
ShawnAuthor Commented:
sorry I'm a little confused. You mean in my post where I uploaded the db? pretty sure it's in there
0
 
Chris BottomleyCommented:
Sorry, i've just uploaded the file a second time and this is the code:

Chris
Sub ReplaceText(oShp As Object, FindString As String, ReplaceString As String)
    Dim oTxtRng As TextRange
    Dim oTmpRng As TextRange
    Dim i As Integer
    Dim iRows As Integer
    Dim iCols As Integer
    Dim oShpTmp As Shape
 
 FindString = strSearchText
 ReplaceString = strReplaceText
 
    On Error Resume Next
    Select Case oShp.Type
Case 19    'msoTable
    For iRows = 1 To oShp.Table.Rows.Count
        For icol = 1 To oShp.Table.Rows(iRows).Cells.Count
            Set oShpTmp = oShp.Table.Rows(iRows).Cells(icol).Shape
            Call ReplaceText(oShpTmp, FindString, ReplaceString)
        Next
    Next
Case msoGroup    'Groups may contain shapes with text, so look within it
    For i = 1 To oShp.GroupItems.Count
        Call ReplaceText(oShp.GroupItems(i), FindString, ReplaceString)
    Next i
Case 21    ' msoDiagram
    For i = 1 To oShp.Diagram.Nodes.Count
        Call ReplaceText(oShp.Diagram.Nodes(i).TextShape, FindString, ReplaceString)
    Next i
Case Else
    If oShp.HasTextFrame Then
        If oShp.TextFrame.HasText Then
            Set oTxtRng = oShp.TextFrame.TextRange
            Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, _
                                          Replacewhat:=ReplaceString, WholeWords:=True)
            Do While Not oTmpRng Is Nothing
                Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, _
                                              Replacewhat:=ReplaceString, _
                                              After:=oTmpRng.Start + oTmpRng.Length, _
                                              WholeWords:=True)
                                                                                           
                                              
            Loop
        End If
    End If
    End Select
End Sub

Open in new window

0
 
ShawnAuthor Commented:
Ok, I've applied this but still no change.
0
 
Chris BottomleyCommented:
SInce the replacement is specific to PPT I have no problem in running this in my test application ... it has to be equivalent and independant of your database.

I cannot currently get all shapes working, but it is working fine now for me with tables and in the version posted earlier in normal frames, title boxes etc.  Where you say it does not work at all, have you tried it with my changes and the target text for example in one of the title boxes?

It is important to understand why it is is not working at all and I am concerned that we are progressing but that you are not aware of it.

Chris
0
 
ShawnAuthor Commented:
Hi Chris,

Yes I confirm I have tried several times with all of the code suggestions you have posted. I will go over this again to see if I have missed something.

I have now uploaded twice a test db but no confirmation you have even looked at it. It would at least be a better way to see the exact same scenario. You might also see why your testing is working and why mine is not.

I asked for more attention because I feel we are in a bit of a rut. Of couse as mentioned above I will look over all of your comments/code again to see if I have missed something. Maybe you could have a look at my test db and see where there may be a difference. I'm going to attach my latest version to be sure we are on the same page.

cheers, and thanks for your help. It IS appreciated :)

Shawn
SearchAndReplaceProject-new.zip
0
 
Chris BottomleyCommented:
It is generally better to have example files to work with, in this case having a setup that matches yours and understanding the scope of your project makes this a major issue in my terms.  The essence is that you are trying to replace text via a loop of:

for each presentation
    for each slide
        for each shape
            process components of the shape via the specific subroutine.

It is working for me at least with default boxes and tables.  Neither worked initially but seem to do so now ... I toggle valuers and they change everytime.

Note I also looked carefully at the your code | their code interface and have no problems with that since it is what I am running anyway.

I will out of interest include it for your understanding before I take another try at modifying and understanding your files.

Chris
vbareplacetext.ppt.zip
0
 
ShawnAuthor Commented:
thanks Chris,
I'm going through it as well to see if I have missed something
0
 
Chris BottomleyCommented:
In your original post of the ppt section you gave the snippet:

    For Each oPres In ppt.ActivePresentation.Presentations
        For Each oSld In oPres.Slides
            For Each oShp In oSld.Shapes
                    Call ReplaceText(oShp, strSearchText, strReplaceText)
            Next oShp
        Next oSld
    Next oPres
 
in your latest file, the code run by the button, (command48) has:

    Set ppt = CreateObject("PowerPoint.Application")
    ppt.Visible = True
    ppt.Presentations.Open strFilePath & strFileName ', ReadOnly:=msoTrue
               
...
    'For Each oPres In ppt.ActivePresentation.Presentations
        For Each oSld In oPres.Slides

i.e. the opres definition is missing so everything fails, I am about to change this and follow through and will let you know.

Chris
0
 
Chris BottomleyCommented:
In the module of your form the following is a complete code replacement.

1. The 'fix' for the pages after page 1 is the code I previously advised, which I have applied to the replace routine as called by the button.
2. The fix for the first page of the function is to append some code to accomodate tables, which is also herein though not necessarily tidy ... it is a huge chunk of work though for this site.

I have with some learning managed to work with your database so I know the changes as tested work ok, and it hopefully just needs you to apply them to the form code page and test it.

Chris
Option Compare Database
 
Private Sub cbChooseFiles_Click()
Call InsertFileANDFilepath
[sbfrmReplacementProjectDocuments].Form.Requery
 
End Sub
Private Sub InsertFileANDFilepath(Optional strFolder As String = "\\Fs1\Op_Araxi_France$\Traductions\")
    Dim fso As Scripting.FileSystemObject
    Dim aFiles As Variant
    Dim strTemp As String
    Dim i As Integer
    Dim strStartSplit As String
    Dim strFileName As String
    Dim strSQL As String
    Dim strFilePath As String
    
     
    Set fso = New Scripting.FileSystemObject
    aFiles = apiBrowseFiles("Add Attachment File(s)", strFolder)
     
    'Only process if file(s) selected
    If Not IsEmpty(aFiles) Then
        ' aFiles is an Array, Option Base 1
 
        For i = 1 To UBound(aFiles)
        strFileName = Mid(aFiles(i), InStrRev(aFiles(i), "\") + 1)
        strFilePath = Left(aFiles(i), InStrRev(aFiles(i), "\") - 1)
        strSQL = "INSERT INTO tblReplacementProjectDocuments (ReplacementProjectID, ProjectDocumentFilepath, ProjectDocumentName) " & _
        "VALUES (" & Me!ReplacementProjectID & ", " & "'" & strFilePath & "', '" & strFileName & "');"
        
        CurrentDb.Execute strSQL, dbFailOnError
        Next
        
        
    End If
 
End Sub
 
Private Sub Command25_Click()
 
Dim tmpColor As Long
tmpColor = aDialogColor(Me.hwnd)    'If aDialogColor returns -1 then the user clicked cancel
 
Me.HighLightColour = tmpColor
Me.HighLightColour.BackColor = tmpColor
 
End Sub
 
Private Sub Command48_Click()
 
Dim strError As String
On Error GoTo EH
 
 
Dim wrd As Object
Dim ppt As Object
Dim xls As Object
Dim strFileName As String
Dim strFilePath As String
Dim strSearchText As String
Dim strReplaceText As String
Dim strBeforeTag As String
Dim strAfterTag As String
Dim strSaveExtension As String
Dim strPrefix As String
Dim strSuffix As String
Dim strHighlightColor As Long
Dim strHighlightColorExtract As String
 
strBeforeTag = Me.ReplaceOptionTagBefore
strAfterTag = Me.ReplaceOptionTagAfter
 
strHighlightColorExtract = Right(Me!HighLightColour, Len(Me!HighLightColour) - InStrRev(Me!HighLightColour, ":") + 0)
 
If IsNull(strHighlightColorExtract) Then
strHighlightColor = 4
Else
strHighlightColor = strHighlightColorExtract
End If
 
strSaveExtension = Me.SaveAsExtension
 
'need to trap error if could not find document
'maybe even correct filename and path or reselect
 
 
  With [sbfrmReplacementProjectDocuments].Form.RecordsetClone
    .MoveFirst
    Do While .EOF = False
    strFileName = !ProjectDocumentName
    strPrefix = Left(strFileName, InStrRev(strFileName, ".") - 1)
    strSuffix = Right(strFileName, Len(strFileName) - InStrRev(strFileName, ".") + 1)
    strFilePath = !ProjectDocumentFilepath & "\"
 
Select Case strSuffix
Case ".doc", ".RTF", ".dot", ".docx", ".txt", ".csv"
 
' Beginning of Word section
 
'MsgBox "this is a Word document!" & strFileName & " suffix is" & strSuffix
 
 
    Set wrd = CreateObject("Word.Application")
      wrd.Documents.Open strFilePath & strFileName
                    'need to specify main form
                    If Me.ActivateTrackChanges = True Then
                    wrd.ActiveDocument.TrackRevisions = True
                    Else
                    wrd.ActiveDocument.TrackRevisions = False
                    End If
      wrd.Options.DefaultHighlightColorIndex = strHighlightColor
      wrd.Selection.Find.Replacement.ClearFormatting
      If Forms![frmReplacementProject]!HighLight = True Then
      wrd.Selection.Find.Replacement.HighLight = True
      End If
          
    'start replacing list of words in glossary subform
    With [sbfrmProjectGlossary].Form.RecordsetClone
    .MoveFirst
    Do While .EOF = False
        
    strSearchText = .TargetLanguageTerm
    If Forms![frmReplacementProject]!ReplaceOptionID = 1 Then
    strReplaceText = .TargetLanguageCorrectedTerm
    Else
    strReplaceText = strSearchText & " " & strBeforeTag & .TargetLanguageCorrectedTerm & strAfterTag
    End If
    
    wrd.Selection.Find.Execute FindText:=strSearchText, _
       ReplaceWith:=strReplaceText, _
        Format:=True, Replace:=2, Wrap:=wdFindContinue, Forward:=True
        
    'Now search all other stories using Ranges
    Call FindReplaceAnywhere
    
        
       .MoveNext
    Loop
    End With
      
      wrd.ActiveDocument.SaveAs IncrementIfExists(strFilePath & strPrefix & strSaveExtension & strSuffix)
      DoEvents
      wrd.ActiveDocument.Close (True)
      DoEvents
      
      wrd.Quit
' end of Word section
 
Case Is = ".ppt", ".pptx"
'MsgBox "this is a ppt document!"
' Beginning of ppt section
 
    Dim oPres As Presentation
    Dim oSld As Slide
    Dim oShp As Object
 
    Set ppt = CreateObject("PowerPoint.Application")
    ppt.Visible = True
    ppt.Presentations.Open strFilePath & strFileName ', ReadOnly:=msoTrue
                
    'start replacing list of words in glossary subform
    With [sbfrmProjectGlossary].Form.RecordsetClone
    .MoveFirst
    Do While .EOF = False
 
    strSearchText = .TargetLanguageTerm
    If Forms![frmReplacementProject]!ReplaceOptionID = 1 Then
    strReplaceText = .TargetLanguageCorrectedTerm
    Else
    strReplaceText = strSearchText & " " & strBeforeTag & .TargetLanguageCorrectedTerm & strAfterTag
    End If
 
    For Each oPres In ppt.Presentations
        For Each oSld In oPres.Slides
            For Each oShp In oSld.Shapes
                    Call ReplaceText(oShp, strSearchText, strReplaceText)
 
                    
            Next oShp
        Next oSld
    Next oPres
    
    .MoveNext
    Loop
    End With
 
      ppt.ActivePresentation.SaveAs IncrementIfExists(strFilePath & strPrefix & strSaveExtension & strSuffix)
      DoEvents
      ppt.ActivePresentation.Close (True)
      DoEvents
    
    ppt.Quit
      Set ppt = Nothing
' end of ppt section
    
Case ".xls", ".xlsx"
 
    'MsgBox "this is an xls document!"
On Error Resume Next            'This is needed in case one does not have rights to a particular folder
 
'Open up Excel
Set xls = CreateObject("Excel.Application")
 
xls.Visible = False
xls.DisplayAlerts = False
 
Set objCurrentBook = xls.Workbooks.Open(strFilePath & strFileName)
objCurrentBook.Activate
          
    'start replacing list of words in glossary subform
    With [sbfrmProjectGlossary].Form.RecordsetClone
    .MoveFirst
    Do While .EOF = False
    
    strSearchText = .TargetLanguageTerm
    If Forms![frmReplacementProject]!ReplaceOptionID = 1 Then
    strReplaceText = .TargetLanguageCorrectedTerm
    Else
    strReplaceText = strSearchText & " " & strBeforeTag & .TargetLanguageCorrectedTerm & strAfterTag
    End If
    
    'Go through each worsksheet within the spreadsheet
    For Each objWorksheet In objCurrentBook.Worksheets
    objWorksheet.Cells.Replace strSearchText, strReplaceText
    Next
 
       .MoveNext
    Loop
    End With
      
 
      objCurrentBook.SaveAs IncrementIfExists(strFilePath & strPrefix & strSaveExtension & strSuffix)
      DoEvents
      objCurrentBook.Close
      DoEvents
      
      xls.Quit
 
            
 
Case .pdf
    MsgBox "this is a pdf document! Please convert it to an editable format first"
   
 
    
Case Else
End Select
                     
    Set wrd = Nothing
        
      If booSuccess <> False Then
      .Edit
      !ReplacementResult = "strError"
      !ReplacementCompleted = Now()
      .Update
      Else
      .Edit
      !ReplacementResult = "Success"
      !ReplacementCompleted = Now()
      .Update
      End If
            
      .MoveNext
    Loop
  End With
 
 
MsgBox "Replacement Complete."
 
EH:
' Okay, your optimism was premature!
booSuccess = False
strError = "Error " & Err.Number & ": " & Err.Description
Resume Next
 
End Sub
 
Public Sub FindReplaceAnywhere()
 
  Dim rngStory As Word.Range
  Dim pFindTxt As String
  Dim pReplaceTxt As String
  Dim lngJunk As Long
  Dim oShp As Shape
    
  pFindTxt = strSearchText
  pReplaceTxt = strReplaceText
    
  'Fix the skipped blank Header/Footer problem
  lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
  'Iterate through all story types in the current document
  For Each rngStory In ActiveDocument.StoryRanges
    'Iterate through all linked stories
    Do
      SearchAndReplaceInStory rngStory, pFindTxt, pReplaceTxt
      On Error Resume Next
      Select Case rngStory.StoryType
      Case 6, 7, 8, 9, 10, 11
        If rngStory.ShapeRange.Count > 0 Then
          For Each oShp In rngStory.ShapeRange
            If oShp.TextFrame.HasText Then
              SearchAndReplaceInStory oShp.TextFrame.TextRange, _
              pFindTxt, pReplaceTxt
            End If
          Next
       End If
      Case Else
        'Do Nothing
      End Select
      On Error GoTo 0
      'Get next linked story (if any)
      Set rngStory = rngStory.NextStoryRange
    Loop Until rngStory Is Nothing
  Next
 
 
End Sub
 
Public Sub SearchAndReplaceInStory(ByVal rngStory As Word.Range, _
ByVal strSearch As String, ByVal strReplace As String)
 
  With rngStory.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = strSearch
    .Replacement.Text = strReplace
    .Wrap = wdFindContinue
    .Execute Replace:=wdReplaceAll
  End With
 
End Sub
 
Sub ReplaceText(oShp As Object, FindString As String, ReplaceString As String)
    Dim oTxtRng As TextRange
    Dim oTmpRng As TextRange
    Dim oShpTmp As Object
    Dim i As Integer
    Dim iRows As Integer
    Dim iCol As Integer
 
 'FindString = strSearchText
 'ReplaceString = strReplaceText
 
    On Error Resume Next
    Select Case oShp.Type
Case 19    'msoTable
    For iRows = 1 To oShp.Table.Rows.Count
        For iCol = 1 To oShp.Table.Rows(iRows).Cells.Count
            Set oShpTmp = oShp.Table.Rows(iRows).Cells(iCol).Shape
            Call ReplaceText(oShpTmp, FindString, ReplaceString)
        Next
    Next
Case msoGroup    'Groups may contain shapes with text, so look within it
    For i = 1 To oShp.GroupItems.Count
        Call ReplaceText(oShp.GroupItems(i), FindString, ReplaceString)
    Next i
Case 21    ' msoDiagram
    For i = 1 To oShp.Diagram.Nodes.Count
        Call ReplaceText(oShp.Diagram.Nodes(i).TextShape, FindString, ReplaceString)
    Next i
Case Else
    If oShp.HasTextFrame Then
        If oShp.TextFrame.HasText Then
'            Set oTxtRng = oShp.TextFrame.TextRange
            oShp.TextFrame.TextRange.Text = Replace(oShp.TextFrame.TextRange.Text, FindString, ReplaceString)
'            oTxtRng = Replace(oTxtRng.Text, FindString, _
                                          ReplaceString)
        End If
    Else
        For iRows = 1 To oShp.Table.Rows.Count
            For iCol = 1 To oShp.Table.Rows(iRows).Cells.Count
                Set oShpTmp = oShp.Table.Rows(iRows).Cells(iCol).Shape
'                Call ReplaceText(oShpTmp, FindString, ReplaceString)
                oShpTmp.TextFrame.TextRange = Replace(oShpTmp.TextFrame.TextRange.Text, FindString, _
                                          ReplaceString)
            Next
        Next
    End If
    End Select
 
End Sub
Sub ReplaceTextMyVersion(oShp As Object, FindString As String, ReplaceString As String)
    Dim oTxtRng As TextRange
    Dim oTmpRng As TextRange
    Dim i As Integer
    Dim iRows As Integer
    Dim iCol As Integer
    Dim oShpTmp As Shape
 
 'FindString = strSearchText
 'ReplaceString = strReplaceText
 
    On Error Resume Next
    Select Case oShp.Type
Case 19    'msoTable
    For iRows = 1 To oShp.Table.Rows.Count
        For iCol = 1 To oShp.Table.Rows(iRows).Cells.Count
            Set oShpTmp = oShp.Table.Rows(iRows).Cells(iCol).Shape
            Call ReplaceText(oShpTmp, FindString, ReplaceString)
        Next
    Next
Case msoGroup    'Groups may contain shapes with text, so look within it
    For i = 1 To oShp.GroupItems.Count
        Call ReplaceText(oShp.GroupItems(i), FindString, ReplaceString)
    Next i
Case 21    ' msoDiagram
    For i = 1 To oShp.Diagram.Nodes.Count
        Call ReplaceText(oShp.Diagram.Nodes(i).TextShape, FindString, ReplaceString)
    Next i
Case Else
    If oShp.HasTextFrame Then
        If oShp.TextFrame.HasText Then
            Set oTxtRng = oShp.TextFrame.TextRange
            Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, _
                                          Replacewhat:=ReplaceString, WholeWords:=True)
            Do While Not oTmpRng Is Nothing
                Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, _
                                              Replacewhat:=ReplaceString, _
                                              After:=oTmpRng.Start + oTmpRng.Length, _
                                              WholeWords:=True)
                                                                                           
                                              
            Loop
        End If
    End If
    End Select
End Sub
 
Sub ReplaceTextCantRememberwhichversion(oShp As Object, FindString As String, ReplaceString As String)
    Dim oTxtRng As TextRange
    Dim oTmpRng As TextRange
    Dim i As Integer
    Dim iRows As Integer
    Dim iCol As Integer
    Dim oShpTmp As Shape
 
 'FindString = strSearchText
 'ReplaceString = strReplaceText
 
    On Error Resume Next
    Select Case oShp.Type
Case 19    'msoTable
    For iRows = 1 To oShp.Table.Rows.Count
        For iCol = 1 To oShp.Table.Rows(iRows).Cells.Count
            Set oShpTmp = oShp.Table.Rows(iRows).Cells(iCol).Shape
            Call ReplaceText(oShpTmp, FindString, ReplaceString)
        Next
    Next
Case msoGroup    'Groups may contain shapes with text, so look within it
    For i = 1 To oShp.GroupItems.Count
        Call ReplaceText(oShp.GroupItems(i), FindString, ReplaceString)
    Next i
Case 21    ' msoDiagram
    For i = 1 To oShp.Diagram.Nodes.Count
        Call ReplaceText(oShp.Diagram.Nodes(i).TextShape, FindString, ReplaceString)
    Next i
Case Else
    If oShp.HasTextFrame Then
        If oShp.TextFrame.HasText Then
            Set oTxtRng = oShp.TextFrame.TextRange
            Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, _
                                          Replacewhat:=ReplaceString, WholeWords:=True)
            Do While Not oTmpRng Is Nothing
                Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, _
                                              Replacewhat:=ReplaceString, _
                                              After:=oTmpRng.Start + oTmpRng.Length, _
                                              WholeWords:=True)
                                                                                           
                                              
            Loop
        End If
    End If
    End Select
End Sub
 
 
 
 
Private Sub RunReplacements4_Click()
Dim strError As String
On Error GoTo EH
 
 
Dim wrd As Object
Dim strFileName As String
Dim strFilePath As String
Dim strSearchText As String
Dim strReplaceText As String
Dim strBeforeTag As String
Dim strAfterTag As String
Dim strSaveExtension As String
Dim strPrefix As String
Dim strSuffix As String
Dim strHighlightColor As Long
Dim strHighlightColorExtract As String
 
strHighlightColorExtract = Right(Me!HighLightColour, Len(Me!HighLightColour) - InStrRev(Me!HighLightColour, ":") + 0)
 
If IsNull(strHighlightColorExtract) Then
strHighlightColor = 4
Else
strHighlightColor = strHighlightColorExtract
End If
 
strBeforeTag = Me.ReplaceOptionTagBefore
strAfterTag = Me.ReplaceOptionTagAfter
 
 
strSaveExtension = Me.SaveAsExtension
 
'need to trap error if could not find document
'maybe even correct filename and path or reselect
 
 
  With [sbfrmReplacementProjectDocuments].Form.RecordsetClone
    .MoveFirst
    Do While .EOF = False
    strFileName = !ProjectDocumentName
    strPrefix = Left(strFileName, InStrRev(strFileName, ".") - 1)
    strSuffix = Right(strFileName, Len(strFileName) - InStrRev(strFileName, ".") + 1)
    strFilePath = !ProjectDocumentFilepath & "\"
 
 
 
Select Case strSuffix
Case .doc
 
' Beginning of Word section
    Set wrd = CreateObject("Word.Application")
      wrd.Documents.Open strFilePath & strFileName
                    'need to specify main form
                    If Me.ActivateTrackChanges = True Then
                    wrd.ActiveDocument.TrackRevisions = True
                    Else
                    wrd.ActiveDocument.TrackRevisions = False
                    End If
      wrd.Options.DefaultHighlightColorIndex = strHighlightColor
      wrd.Selection.Find.Replacement.ClearFormatting
      wrd.Selection.Find.Replacement.HighLight = True
    
    'start replacing list of words in glossary subform
    With [sbfrmProjectGlossary].Form.RecordsetClone
    .MoveFirst
    Do While .EOF = False
    wrd.Selection.Find.Execute FindText:=.TargetLanguageTerm, _
       ReplaceWith:="^& " & strBeforeTag & .TargetLanguageCorrectedTerm & strAfterTag, _
        Format:=True, Replace:=2
       .MoveNext
    Loop
    End With
      
      wrd.ActiveDocument.SaveAs IncrementIfExists(strFilePath & strPrefix & strSaveExtension & strSuffix)
      DoEvents
      wrd.ActiveDocument.Close (True)
      DoEvents
      
      wrd.Quit
' end of Word section
 
Case .ppt
    MsgBox "this is a ppt document!"
    'Call ManipulatePpt(filename)
    
Case Else
End Select
                     
    Set wrd = Nothing
        
      If booSuccess <> False Then
      .Edit
      !ReplacementResult = "strError"
      !ReplacementCompleted = Now()
      .Update
      Else
      .Edit
      !ReplacementResult = "Success"
      !ReplacementCompleted = Now()
      .Update
      End If
            
      .MoveNext
    Loop
  End With
 
 
MsgBox "Replacement Complete."
 
EH:
' Okay, your optimism was premature!
booSuccess = False
strError = "Error " & Err.Number & ": " & Err.Description
Resume Next
End Sub
 
Private Sub wPalette1_Click()
 
Me.wPalette1.BackColor = 65280
Me.HighLightColour.BackColor = Me.wPalette1.BackColor
Me!HighLightColour = "wdBrightGreen:4"
 
End Sub
 
Private Sub wPalette2_Click()
 
Me.wPalette2.BackColor = 16776960
Me.HighLightColour.BackColor = Me.wPalette2.BackColor
Me!HighLightColour = "wdTurquoise:3"
 
End Sub
 
Private Sub wPalette3_Click()
 
Me.wPalette3.BackColor = 65535
Me.HighLightColour.BackColor = Me.wPalette3.BackColor
Me!HighLightColour = "wdYellow:7"
 
End Sub
 
Private Sub wPalette4_Click()
 
Me.wPalette4.BackColor = 12632256
Me.HighLightColour.BackColor = Me.wPalette4.BackColor
Me!HighLightColour = "wdGray25:16"
 
 
End Sub
 
Private Sub wPalette5_Click()
 
Me.wPalette5.BackColor = 8421504
Me.HighLightColour.BackColor = Me.wPalette5.BackColor
Me!HighLightColour = "wdGray50:15"
 
 
End Sub
 
Private Sub wPalette6_Click()
 
Me.wPalette6.BackColor = 16711935
Me.HighLightColour.BackColor = Me.wPalette6.BackColor
Me!HighLightColour = "wdPink:5"
 
 
End Sub
 
Private Sub wPalette7_Click()
 
Me.wPalette7.BackColor = 32768
Me.HighLightColour.BackColor = Me.wPalette7.BackColor
Me!HighLightColour = "wdGreen:11"
 
 
End Sub
 
Private Sub wPalette8_Click()
 
Me.wPalette8.BackColor = 255
Me.HighLightColour.BackColor = Me.wPalette8.BackColor
Me!HighLightColour = "wdRed:6"
 
 
End Sub
 
Private Sub wPalette9_Click()
 
Me.wPalette9.BackColor = 16711680
Me.HighLightColour.BackColor = Me.wPalette9.BackColor
Me!HighLightColour = "wdBlue:2"
 
 
End Sub
Private Sub wPalette10_Click()
 
Me.wPalette10.BackColor = 8388736
Me.HighLightColour.BackColor = Me.wPalette10.BackColor
Me!HighLightColour = "wdViolet:12"
 
 
End Sub
 
Private Sub wPalette11_Click()
 
Me.wPalette11.BackColor = 8421376
Me.HighLightColour.BackColor = Me.wPalette11.BackColor
Me!HighLightColour = "wdTeal:10"
 
 
End Sub
 
Private Sub wPalette12_Click()
 
Me.wPalette12.BackColor = 32896
Me.HighLightColour.BackColor = Me.wPalette12.BackColor
Me!HighLightColour = "wdDarkYellow:14"
 
End Sub

Open in new window

0
 
ShawnAuthor Commented:
Chris,

When I place a toggle breakpoint on the saveas command I'm noticing there seems to be a problem with the line : For Each oPres...

it shows oPres = Nothing

I'm pretty sure this is where it is breaking up.

the other thing I corrected is the sub ReplaceText. I noticed it wasn't public.
was:
Sub ReplaceText(oShp As Object, FindString As String, ReplaceString As String)
is now
Public Sub ReplaceText(oShp As Object, FindString As String, ReplaceString As String)
    Dim oPres As Presentation
    Dim oSld As Slide
    Dim oShp As Shape
 
    Set ppt = CreateObject("PowerPoint.Application")
    ppt.Visible = True
    ppt.Presentations.Open strFilePath & strFileName ', ReadOnly:=msoTrue
                
    'start replacing list of words in glossary subform
    With [sbfrmProjectGlossary].Form.RecordsetClone
    .MoveFirst
    Do While .EOF = False
 
    strSearchText = .TargetLanguageTerm
    If Forms![frmReplacementProject]!ReplaceOptionID = 1 Then
    strReplaceText = .TargetLanguageCorrectedTerm
    Else
    strReplaceText = strSearchText & " " & strBeforeTag & .TargetLanguageCorrectedTerm & strAfterTag
    End If
 
    For Each oPres In ppt.ActivePresentation.Presentations
        For Each oSld In ppt.oPres.Slides
            For Each oShp In oSld.Shapes
                    Call ReplaceText(oShp, strSearchText, strReplaceText)
            Next oShp
        Next oSld
    Next oPres
    
    .MoveNext
    Loop
    End With

Open in new window

0
 
Chris BottomleyCommented:
The public prefix ought not to be required as it is in the same code module ... but does no harm in the context.

The oPres initialisation I enabled was missing originally and I merely reset it to your original post.  For myself I would do it as:

'    For Each oPres In ppt.Presentations
        Set oPres = ppt.ActivePresentation
        For Each oSld In oPres.Slides
            For Each oShp In oSld.Shapes
                    Call ReplaceText(oShp, strSearchText, strReplaceText)

                   
            Next oShp
        Next oSld
'    Next oPres

Since the active presentation will be the most recently opened file, a few lines before.

Chris
0
 
ShawnAuthor Commented:
good news...it's working! thank you for your patience ;-)

a couple things...though feel free to get me to open new questions...

replacing a 4mo .ppt with 142 slides it was a little slow (understandibly I guess). My concern is as the window is left open and there is no progress indicator it's a little vulnerable of accidentally being closed or modified before procedure finishes.

for some reason I can't set ppt.visible to false or rather it doesn't work afterwards
is there anything we can use instead of ActivePresentation to make this work?

other related. Speed isn't a major issue in this case but I do have some glossaries with a few hundred terms. To go through a 142 slide ppt it might be to slow to be worth while. Any suggestions?
0
 
Chris BottomleyCommented:
I didn't touch the visible, though I would add some scepticism on your statement ... I do apologise, it does indeed seem to be the case.  I have tried a few things and all failed to help, a web search wasn't immediately helpful so i'll put it on my back burner out of interest but will be pursuing it here.

Getting to make the window hidden I think will improve your running speed dramatically but   !  Out of interest I tried the excel screenupdating command but that seems to have no effect.

I am however pleased we got you over the initial hurdle, and wish you well in tidying up the replacement sub should it be necessary.

Chris
0
 
ShawnAuthor Commented:
ok. thanks for all your help...and I'll let you know if I do come across something to increase speed/hide the window.
Shawn

0

Featured Post

Prep for the ITIL® Foundation Certification Exam

December’s Course of the Month is now available! Enroll to learn ITIL® Foundation best practices for delivering IT services effectively and efficiently.

  • 14
  • 14
Tackle projects and never again get stuck behind a technical roadblock.
Join Now