Draw Text Übersetzung

[koter]

Hallo Norre,

wenn ein weißer Abschnitt leer gelassen wird sollte es mit folgender, geäderter SUB gehen:

Code:

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
                    t2 = NDers(t)
                    If Len(t2) > 0 Then
                        s.Text.Story.Text = t
                    End If
                End If
            Next
        End If
    Next
    ActiveDocument.EndCommandGroup
    Set wd = Nothing
End Sub

Function NDers(ByVal t As String) As String
    t = Trim(t)
    et = Array(Chr(10), Chr(11), Chr(13), Chr(32))
    For i = 0 To UBound(et)
        t = Replace(t, et(i), "")
    Next i
    NDers = t
End Function

Gruß

koter