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

gmayor · 08-28-2014, 07:38 AM

Having re-read the question, I think there is enough information to suggest a function. Open a document with the required text and test with the following to see if it gives you the results you want:

Code:

Sub Test()
ExtractText ActiveDocument
End Sub

If it does then run it as a custom process from the aforementioned add-in
Try it on a small group of three or four files first. The function puts the files in the same folder as the documents, but you can change the path if you wish.

Code:

Function ExtractText(oDoc As Document) As Boolean
Dim oRng As Range
Dim oNewRange 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
        If Len(.Text) > 0 Then
            Set oNewDoc = Documents.Add(Template:=oDoc.FullName, Visible:=False)
            oNewDoc.Range.FormattedText = oRng.FormattedText
            Set oNewRange = oNewDoc.Range
            oNewRange.Collapse wdCollapseStart
            oNewRange.MoveEndUntil ":"
            oNewRange.End = oNewRange.End + 2
            oNewRange.Delete
            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