Draw Text Übersetzung

[koter]

Hallo norre,

vielleicht geht es auch wie im Excel-Beispiel oben, in Word.
Die SUB nachWord im folgenden Makro erstellt ein Word-Dokument, bei dem die Originaltexte in geschützen Abschnitten, liegen die Grau hinterlegt sind.
(Dazu muss ein leeres Word-Dokument geöffnet sein)



Diese können nicht geändert werden. In die darunterligenden weißen Abschnitte trägt man die Übersetzung ein.



Danach führt man die SUB vonWord aus, welche die Originatexte durch die Übersetzung austauscht.

Code:

Sub zuWord()
    Dim p As Page, s As Shape, t As String
    Set wd = GetObject(, "Word.Application")
    wd.Application.Activate
    With wd.Selection.ParagraphFormat
        .SpaceBefore = 0
        .SpaceBeforeAuto = False
        .SpaceAfter = 0
        .SpaceAfterAuto = False
        .LineSpacingRule = 0
        .WidowControl = True
        .KeepWithNext = True
        .KeepTogether = True
    End With

    For Each p In ActiveDocument.Pages
        For Each s In p.Shapes
            If s.Type = cdrTextShape Then
                t = s.Text.Story.Text
                sid = s.StaticID
                With wd.Selection
                    .TypeText t
                    .Sections(1).Range.Bookmarks.Add "SID" & sid
                    .TypeParagraph
                    .InsertBreak Type:=3
                    .InsertBreak Type:=3
                End With
            End If
        Next
    Next
    For Each Abschnitt In wd.ActiveDocument.Sections
        If Abschnitt.index Mod 2 = 1 Then
            Abschnitt.Range.Shading.BackgroundPatternColor = 14737632
            Abschnitt.ProtectedForForms = True
        Else
            Abschnitt.ProtectedForForms = False
        End If
    Next
    wd.ActiveDocument.Protect Password:="norre", NoReset:=False, Type:=2
    Set wd = Nothing
End Sub

Sub vonWord()
    Dim p As Page
    Dim s As Shape
    Set wd = GetObject(, "Word.Application")
    ActiveDocument.BeginCommandGroup "Übersetzung einlesen"
    For Each Abschnitt In wd.ActiveDocument.Sections
        If Abschnitt.ProtectedForForms = True Then
            If Abschnitt.Range.Bookmarks.Count > 0 Then
                sid = Right(Abschnitt.Range.Bookmarks(1), Len(Abschnitt.Range.Bookmarks(1)) - 3)
            End If
        Else
            t = Left(Abschnitt.Range.Text, Len(Abschnitt.Range.Text) - 1)
            For Each p In ActiveDocument.Pages
                Set s = p.FindShape(StaticID:=sid)
                If s Is Nothing Then
                Else
                    s.Text.Story.Text = t
                End If
            Next
        End If
    Next
    ActiveDocument.EndCommandGroup
    Set wd = Nothing
End Sub

Gruß

Koter