Beiträge

26.10.2012

Excel -> Word in Textmarken (Bookmarks)...

Frage: In meiner Exceltabelle habe ich verschiedene Zellen, deren Inhalt in eine bestehende Worddatei mit vorhandenen Textmarken (Bookmarks) eingefügt werden soll. Kann auch ein Bereich als Bild gespeichert werden? Oder auch einfach rüberkopiert werden? Dann noch ein Speicherndialog?

In der gezippten Beispieldatei ist ein Exceldokument und zwei Worddokumente. Die Worddokumente sind identisch - eines nur als Sicherung.

Hier noch eine Beispieldatei: Daten von Excel nach Word in Textmarken (Bookmarks)...

Option Explicit
' Namen der Textmarken im Worddokument 
Const strBookmark1 As String = "Name"
Const strBookmark2 As String = "Strasse"
Const strBookmark3 As String = "PLZ"
Const strBookmark4 As String = "Ort"
Const strBookmark5 As String = "Betreff"
Const strBookmark6 As String = "Wertetabelle"
Const strBookmark7 As String = "Wertetabelle1"
' Konstante für den Speichern-Unter Dialog in Word 
Const wdDialogFileSaveAs = 84
' Wenn Word nicht offen ist wird diese Variable auf True 
' gesetzt und Word am Ende wieder geschlossen 
' War Word schon offen, belibt es das auch 
Dim blnTMP As Boolean
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 26.10.2012 
' Purpose   : Daten von Excel nach Word in Textmarken (Bookmarks)... 
'-------------------------------------------------------------------------- 
Public Sub Main()
    ' Variablendeklaration 
    ' Da wir mit Late Binding arbeiten, also ohen Verweise auf die 
    ' Wordbibliothek dimensionieren wir die Wordbezogenen Variablen 
    ' als Objekt, die dann mit Set dem entsprechenden 
    ' Objekt zugewiesen werden 
    Dim objWordRange As Object
    Dim objDocument As Object
    Dim objDialog As Object
    Dim objApp As Object
    Dim strDoc As String
    ' Bei einem Fehler gehe zu diesrr Sprungmarke 
    On Error GoTo Fin
    ' Das Worddokument mit Pfad und Name 
    strDoc = ThisWorkbook.Path & _
        Application.PathSeparator & "Lieferschein.doc"
    ' Die Wordapplikation wird mit der Funktion "OffApp" gesucht 
    ' ODER bei Bedarf gestartet 
    Set objApp = OffApp("Word")
    'folgende Codezeile für Word nicht sichtbar 
    'Set objApp = OffApp("Word", False) 
    ' Wenn die Word der Objektvariablen zugewiesen werden konnte dann... 
    If Not objApp Is Nothing Then
    ' Öffne das Worddokument, zugewiesen an die Objektvariable objDocument 
    Set objDocument = objApp.Documents.Open(Filename:=strDoc)
    ' With für Schreibfaule :-) Alle Bezüge auf Tabelle1 müssen 
    ' mit einem Punkt beginnen 
    With ThisWorkbook.Worksheets("Tabelle1")
        ' Prüfe, ob die Textmarke vorhanden ist 
        If objDocument.Bookmarks.Exists(strBookmark1) = True Then
            ' Schreibe den Wert von B2 in die Textmarke Name 
            objDocument.Bookmarks(strBookmark1).Range = .Range("B2").Text
        End If
        If objDocument.Bookmarks.Exists(strBookmark2) = True Then
            objDocument.Bookmarks(strBookmark2).Range = .Range("C2").Text
        End If
        If objDocument.Bookmarks.Exists(strBookmark3) = True Then
            objDocument.Bookmarks(strBookmark3).Range = .Range("D2").Text
        End If
        If objDocument.Bookmarks.Exists(strBookmark4) = True Then
            objDocument.Bookmarks(strBookmark4).Range = .Range("E2").Text
        End If
        If objDocument.Bookmarks.Exists(strBookmark5) = True Then
            objDocument.Bookmarks(strBookmark5).Range = .Range("F2").Text
        End If
        ' Kopiere einen Bereich als Bild an die Textmarke Wertetabelle 
        ' Objektvariable objWordRange leeren 
        If objDocument.Bookmarks.Exists(strBookmark6) = True Then
            .Range("H1:J4").CopyPicture 1, 2
            Set objWordRange = objDocument.Bookmarks(strBookmark6).Range
            objWordRange.Paste
            Set objWordRange = Nothing
        End If
        ' Kopiere einen Bereich an die Textmarke Wertetabelle1 
        If objDocument.Bookmarks.Exists(strBookmark7) = True Then
            .Range("H1:J4").Copy
            Set objWordRange = objDocument.Bookmarks(strBookmark7).Range
            objWordRange.Paste
        End If
        ' Ameisenrennen um den kopierten Bereich beenden 
        ' und Zwischenspeicher leeren 
        Application.CutCopyMode = True
        ' Objektvariable objWordRange leeren 
        Set objWordRange = Nothing
        ' Word Speicherdialog aufrufen 
        Set objDialog = objApp.Dialogs(wdDialogFileSaveAs)
        With objDialog
            ' Pfad vorgeben 
            .Name = "C:\Temp\"
            ' Wenn auf Speichern geklickt wurde... 
            If .Display = -1 Then
                objDocument.SaveAs Filename:=.Name
            End If
            ' Dokument schliessen 
            objDocument.Close
        End With
    End With
    Else
        ' Ausgabe, wenn die Objektvariable objApp Nothing ist... 
        MsgBox "Applikation nicht installiert!"
    End If
Fin:
    If Not objApp Is Nothing Then
        ' Wor war nicht offen, also... 
        If blnTMP = True Then
            ' ... Word schliessen 
            objApp.Quit
            blnTMP = False
        End If
    End If
    ' Objektvariablen leeren 
    Set objWordRange = Nothing
    Set objDocument = Nothing
    Set objApp = Nothing
    Application.CutCopyMode = True
    ' Wenn die Fehlernummer NICHT 0 ist, dann gib die Fehlernummer 
    ' und die Fehlerbeschreibung aus 
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = True) As Object
    Dim objApp As Object
    On Error Resume Next
    Set objApp = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objApp = CreateObject(strApp & ".Application")
            blnTMP = True
            If blnVisible = True Then
                On Error Resume Next
                objApp.Visible = True
                Err.Clear
            End If
    End Select
    On Error GoTo 0
    Set OffApp = objApp
    Set objApp = Nothing
End Function