Microsoft Office Forums - View Single Post - [Solved] We have many word docs we need to copy text from

gmayor · 08-28-2014, 09:16 PM

If you want to keep the start and end search strings, you don't need any of the oNewRange lines. The reason for the skipping is presumably because you are testing with an unsaved document, so the naming section errors out and when that occurs it moves to the label. If that is not it, comment out the On Error line (while testing with the test macro) and see which line causes the error. It works here when tested in Word 2010 and 2013.

Code:

Function ExtractText(oDoc As Document) As Boolean
Dim oRng As Range
Dim oNewDoc As Document
Dim strNewName As String
Const strStart As String = "The information received does not support the service requested:"
Const strEnd As String = "The above actions are supported by the following:"
    On Error GoTo Err_Handler
    Set oRng = oDoc.Range
    With oRng
        .Start = .Start + InStr(oRng, strStart) - 1 
        .End = .Start + InStr(oRng, strEnd) + 1
        .MoveEndUntil Chr(58)
        .End = .End + 1
        If Len(.Text) > 0 Then
            Set oNewDoc = Documents.Add(Template:=oDoc.FullName, Visible:=True)
            oNewDoc.Range.FormattedText = oRng.FormattedText
            strNewName = oDoc.FullName
            strNewName = Left(strNewName, InStrRev(strNewName, Chr(46)) - 1)
            strNewName = strNewName & "EN"
            strNewName = strNewName & Right(oDoc.name, Len(oDoc.name) - InStrRev(oDoc.name, Chr(46)) + 1)
            oNewDoc.SaveAs strNewName, addtorecentfiles:=False
            oNewDoc.Close 0
        End If
    End With
    ExtractText = True

lbl_Exit:
    Exit Function
Err_Handler:
    ExtractText = False
End Function