Excel-VBA: Word falsch aus Excel gestartet?

16/07/2009 - 11:42 von Mathias | Report spam
Hallo NG

Habe ein VBA-Code geschrieben, der Tabellen mit Textmarken im Word
verknüpfen sollen. Der Code funktioniert
recht gut. Bis auf einen Fall:
Word ist geöffnet und Das Dokument 1 steht im Fenster. Jetzt starte
ich im Excel den VBA-Code. Ein neues
Dokument wird angelegt und unter einem neuen Namen gespeichert.
Die Tabellen mit den Textmarken verknüpft. Wenn ich nun das das
bearbeitete Dokument schliesse will Word
immer Normal.dotm speichern. Kann es anscheinend nicht. Meldung:
Normal.dotm wird von einem anderen User
benützt. Speichern unter neuem Namen? Wo liegt der Fehler in meinem
Code?

[code]
Option Explicit

Sub ExportZuWord()
Dim WordObj As Word.Application
Dim WordDoc As Object
Dim strFile As String
Dim strPath As String
Dim strBlatt As String
Dim strTextMarke As String
Dim byWert As Byte
Dim Neuer_Dateiname
Dim Pos As Integer
Dim i As Integer
Dim z As Integer
'Pfad zur Excel-Datei ermitteln
'Wenn nicht vorhanden Datei zuerst speichern
byWert = 7
strPath = ThisWorkbook.Path
If strPath = "" Then
byWert = MsgBox("Die Datei muss zuerst gespeichert werden." & Chr
(13) & "Spechern JA klicken" & Chr(13) & "Nicht Speichern NEIN
klicken", vbYesNo, "Speichern")
If byWert = 7 Then Exit Sub
ChDir "E:\Dokumente und Einstellungen\Miles\Eigene Dateien
\Dokumente\Schàtzungen"
Neuer_Dateiname = Application.GetSaveAsFilename
(InitialFileName:=Application.Range("Name") & " Berechnung " & Format
(Date, "yyyy-mm-dd") & ".xlsm", fileFilter:="Excel-Arbeitsmappe,
*.xlsm")
If Neuer_Dateiname = False Then Exit Sub
ActiveWorkbook.SaveAs Filename:=Neuer_Dateiname,
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
strPath = ThisWorkbook.Path
Else
ActiveWorkbook.Save
End If

'Prüfen ob Word-Datei schon vorhanden.
'Namen für Word-Datei festlegen
strFile = ThisWorkbook.Name
Pos = InStr(1, strFile, "Berechnung", 0)
strFile = Left(strFile, Pos - 1) & "Expertise " & Mid(strFile, Pos +
11, 10) & ".docx"
byWert = 7
If Dir(strPath & "\" & strFile) = "" Then
'nicht vorhanden
byWert = MsgBox("Die Word-Datei muss zuerst erstellt werden." & Chr
(13) & "Erstellen JA klicken" & Chr(13) & "Nicht Erstellen NEIN
klicken", vbYesNo, "Speichern")
If byWert = 7 Then
Word_Disconnect
Exit Sub
End If
' Word schon gestartet?
If xlOpen Then
' ja
Set WordObj = GetObject(, "Word.Application")
Else
' nein
Set WordObj = CreateObject("Word.Application")
End If
' Word Dokumen auf Grundlage von *.Dotx öffnen und speichern.
Set WordDoc = WordObj.Documents.Add(Template:="E:\Dokumente und
Einstellungen\Miles\Anwendungsdaten\Microsoft\Templates\Schàtzungen
\CAS Schàtzung.dotm", DocumentType:=0)
WordObj.Visible = True
WordObj.Activate
WordDoc.Activate
ChangeFileOpenDirectory strPath
ActiveDocument.SaveAs Filename:=strFile, FileFormat:= _
wdFormatXMLDocument, LockComments:=False, Password:="",
AddToRecentFiles _
:=True, WritePassword:="", ReadOnlyRecommended:=False,
EmbedTrueTypeFonts _
:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False
Else
'Word Dokument vorhanden
Set WordObj = New Word.Application
WordObj.Visible = True
WordObj.Documents.Open strPath & "\" & strFile
WordObj.Activate
End If
For i = 2 To ActiveWorkbook.Worksheets.Count
strBlatt = Sheets(i).Name
strTextMarke = strBlatt
If strBlatt <> "Zusammenstellung" Then
Sheets(strBlatt).Activate
Application.Goto Reference:="Print_Area"
Call Export(WordObj, strTextMarke)
Else
z = 0
Sheets(strBlatt).Activate
For z = 1 To 4
Select Case z
Case 1
Application.Goto Reference:="Print_Area"
Call Export(WordObj, strTextMarke)
Case 2
strTextMarke = "Verkehrswert"
Application.Goto Reference:="Druckbereich2"
Call Export(WordObj, strTextMarke)
Case 3
strTextMarke = "Rendite"
Application.Goto Reference:="Druckbereich3"
Call Export(WordObj, strTextMarke)
Case 4
strTextMarke = "Rendite1"
Application.Goto Reference:="Druckbereich3"
Call Export(WordObj, strTextMarke)
End Select
Next z
End If
Next i
Word_Disconnect
End Sub

Function Export(WordObj As Object, strTextMarke As String)
'On Error GoTo weiter
Selection.Copy
WordObj.Selection.Goto what:=wdGoToBookmark, Name:=strTextMarke
WordObj.Selection.PasteSpecial Link:=True,
DataType:=wdPasteOLEObject, Placement:=wdInLine, DisplayAsIcon:=False
' Formatieren (Code noch nicht erstellt)
Application.CutCopyMode = False
weiter:
Application.Range("A1").Select
End Function

Sub Word_Disconnect()
Set WordObj = Nothing
Set WordDoc = Nothing
Sheets("Grunddaten").Select
Range("A1").Select
End Sub
Public Function xlOpen() As Boolean
Dim blnOpen As Boolean
blnOpen = False
On Error GoTo Ende
Set WordObj = GetObject(, "Word.Application")
blnOpen = True
Ende:
xlOpen = blnOpen
End Function
[Code Ende]

Für Tipps bin ich euch sehr dankbar.
Gruss Mathias
 

Lesen sie die antworten

#1 Anonimo
16/07/2009 - 12:14 | Warnen spam
Hallo Matthias

Wenn eine externe Applikation per VBA gesteuert wird, dann wird zwar die
Referenz auf das Objekt gelöscht mit set objWord=nothing, jedoch bleibt die
Applikation im Hintergrund noch offen, was zum erwàhnten Effekt führen
könnte.

Daher sollte die Applikation zuerst verlassen werden (objWord.Quit), bevor
auf nothing gesetzt wird. Der Vorteil besteht auch dadrin, dass nicht noch
beliebige Zombie-Prozesse im Hintergrund offen bleiben.

Ich hoffe, dass dies das Problem löst.

Gruss,
Alex


Der Excel-Spezialist
www.excelspezialist.ch




"Mathias" schrieb im Newsbeitrag
news:
Hallo NG

Habe ein VBA-Code geschrieben, der Tabellen mit Textmarken im Word
verknüpfen sollen. Der Code funktioniert
recht gut. Bis auf einen Fall:
Word ist geöffnet und Das Dokument 1 steht im Fenster. Jetzt starte
ich im Excel den VBA-Code. Ein neues
Dokument wird angelegt und unter einem neuen Namen gespeichert.
Die Tabellen mit den Textmarken verknüpft. Wenn ich nun das das
bearbeitete Dokument schliesse will Word
immer Normal.dotm speichern. Kann es anscheinend nicht. Meldung:
Normal.dotm wird von einem anderen User
benützt. Speichern unter neuem Namen? Wo liegt der Fehler in meinem
Code?

[code]
Option Explicit

Sub ExportZuWord()
Dim WordObj As Word.Application
Dim WordDoc As Object
Dim strFile As String
Dim strPath As String
Dim strBlatt As String
Dim strTextMarke As String
Dim byWert As Byte
Dim Neuer_Dateiname
Dim Pos As Integer
Dim i As Integer
Dim z As Integer
'Pfad zur Excel-Datei ermitteln
'Wenn nicht vorhanden Datei zuerst speichern
byWert = 7
strPath = ThisWorkbook.Path
If strPath = "" Then
byWert = MsgBox("Die Datei muss zuerst gespeichert werden." & Chr
(13) & "Spechern JA klicken" & Chr(13) & "Nicht Speichern NEIN
klicken", vbYesNo, "Speichern")
If byWert = 7 Then Exit Sub
ChDir "E:\Dokumente und Einstellungen\Miles\Eigene Dateien
\Dokumente\Schàtzungen"
Neuer_Dateiname = Application.GetSaveAsFilename
(InitialFileName:=Application.Range("Name") & " Berechnung " & Format
(Date, "yyyy-mm-dd") & ".xlsm", fileFilter:="Excel-Arbeitsmappe,
*.xlsm")
If Neuer_Dateiname = False Then Exit Sub
ActiveWorkbook.SaveAs Filename:=Neuer_Dateiname,
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
strPath = ThisWorkbook.Path
Else
ActiveWorkbook.Save
End If

'Prüfen ob Word-Datei schon vorhanden.
'Namen für Word-Datei festlegen
strFile = ThisWorkbook.Name
Pos = InStr(1, strFile, "Berechnung", 0)
strFile = Left(strFile, Pos - 1) & "Expertise " & Mid(strFile, Pos +
11, 10) & ".docx"
byWert = 7
If Dir(strPath & "\" & strFile) = "" Then
'nicht vorhanden
byWert = MsgBox("Die Word-Datei muss zuerst erstellt werden." & Chr
(13) & "Erstellen JA klicken" & Chr(13) & "Nicht Erstellen NEIN
klicken", vbYesNo, "Speichern")
If byWert = 7 Then
Word_Disconnect
Exit Sub
End If
' Word schon gestartet?
If xlOpen Then
' ja
Set WordObj = GetObject(, "Word.Application")
Else
' nein
Set WordObj = CreateObject("Word.Application")
End If
' Word Dokumen auf Grundlage von *.Dotx öffnen und speichern.
Set WordDoc = WordObj.Documents.Add(Template:="E:\Dokumente und
Einstellungen\Miles\Anwendungsdaten\Microsoft\Templates\Schàtzungen
\CAS Schàtzung.dotm", DocumentType:=0)
WordObj.Visible = True
WordObj.Activate
WordDoc.Activate
ChangeFileOpenDirectory strPath
ActiveDocument.SaveAs Filename:=strFile, FileFormat:= _
wdFormatXMLDocument, LockComments:=False, Password:="",
AddToRecentFiles _
:=True, WritePassword:="", ReadOnlyRecommended:=False,
EmbedTrueTypeFonts _
:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False
Else
'Word Dokument vorhanden
Set WordObj = New Word.Application
WordObj.Visible = True
WordObj.Documents.Open strPath & "\" & strFile
WordObj.Activate
End If
For i = 2 To ActiveWorkbook.Worksheets.Count
strBlatt = Sheets(i).Name
strTextMarke = strBlatt
If strBlatt <> "Zusammenstellung" Then
Sheets(strBlatt).Activate
Application.Goto Reference:="Print_Area"
Call Export(WordObj, strTextMarke)
Else
z = 0
Sheets(strBlatt).Activate
For z = 1 To 4
Select Case z
Case 1
Application.Goto Reference:="Print_Area"
Call Export(WordObj, strTextMarke)
Case 2
strTextMarke = "Verkehrswert"
Application.Goto Reference:="Druckbereich2"
Call Export(WordObj, strTextMarke)
Case 3
strTextMarke = "Rendite"
Application.Goto Reference:="Druckbereich3"
Call Export(WordObj, strTextMarke)
Case 4
strTextMarke = "Rendite1"
Application.Goto Reference:="Druckbereich3"
Call Export(WordObj, strTextMarke)
End Select
Next z
End If
Next i
Word_Disconnect
End Sub

Function Export(WordObj As Object, strTextMarke As String)
'On Error GoTo weiter
Selection.Copy
WordObj.Selection.Goto what:=wdGoToBookmark, Name:=strTextMarke
WordObj.Selection.PasteSpecial Link:=True,
DataType:=wdPasteOLEObject, Placement:=wdInLine, DisplayAsIcon:=False
' Formatieren (Code noch nicht erstellt)
Application.CutCopyMode = False
weiter:
Application.Range("A1").Select
End Function

Sub Word_Disconnect()
Set WordObj = Nothing
Set WordDoc = Nothing
Sheets("Grunddaten").Select
Range("A1").Select
End Sub
Public Function xlOpen() As Boolean
Dim blnOpen As Boolean
blnOpen = False
On Error GoTo Ende
Set WordObj = GetObject(, "Word.Application")
blnOpen = True
Ende:
xlOpen = blnOpen
End Function
[Code Ende]

Für Tipps bin ich euch sehr dankbar.
Gruss Mathias

Ähnliche fragen