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

skyslayer · 08-29-2014, 12:10 PM

Update
I have discovered that the original ExtractText function somehow inserts the last table before the start
search string into the new document because I am a beginer to all this the only way for me to remove the added table or tables are to remove them
using the Sub Removetables.

My problem now is in order for my new Sub to run on the new document I need to set oNewDoc = Documents.Add(Template:=oDoc.FullName, Visible:=True)
but when it is set to true the Batch Process Documents Add-in does not work so I must do them one at a time, If I set it to False the Batch Process Documents Add-in
works with error corrupted tables as in last post but my Sub runs on the active document (the original).
I am assuming this is somthing simple but at this stage of my grasp of VBA I am at a loss.

Thank You
Jim

Code:

 
 Sub TestENV2()
ExtractTextENV2 ActiveDocument
End Sub
 Function ExtractTextENV2(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) '<---If set to True Sub Removetables works fine
            'but Batch Process Documents Add-in does not work if set to False Batch Process Documents works but Sub Removetables
            'does not work
            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)
            Call Removetables '<---new call to Sub to remove all tables in new document (by Jim)
            oNewDoc.SaveAs strNewName, addtorecentfiles:=False
            oNewDoc.Close 0
        End If
    End With
    ExtractTextENV2 = True
 lbl_Exit:
    Exit Function
Err_Handler:
    ExtractTextENV2 = False
End Function
 
 'This Sub used to remove all tables in new document
Sub Removetables()
Dim oTable As Table
Dim oNewDoc As Document
Set oNewDoc = ActiveDocument
On Error Resume Next
For Each oTable In ActiveDocument.Tables
oTable.Delete
Next oTable
End Sub