Excel - UserForm - ListBox - Inhalt nach Word - Textmarke...

Frage: Der komplette Inhalt einer ListBox (UserForm) soll nach Word gebracht werden. Eine Textmarke ist vorhanden. In der Beispieldatei sind zwei Möglichkeiten:
1. Ein vorhandenes Worddokument - Liste in einer Zeile mit Komma getrennt.
2. Eine Wordvorlage - Liste jeder Eintrag in eine Zeile.
Der Speicherdialog von Word wird am Schluss aufgerufen. Wie geht das?

The complete contents of a ListBox (UserForm) to be brought to Word. A bookmark is available. In the sample file are two possibilities:
1. An existing Word document - list in one line separated by commas.
2. A Word template - list each entry in a row.
The Save As dialog of Word is called at the end. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
Excel - UserForm - ListBox - Inhalt nach Word - Textmarke...[ZIP 50 KB]

Änderung um 19:45 - Beispiele mit Aufzählungszeichen. Anpassung ist nur in der Beispieldatei, nicht im Code unten!
Change at 19:45 - Examples with bullets. Adaptation is only in the sample file, not in the code below!

Hier noch eine Beispieldatei / Here's a sample file:
Excel - UserForm - ListBox - Inhalt nach Word - Textmarke...[ZIP 50 KB]

Code aus UserForm1 (doc) / Code from UserForm1 (doc):

Option Explicit
' Name des Worddokumentes
Const strWordDoc As String = "Defects_list.doc"
' Namen der Textmarken im Worddokument
Const strBookmark1 As String = "defect"
' Konstante für den Speichern-Unter Dialog in Word
Const wdDialogFileSaveAs = 84
' Konstante für das Speicherformat
Const wdFormatDocument97 = 0
' Wenn Word nicht offen ist wird diese Variable auf True
' gesetzt und Word am Ende wieder geschlossen
' War Word schon offen, beleibt es das auch
Dim blnTMP As Boolean
'--------------------------------------------------------------------------
' Module    : UserForm1
' Author    : Case (Ralf Stolzenburg)
' Date      : 03.07.2013
' Purpose   : Daten von Excel UserForm ListBox nach Word in Textmarke...
'--------------------------------------------------------------------------
Private Sub CommandButton1_Click()
    ' Variablendeklaration
    ' Da wir mit Late Binding arbeiten, also ohne Verweise auf die
    ' Wordbibliothek dimensionieren wir die Wordbezogenen Variablen
    ' als Objekt, die dann mit Set dem entsprechenden
    ' Objekt zugewiesen werden
    Dim strListContent As String
    Dim objBookmark As Object
    Dim objDocument As Object
    Dim objDialog As Object
    Dim lngCount As Long
    Dim objApp As Object
    Dim strDoc As String
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' ListBox Inhalt in String mit LineFeed
    ' ODER Leerzeichen am Schluss schreiben
    For lngCount = 0 To ListBox1.ListCount - 1
        ' Mit Leerzeichen - dann kommt das Ergebnis in eine Zeile
        strListContent = strListContent & ListBox1.List(lngCount) & ", "
        ' Mit VbLf - dann steht jeder ListBoxeintag in einer neuen Zeile
        'strListContent = strListContent & ListBox1.List(lngCount) & vbLf
    Next lngCount
    ' Letztes Zeichen entfernen WENN MIT VbLf GEARBEITET WIRD
    'strListContent = Left(strListContent, Len(strListContent) - 1)
    ' Letzte zwei Zeichen entfernen - WENN MIT ", " GEARBEITET WIRD
    strListContent = Left(strListContent, Len(strListContent) - 2)
    ' Das Worddokument mit Pfad und Name - also bei Bedarf anpassen!!!
    ' Liegt im gleichen Ordner wie diese Exceldatei
    strDoc = ThisWorkbook.Path & _
        Application.PathSeparator & strWordDoc
    ' 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)
        ' Prüfe, ob die Textmarke vorhanden ist
        If objDocument.Bookmarks.Exists(strBookmark1) = True Then
            ' Schreibe den Wert von B2 in die Textmarke Name
            Set objBookmark = objDocument.Bookmarks(strBookmark1).Range
            ' Schreibe den Inhalt der Variablen strListContent in die Textmarke
            objBookmark.Text = strListContent
        End If
        ' Word Speicherdialog aufrufen
        Set objDialog = objApp.Dialogs(wdDialogFileSaveAs)
        With objDialog
            ' Pfad und Dateiname vorgeben
            .Name = ThisWorkbook.Path & Application.PathSeparator & _
                "Test_" & Format(Now, "DD_MM_YYYY_hh_mm_ss")
            ' Wenn auf Speichern geklickt wurde...
            If .Display = -1 Then
                objDocument.SaveAs Filename:=.Name, _
                    FileFormat:=wdFormatDocument97
            End If
            ' Dokument schliessen OHNE speichern
            objDocument.Close False
            ' Objektvariable leeren
            Set objDocument = Nothing
        End With
    Else
        ' Ausgabe, wenn die Objektvariable objApp Nothing ist...
        MsgBox "Applikation nicht installiert!"
    End If
Fin:
    ' UserForm schliessen
    Unload Me
    ' Wenn noch ein Worddokument offen ist - schliessen ohne speichern
    If Not objDocument Is Nothing Then objDocument.Close False
    ' Wenn die Applikation noch offen ist - schliessen
    ' Aber nur, wenn sie nicht vorher schon offen war
    If Not objApp Is Nothing Then
        If blnTMP = True Then
            objApp.Quit
            blnTMP = False
        End If
    End If
    ' Objektvariablen leeren
    Set objBookmark = Nothing
    Set objDocument = Nothing
    Set objApp = Nothing
    ' 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
'--------------------------------------------------------------------------
' Module    : UserForm1
' Procedure : OffApp
' Author    : Case (Ralf Stolzenburg)
' Date      : 03.07.2013
' Purpose   : Start application...
'--------------------------------------------------------------------------
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

' Konstanten für das Speicherformat
' Aus dem Objektkatalog in Word VBA-Editor F2
' Suchbegriff: wdFormatDocument

' Const wdFormatDocument = 0
' Const wdFormatDocument97 = 0
' Const wdFormatDocumentDefault = 16
' Const wdFormatDOSText = 4
' Const wdFormatDOSTextLineBreaks = 5
' Const wdFormatEncodedText = 7
' Const wdFormatFilteredHTML = 10
' Const wdFormatFlatXML = 19
' Const wdFormatFlatXMLMacroEnabled = 20
' Const wdFormatFlatXMLTemplate = 21
' Const wdFormatFlatXMLTemplateMacroEnabled = 22
' Const wdFormatHTML = 8
' Const wdFormatOpenDocumentText = 23
' Const wdFormatPDF = 17
' Const wdFormatRTF = 6
' Const wdFormatTemplate = 1
' Const wdFormatTemplate97 = 1
' Const wdFormatText = 2
' Const wdFormatTextLineBreaks = 3
' Const wdFormatUnicodeText = 7
' Const wdFormatWebArchive = 9
' Const wdFormatXML = 11
' Const wdFormatXMLDocument = 12
' Const wdFormatXMLDocumentMacroEnabled = 13
' Const wdFormatXMLTemplate = 14
' Const wdFormatXMLTemplateMacroEnabled = 15
' Const wdFormatXPS = 18

Code aus UserForm2 (dot) / Code from UserForm2 (dot):

Option Explicit
' Name des Worddokumentes
Const strWordDoc As String = "Defects_list.dot"
' Namen der Textmarken im Worddokument
Const strBookmark1 As String = "defect"
' Konstante für den Speichern-Unter Dialog in Word
Const wdDialogFileSaveAs = 84
' Konstante für das Speicherformat
Const wdFormatDocumentDefault = 16
' Wenn Word nicht offen ist wird diese Variable auf True
' gesetzt und Word am Ende wieder geschlossen
' War Word schon offen, beleibt es das auch
Dim blnTMP As Boolean
'--------------------------------------------------------------------------
' Module    : UserForm1
' Author    : Case (Ralf Stolzenburg)
' Date      : 03.07.2013
' Purpose   : Daten von Excel UserForm ListBox nach Word in Textmarke...
'--------------------------------------------------------------------------
Private Sub CommandButton1_Click()
    ' Variablendeklaration
    ' Da wir mit Late Binding arbeiten, also ohne Verweise auf die
    ' Wordbibliothek dimensionieren wir die Wordbezogenen Variablen
    ' als Objekt, die dann mit Set dem entsprechenden
    ' Objekt zugewiesen werden
    Dim strListContent As String
    Dim objBookmark As Object
    Dim objDocument As Object
    Dim objDialog As Object
    Dim lngCount As Long
    Dim objApp As Object
    Dim strDoc As String
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' ListBox Inhalt in String mit LineFeed
    ' ODER Leerzeichen am Schluss schreiben
    For lngCount = 0 To ListBox1.ListCount - 1
        ' Mit Leerzeichen - dann kommt das Ergebnis in eine Zeile
        'strListContent = strListContent & ListBox1.List(lngCount) & ", "
        ' Mit VbLf - dann steht jeder ListBoxeintag in einer neuen Zeile
        strListContent = strListContent & ListBox1.List(lngCount) & vbLf
    Next lngCount
    ' Letztes Zeichen entfernen WENN MIT VbLf GEARBEITET WIRD
    strListContent = Left(strListContent, Len(strListContent) - 1)
    ' Letzte zwei Zeichen entfernen - WENN MIT ", " GEARBEITET WIRD
    'strListContent = Left(strListContent, Len(strListContent) - 2)
    ' Die Wordvorlage mit Pfad und Name - also bei Bedarf anpassen!!!
    ' Liegt im gleichen Ordner wie diese Exceldatei
    strDoc = ThisWorkbook.Path & _
        Application.PathSeparator & strWordDoc
    ' 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.Add(Template:=strDoc)
        ' Prüfe, ob die Textmarke vorhanden ist
        If objDocument.Bookmarks.Exists(strBookmark1) = True Then
            ' Schreibe den Wert von B2 in die Textmarke Name
            Set objBookmark = objDocument.Bookmarks(strBookmark1).Range
            ' Schreibe den Inhalt der Variablen strListContent in die Textmarke
            objBookmark.Text = strListContent
        End If
        ' Word Speicherdialog aufrufen
        Set objDialog = objApp.Dialogs(wdDialogFileSaveAs)
        With objDialog
            ' Pfad und Dateiname vorgeben
            .Name = ThisWorkbook.Path & Application.PathSeparator & _
                "Test_" & Format(Now, "DD_MM_YYYY_hh_mm_ss")
            ' Wenn auf Speichern geklickt wurde...
            If .Display = -1 Then
                objDocument.SaveAs Filename:=.Name, _
                    FileFormat:=wdFormatDocumentDefault
            End If
            ' Dokument schliessen OHNE speichern
            objDocument.Close False
            ' Objektvariable leeren
            Set objDocument = Nothing
        End With
    Else
        ' Ausgabe, wenn die Objektvariable objApp Nothing ist...
        MsgBox "Applikation nicht installiert!"
    End If
Fin:
    ' UserForm schliessen
    Unload Me
    ' Wenn noch ein Worddokument offen ist - schliessen ohne speichern
    If Not objDocument Is Nothing Then objDocument.Close False
    ' Wenn die Applikation noch offen ist - schliessen
    ' Aber nur, wenn sie nicht vorher schon offen war
    If Not objApp Is Nothing Then
        If blnTMP = True Then
            objApp.Quit
            blnTMP = False
        End If
    End If
    ' Objektvariablen leeren
    Set objBookmark = Nothing
    Set objDocument = Nothing
    Set objApp = Nothing
    ' 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
'--------------------------------------------------------------------------
' Module    : UserForm1
' Procedure : OffApp
' Author    : Case (Ralf Stolzenburg)
' Date      : 03.07.2013
' Purpose   : Start application...
'--------------------------------------------------------------------------
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

' Konstanten für das Speicherformat
' Aus dem Objektkatalog in Word VBA-Editor F2
' Suchbegriff: wdFormatDocument

' Const wdFormatDocument = 0
' Const wdFormatDocument97 = 0
' Const wdFormatDocumentDefault = 16
' Const wdFormatDOSText = 4
' Const wdFormatDOSTextLineBreaks = 5
' Const wdFormatEncodedText = 7
' Const wdFormatFilteredHTML = 10
' Const wdFormatFlatXML = 19
' Const wdFormatFlatXMLMacroEnabled = 20
' Const wdFormatFlatXMLTemplate = 21
' Const wdFormatFlatXMLTemplateMacroEnabled = 22
' Const wdFormatHTML = 8
' Const wdFormatOpenDocumentText = 23
' Const wdFormatPDF = 17
' Const wdFormatRTF = 6
' Const wdFormatTemplate = 1
' Const wdFormatTemplate97 = 1
' Const wdFormatText = 2
' Const wdFormatTextLineBreaks = 3
' Const wdFormatUnicodeText = 7
' Const wdFormatWebArchive = 9
' Const wdFormatXML = 11
' Const wdFormatXMLDocument = 12
' Const wdFormatXMLDocumentMacroEnabled = 13
' Const wdFormatXMLTemplate = 14
' Const wdFormatXMLTemplateMacroEnabled = 15
' Const wdFormatXPS = 18

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

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