Dim TextNo As Integer
Dim QuitNow As Boolean
Sub TBoxer_ExtractFromTextBoxes()

Dim Boite As Shape
Dim ThisDoc As Document, MyDoc As Document
Dim cProp As DocumentProperty, itExists As Boolean
Dim Styl As Style, StylEx As Boolean
Dim MyFileName As String, OldFileName As String
Dim i As Integer
Const MyName As String = "Text Boxer - Extract from textboxes"

On Error GoTo ErrorHandler

    If Documents.Count < 1 Then
        MsgBox "Please open the document with textboxes and run this macro again.", vbOKOnly, MyName
        Exit Sub
    End If
    If ActiveDocument.Path = "" Then
        MsgBox "Please save the document and run this macro again", vbOKOnly, MyName
        Exit Sub
    End If
    If ActiveDocument.ReadOnly = True Then
        MsgBox "This macro can't continue. Make sure the document is not read-only and then " & _
        "run the macro again.", vbOKOnly, MyName
        Exit Sub
    End If

Application.ScreenUpdating = False

With ActiveDocument
    MyFileName = .FullName
    OldFileName = MyFileName
    For i = Len(MyFileName) To 2 Step -1
    If Mid(MyFileName, i, 1) = "." Then MyFileName = Left(MyFileName, i - 1): Exit For
    Next
    .SaveAs MyFileName & ".bak"
    .SaveAs OldFileName
End With

Set ThisDoc = ActiveDocument

With ThisDoc
itExists = False
For Each cProp In .CustomDocumentProperties
    If cProp.Name = "Text Boxer" Then itExists = True
Next cProp
If itExists = True Then
    Application.ScreenUpdating = True
    If MsgBox("It seems you have already extracted text boxes from this document on " & _
    .CustomDocumentProperties("Text Boxer") & ". Continue?", _
    vbYesNo, MyName) = 7 Then Exit Sub
    Application.ScreenUpdating = False
    .CustomDocumentProperties("Text Boxer").Value = Date & ", " & Time
Else
    .CustomDocumentProperties.Add Name:="Text Boxer", LinkToContent:=False, _
    Value:=Date & ", " & Time, Type:=msoPropertyTypeString
End If
End With

Documents.Add
Set MyDoc = ActiveDocument

TextNo = 0
StylEx = False

With MyDoc
    .CustomDocumentProperties.Add Name:="Text Boxer", LinkToContent:=False, _
    Value:=OldFileName, Type:=msoPropertyTypeString
    For Each Styl In .Styles
        If Styl = "tw4winExternal" Then StylEx = True
    Next Styl
    If StylEx = False Then
        .Styles.Add Name:="tw4winExternal", Type:=wdStyleTypeCharacter
        .Styles("tw4winExternal").Font.Color = wdColorGray50
    End If
End With

For Each Boite In ThisDoc.Shapes
    If Boite.Type <> msoGroup Then
    If Boite.Type = msoTextBox Then
    With Boite.TextFrame
        If .TextRange.Text <> "" Then
            TextNo = TextNo + 1
            If .Overflowing Then
                .ContainingRange.Cut
            Else
                .TextRange.Cut
            End If
            .TextRange.Bookmarks.Add ("TBox" & TextNo)
        With Selection
            .InsertAfter "<TBox " & TextNo & ">"
            .Style = "tw4winExternal"
            .Collapse wdCollapseEnd
            .Paste
        End With
        End If
    End With
    End If
    Else
        Call ProcessGroup(Boite)
    End If
Next
    If TextNo <> 0 Then
        With Selection
        .InsertAfter "<TBox End>"
        .Style = "tw4winExternal"
        .HomeKey Unit:=wdStory
        End With
    Else
        MyDoc.Close False
        MsgBox "No text boxes found. Nothing extracted.", vbOKOnly, MyName
        Exit Sub
    End If

ThisDoc.Close wdSaveChanges

MyDoc.Activate
With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Replacement.Style = "tw4winExternal"
    .Execute FindText:="^p<TBox", MatchWildcards:=False, Wrap:=wdFindContinue, Format:=True, _
    ReplaceWith:="<TBox", Replace:=wdReplaceAll
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
End With

MyDoc.SaveAs MyFileName & "_TBoxer.doc"

With Application
    .ScreenUpdating = True
    .ScreenRefresh
End With
MsgBox "Finished succesfully." & vbCrLf & vbCrLf & _
"Translate this file and then run the 'Return to textboxes' macro.", vbOKOnly, MyName
Exit Sub

ErrorHandler:
With Application
    .ScreenUpdating = True
    .ScreenRefresh
End With
MsgBox "An unexpected error occurred. I'm sorry." & vbCrLf & "Close your document without saving changes!" & _
vbCrLf & vbCrLf & "Error number: " & Err.Number & vbCrLf & "Error description: " & Err.Description, vbOKOnly, MyName

End Sub
Function ProcessGroup(ThisGroup As Shape)
Dim GI As Integer
For GI = 1 To ThisGroup.GroupItems.Count
    If ThisGroup.GroupItems(GI).Type = msoGroup Then
        Call ProcessGroup(ThisGroup.GroupItems(GI))
    Else
        If ThisGroup.GroupItems(GI).Type = msoTextBox Then
        With ThisGroup.GroupItems(GI).TextFrame
            If .TextRange.Text <> "" Then
                TextNo = TextNo + 1
                If .Overflowing Then
                    .ContainingRange.Cut
                Else
                    .TextRange.Cut
                End If
                .TextRange.Bookmarks.Add ("TBox" & TextNo)
                With Selection
                    .InsertAfter "<TBox " & TextNo & ">"
                    .Style = "tw4winExternal"
                    .Collapse wdCollapseEnd
                    .Paste
                End With
            End If
        End With
        End If
    End If
Next GI
End Function
Sub TBoxer_ReturnToTextBoxes()

Dim BmkTxt As String, BmkNo As String
Dim ExtrDoc As Document, TransDoc As Document
Dim MyRange As Range
Dim Bkmrk As Bookmark
Dim cProp As DocumentProperty, itExists As Boolean
Dim fs As Object
Dim linkedDoc As String
Const MyName As String = "Text Boxer - Back to text boxes"

QuitNow = False
If Documents.Count < 1 Then
    MsgBox "Please open the document with text extracted from textboxes" & vbCrLf & _
    "and then run this macro again.", vbOKOnly, MyName
    Exit Sub
End If

Set ExtrDoc = ActiveDocument

With ExtrDoc
If .Saved = False Or .Path = "" Then
    If MsgBox("This file isn't saved. Do you want to save it now?" & vbCrLf & _
    "(If you don't save it, this macro will discard it.)", vbYesNo, MyName) = 6 Then .Save
End If

itExists = False
For Each cProp In .CustomDocumentProperties
    If cProp.Name = "Text Boxer" Then itExists = True
Next cProp
If itExists = True Then
    linkedDoc = .CustomDocumentProperties("Text Boxer").Value
Else
    If MsgBox("This doesn't seem to be a document with textboxes extracted by Text Boxer. Continue?", _
    vbYesNo, MyName) = 7 Then Exit Sub
End If
End With

If itExists Then
    Set fs = CreateObject("Scripting.FileSystemObject")
    If fs.FileExists(linkedDoc) Then
        Documents.Open linkedDoc
        With ActiveDocument
            itExists = False
            For Each cProp In .CustomDocumentProperties
                If cProp.Name = "Text Boxer" Then itExists = True
            Next cProp
            If itExists = False Then
                .Close
                Call OpenDaFile
                If QuitNow = True Then Exit Sub
            End If
        End With
    Else
        Call OpenDaFile
        If QuitNow = True Then Exit Sub
    End If
Else
    Call OpenDaFile
    If QuitNow = True Then Exit Sub
End If

Set TransDoc = ActiveDocument

If linkedDoc <> "" Then
    With TransDoc
    If Right(linkedDoc, Len(.Name)) <> .Name Then
        If MsgBox("This file has a different name than the file from" & vbCrLf & _
        "which the textboxes were extracted. Continue?", _
        vbYesNo, MyName) = 7 Then Exit Sub
    End If
    End With
End If

Set MyRange = ExtrDoc.Range(0, 0)

Do
With MyRange
    .MoveEnd wdCharacter, 6
    If .Text <> "<TBox " Then
        .Select
        MsgBox "An error occured in the selected spot.", vbOKOnly, MyName
        Exit Sub
    End If
    .Collapse wdCollapseEnd
    .MoveEndUntil ">", wdForward
    BmkNo = .Text
    If BmkNo = "End" Then Exit Do
    .Move wdCharacter, 2
    
    Do
    .MoveEndUntil "<", wdForward
    If ExtrDoc.Range(.End, .End + 5) = "<TBox" Then Exit Do
    .MoveEnd wdCharacter, 1
    Loop
    
    .Copy
    .Collapse wdCollapseEnd
End With
With TransDoc
    If Not .Bookmarks.Exists("TBox" & BmkNo) Then
        If MsgBox("An error occured: text number " & BmkNo & _
        " cannot find its textbox. Continue?", vbYesNo, MyName) = 7 Then Exit Sub
    Else
        .Bookmarks("TBox" & BmkNo).Range.Paste
    End If
End With
Loop

ExtrDoc.Close False

For Each Bkmrk In TransDoc.Bookmarks
    If Bkmrk.Name Like "TBox*" Then Bkmrk.Delete
Next Bkmrk

With TransDoc
    itExists = False
    For Each cProp In .CustomDocumentProperties
        If cProp.Name = "Text Boxer" Then itExists = True
    Next cProp
    If itExists = True Then .CustomDocumentProperties("Text Boxer").Delete
    .Activate
End With
MsgBox "Finished successfully." & vbCrLf & "Check and save your document.", vbOKOnly, MyName

End Sub
Function OpenDaFile()
Dim OpenDial As Dialog
Dim itExists As Boolean
Dim cProp As DocumentProperty
Const MyName As String = "Text Boxer - Back to text boxes"
    Set OpenDial = Dialogs(wdDialogFileOpen)
    MsgBox "Please open the document with text boxes.", vbOKOnly, MyName
    If OpenDial.Show = 0 Then QuitNow = True
    itExists = False
    With ActiveDocument
        For Each cProp In .CustomDocumentProperties
            If cProp.Name = "Text Boxer" Then itExists = True
        Next cProp
        If itExists = False Then
            If MsgBox("This doesn't seem to be the document from which these textboxes" & _
            " were extracted. Continue?", vbYesNo, MyName) = 7 Then QuitNow = True
        End If
    End With
End Function