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):
Code aus UserForm2 (dot) / Code from UserForm2 (dot):
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):
OptionExplicit
' Name des Worddokumentes
ConststrWordDocAsString="Defects_list.doc"
' Namen der Textmarken im Worddokument
ConststrBookmark1AsString="defect"
' Konstante für den Speichern-Unter Dialog in Word
ConstwdDialogFileSaveAs=84
' Konstante für das Speicherformat
ConstwdFormatDocument97=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
DimblnTMPAsBoolean
'--------------------------------------------------------------------------
' Module : UserForm1
' Author : Case (Ralf Stolzenburg)
' Date : 03.07.2013
' Purpose : Daten von Excel UserForm ListBox nach Word in Textmarke...
'--------------------------------------------------------------------------
PrivateSubCommandButton1_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
DimstrListContentAsString
DimobjBookmarkAsObject
DimobjDocumentAsObject
DimobjDialogAsObject
DimlngCountAsLong
DimobjAppAsObject
DimstrDocAsString
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
OnErrorGoToFin
' ListBox Inhalt in String mit LineFeed
' ODER Leerzeichen am Schluss schreiben
ForlngCount=0ToListBox1.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
NextlngCount
' 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
SetobjApp=OffApp("Word")
'folgende Codezeile für Word nicht sichtbar
'Set objApp = OffApp("Word", False)
' Wenn die Word der Objektvariablen zugewiesen werden konnte dann...
IfNotobjAppIsNothingThen
' Öffne das Worddokument, zugewiesen an die Objektvariable objDocument
SetobjDocument=objApp.Documents.Open(Filename:=strDoc)
' Prüfe, ob die Textmarke vorhanden ist
IfobjDocument.Bookmarks.Exists(strBookmark1)=TrueThen
' Schreibe den Wert von B2 in die Textmarke Name
SetobjBookmark=objDocument.Bookmarks(strBookmark1).Range
' Schreibe den Inhalt der Variablen strListContent in die Textmarke
objBookmark.Text=strListContent
EndIf
' Word Speicherdialog aufrufen
SetobjDialog=objApp.Dialogs(wdDialogFileSaveAs)
WithobjDialog
' 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=-1Then
objDocument.SaveAsFilename:=.Name,_
FileFormat:=wdFormatDocument97
EndIf
' Dokument schliessen OHNE speichern
objDocument.CloseFalse
' Objektvariable leeren
SetobjDocument=Nothing
EndWith
Else
' Ausgabe, wenn die Objektvariable objApp Nothing ist...
MsgBox"Applikation nicht installiert!"
EndIf
Fin:
' UserForm schliessen
UnloadMe
' Wenn noch ein Worddokument offen ist - schliessen ohne speichern
IfNotobjDocumentIsNothingThenobjDocument.CloseFalse
' Wenn die Applikation noch offen ist - schliessen
' Aber nur, wenn sie nicht vorher schon offen war
IfNotobjAppIsNothingThen
IfblnTMP=TrueThen
objApp.Quit
blnTMP=False
EndIf
EndIf
' Objektvariablen leeren
SetobjBookmark=Nothing
SetobjDocument=Nothing
SetobjApp=Nothing
' Wenn die Fehlernummer NICHT 0 ist, dann gib die Fehlernummer
' und die Fehlerbeschreibung aus
IfErr.Number<>0ThenMsgBox"Fehler: "&_
Err.Number&" "&Err.Description
EndSub
'--------------------------------------------------------------------------
' Module : UserForm1
' Procedure : OffApp
' Author : Case (Ralf Stolzenburg)
' Date : 03.07.2013
' Purpose : Start application...
'--------------------------------------------------------------------------
PrivateFunctionOffApp(ByValstrAppAsString,_
OptionalblnVisibleAsBoolean=True)AsObject
DimobjAppAsObject
OnErrorResumeNext
SetobjApp=GetObject(,strApp&".Application")
SelectCaseErr.Number
Case429
Err.Clear
SetobjApp=CreateObject(strApp&".Application")
blnTMP=True
IfblnVisible=TrueThen
OnErrorResumeNext
objApp.Visible=True
Err.Clear
EndIf
EndSelect
OnErrorGoTo0
SetOffApp=objApp
SetobjApp=Nothing
EndFunction
' 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):
OptionExplicit
' Name des Worddokumentes
ConststrWordDocAsString="Defects_list.dot"
' Namen der Textmarken im Worddokument
ConststrBookmark1AsString="defect"
' Konstante für den Speichern-Unter Dialog in Word
ConstwdDialogFileSaveAs=84
' Konstante für das Speicherformat
ConstwdFormatDocumentDefault=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
DimblnTMPAsBoolean
'--------------------------------------------------------------------------
' Module : UserForm1
' Author : Case (Ralf Stolzenburg)
' Date : 03.07.2013
' Purpose : Daten von Excel UserForm ListBox nach Word in Textmarke...
'--------------------------------------------------------------------------
PrivateSubCommandButton1_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
DimstrListContentAsString
DimobjBookmarkAsObject
DimobjDocumentAsObject
DimobjDialogAsObject
DimlngCountAsLong
DimobjAppAsObject
DimstrDocAsString
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
OnErrorGoToFin
' ListBox Inhalt in String mit LineFeed
' ODER Leerzeichen am Schluss schreiben
ForlngCount=0ToListBox1.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
NextlngCount
' 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
SetobjApp=OffApp("Word")
'folgende Codezeile für Word nicht sichtbar
'Set objApp = OffApp("Word", False)
' Wenn die Word der Objektvariablen zugewiesen werden konnte dann...
IfNotobjAppIsNothingThen
' Öffne das Worddokument, zugewiesen an die Objektvariable objDocument
SetobjDocument=objApp.Documents.Add(Template:=strDoc)
' Prüfe, ob die Textmarke vorhanden ist
IfobjDocument.Bookmarks.Exists(strBookmark1)=TrueThen
' Schreibe den Wert von B2 in die Textmarke Name
SetobjBookmark=objDocument.Bookmarks(strBookmark1).Range
' Schreibe den Inhalt der Variablen strListContent in die Textmarke
objBookmark.Text=strListContent
EndIf
' Word Speicherdialog aufrufen
SetobjDialog=objApp.Dialogs(wdDialogFileSaveAs)
WithobjDialog
' 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=-1Then
objDocument.SaveAsFilename:=.Name,_
FileFormat:=wdFormatDocumentDefault
EndIf
' Dokument schliessen OHNE speichern
objDocument.CloseFalse
' Objektvariable leeren
SetobjDocument=Nothing
EndWith
Else
' Ausgabe, wenn die Objektvariable objApp Nothing ist...
MsgBox"Applikation nicht installiert!"
EndIf
Fin:
' UserForm schliessen
UnloadMe
' Wenn noch ein Worddokument offen ist - schliessen ohne speichern
IfNotobjDocumentIsNothingThenobjDocument.CloseFalse
' Wenn die Applikation noch offen ist - schliessen
' Aber nur, wenn sie nicht vorher schon offen war
IfNotobjAppIsNothingThen
IfblnTMP=TrueThen
objApp.Quit
blnTMP=False
EndIf
EndIf
' Objektvariablen leeren
SetobjBookmark=Nothing
SetobjDocument=Nothing
SetobjApp=Nothing
' Wenn die Fehlernummer NICHT 0 ist, dann gib die Fehlernummer
' und die Fehlerbeschreibung aus
IfErr.Number<>0ThenMsgBox"Fehler: "&_
Err.Number&" "&Err.Description
EndSub
'--------------------------------------------------------------------------
' Module : UserForm1
' Procedure : OffApp
' Author : Case (Ralf Stolzenburg)
' Date : 03.07.2013
' Purpose : Start application...
'--------------------------------------------------------------------------
PrivateFunctionOffApp(ByValstrAppAsString,_
OptionalblnVisibleAsBoolean=True)AsObject
DimobjAppAsObject
OnErrorResumeNext
SetobjApp=GetObject(,strApp&".Application")
SelectCaseErr.Number
Case429
Err.Clear
SetobjApp=CreateObject(strApp&".Application")
blnTMP=True
IfblnVisible=TrueThen
OnErrorResumeNext
objApp.Visible=True
Err.Clear
EndIf
EndSelect
OnErrorGoTo0
SetOffApp=objApp
SetobjApp=Nothing
EndFunction
' 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