ich habe folgendes Problem:
Ich arbeite auf meinem Rechner mit Office 2013 und auf einem anderen mit Office 2016.
Mit den nachstehenden Makros öffne ich eine Wordvorlage nach zuvor ausgewählten Datenschritten, das Worddokument öffnet sich.
Beim Schliessen des Worddokument, wird dieses schreibgeschützt ohne Makros abgespeichert.
Über eine Listbox kann das Worddokument ausgewählt und geöffnet werden. Es werden dann die gespeicherten Werte angezeigt.
Dieses Dokument ist bewusst schreibgeschützt. Es kann dann über einen Button im Formular geschlossen werden.
Dieses funktioniert bei mir auf dem Rechner einwandfrei. Wenn ich das gleiche auf dem anderen Rechner ausführe, wird ein nicht mit
Werten gespeichertes Dokument geöffnet - es sucht die Makros im Worddokument. Da dieses Dokument nicht ordnungsgemäss gespeichert ist,
wird das Makro beim Öffnen von Worddokument in der Zeile "wrdDoc.SelectContentControlsByTag("Pflichtfeld").Item(1).Range = PflichtName" aus dem
Code von Button "Private Sub CommandButton18_Click" angehalten mit Laufzeitfehler '6124' Sie sind nicht berechtigt, diese Auswahl zu bearbeiten, weil
es geschützt ist.
Option Explicit
Private WrdApp As Object, wrdDoc As Object
Private strDName As String, strPfad As String, strName As String
'gewählte Worddatei öffnen
Private Sub CommandButton14_Click()
Dim pfad As String
Dim PflichtName As String 'neu für Pflichtfeld
'Anfang - Pfad für Wordvorlage und strName für Dateiname der WORD-Vorlage aus Listbox2
pfad = ThisWorkbook.Path & "\" 'von Gerhard 2021_04_23
'Debug.Print Pfad
strDName = pfad & ListBox2.Value
'Debug.Print strDName
'Ende - Pfad für Wordvorlage und strName für Dateiname der WORD-Vorlage aus Listbox2
PflichtName = Worksheets("Worddaten").Range("A2").Value
'Debug.Print PflichtName
Set WrdApp = CreateObject("Word.Application")
' WrdApp.Visible = True 'True = sichtbar
WrdApp.Visible = False 'False = nicht sichtbar 'dadurch wird erst das aktualisierte Dokument1 angezeigt
WrdApp.WindowState = 1 '1 = maximal
WrdApp.Application.DisplayAlerts = 0
Set wrdDoc = WrdApp.Documents.Add(strDName)
WrdApp.Run "pfadAktualisieren"
' wrdDoc.SelectContentControlsByTag("Pflichtfeld").Item(1).Range = "Test"
' wrdDoc.SelectContentControlsByTag("Pflichtfeld").Item(1).Range = "Carl-von-Linde-Gymnasium"
wrdDoc.SelectContentControlsByTag("Pflichtfeld").Item(1).Range = PflichtName
WrdApp.Visible = True 'True = sichtbar 'dadurch wird erst das aktualisierte Dokument1 angezeigt
With Label45
.BackColor = &H8000000F
.Caption = "Dokument1 aus Vorlage" & vbLf & strDName & vbLf & "wurde geöffnet!"
End With
CommandButton14.Enabled = False
CommandButton15.Enabled = True
CommandButton2.Enabled = False
wrdDoc.Activate 'dadurch wird geöffnetes Dokument sofort sichtbar
End Sub
'gewählte Worddatei schliessen
Private Sub CommandButton15_Click()
Dim ZielPfad As String
Dim DatName As String
Dim wdFormatDocument
Dim strDokNeu As String
Dim strDokNeu2 As String
Dim Eingabe As String
Dim PflichtName As String 'neu für Pflichtfeld
ZielPfad = ThisWorkbook.Path & "\" 'von Gerhard 2021_04_23
PflichtName = Worksheets("Worddaten").Range("A2").Value
'Debug.Print PflichtName
'Anfang - Dokumentennahme entsprechend Schuljahr bzw. Kalenderjahr
If Worksheets("Hilfstabelle").Range("C3") > "" Then 'Kalenderjahr
DatName = Left(ListBox2, Len(ListBox2) - 5) & "_" & Right(TextBox1, 4) & "_" & Date
'Debug.Print DatName
'Debug.Print ZielPfad & DatName
wrdDoc.Activate 'dadurch wird das zu speichernde Dokument1 ausgewählt
strDokNeu = ZielPfad & DatName & ".docx"
'Debug.Print strDokNeu
ElseIf Worksheets("Hilfstabelle").Range("C2") > "" Then 'Schuljahr
DatName = Left(ListBox2, Len(ListBox2) - 5) & "_" & Right(TextBox1, 4) & "_" & Right(TextBox2, 4) & "_" & Date
'Debug.Print DatName
'Debug.Print ZielPfad & DatName
wrdDoc.Activate 'dadurch wird das zu speichernde Dokument1 ausgewählt
strDokNeu = ZielPfad & DatName & ".docx"
'Debug.Print strDokNeu
End If
'Ende - Dokumentennahme entsprechend Schuljahr bzw. Kalenderjahr
With wrdDoc
' .SelectContentControlsByTag("Pflichtfeld").Item(1).Range = "Test1"
.SelectContentControlsByTag("Pflichtfeld").Item(1).Range = PflichtName
If Dir(strDokNeu) = "" Then 'wenn kein Dokument vorhanden ist
'schreibgeschützt 'damit wird Dokument1 unter vorgegebenem Namen schreibgeschützt gespeichert
WrdApp.ActiveDocument.SaveAs Filename:=ZielPfad & DatName & ".docx", FileFormat:= _
wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
True, WritePassword:="", ReadOnlyRecommended:=True, EmbedTrueTypeFonts:= _
False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False
'MsgBox "Das Dokument wurde im Ordner: " & strDokNeu & " schreibgeschützt - gespeichert!"
Label39.Font.Size = 12
Label39.Caption = "Das Dokument wurde im Ordner: " & strDokNeu & " schreibgeschützt - gespeichert!"
'Anfang WordDoc schliesen und ggf. Word beenden
If Not WrdApp Is Nothing Then
wrdDoc.Close 0
If WrdApp.Documents.Count = 0 Then WrdApp.Quit
Set wrdDoc = Nothing
Set WrdApp = Nothing
End If
With Label39
.BackColor = &HC0FFC0
.Caption = "Die Datei " & """" & strDName & """" & " wurde geschlossen!"
End With
CommandButton14.Enabled = False
CommandButton15.Enabled = False
'Ende WordDoc schliesen und ggf. Word beenden
'Anfang - zu erledigende Aufgaben
'da Dokument1 unter neuem Namen in Ordner "Dokumente" gespeichert wird, muss u.a. Makro ausgeführt werden
Call Word_Vorlagen_Laufend_auflisten
Call ListBox3_aktualisieren
CommandButton13 = True
ListBox2.Enabled = True
CommandButton8 = True 'Auswahl löschen
Label31.Caption = "Die Datei " & """" & (Worksheets("Worddaten").Range("B24")) & """" & " wurde geschlossen!"
Label39.Caption = vbLf & vbLf & " Bitte neue Auswahl treffen oder mittels Button ""Beenden"" das Formular schliessen!"
'Ende - zu erledigende Aufgaben
Else
If MsgBox("Wollen Sie das Dokument mit neuem Namen speichern?", vbOKCancel, "Meldung1") = vbOK Then
Do
Eingabe = InputBox("Bitte den Namenzusatz eingeben")
If StrPtr(Eingabe) = 0 Then
'Anfang WordDoc schliesen und ggf. Word beenden
If Not WrdApp Is Nothing Then
wrdDoc.Close 0
If WrdApp.Documents.Count = 0 Then WrdApp.Quit
On Error GoTo 0
Set wrdDoc = Nothing
Set WrdApp = Nothing
End If
With Label39
.BackColor = &HC0FFC0
.Caption = "Die Datei " & """" & strDName & """" & " wurde geschlossen!"
End With
CommandButton14.Enabled = False
CommandButton15.Enabled = False
'Ende WordDoc schliesen und ggf. Word beenden
'Anfang - zu erledigende Aufgaben
'da Dokument1 unter neuem Namen in Ordner "Dokumente" gespeichert wird, muss u.a. Makro ausgeführt werden
Call Word_Vorlagen_Laufend_auflisten
Call ListBox3_aktualisieren
CommandButton13 = True
ListBox2.Enabled = True
CommandButton8 = True 'Auswahl löschen
Label31.Caption = "Die Datei " & """" & (Worksheets("Worddaten").Range("B24")) & """" & " wurde geschlossen!"
Label39.Caption = vbLf & vbLf & " Bitte neue Auswahl treffen oder mittels Button ""Beenden"" das Formular schliessen!"
'Ende - zu erledigende Aufgaben
Exit Sub
End If
Loop While Eingabe = vbNullString
strDokNeu2 = ZielPfad & DatName & Eingabe & ".docx"
'Debug.Print strDokNeu2
'Anfang nochmalige Prüfung für strFile2
If Dir(strDokNeu2) = "" Then 'wenn kein Dokument vorhanden ist
'schreibgeschützt 'damit wird Dokument1 unter vorgegebenem Namen schreibgeschützt gespeichert
WrdApp.ActiveDocument.SaveAs Filename:=ZielPfad & DatName & Eingabe & ".docx", FileFormat:= _
wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
True, WritePassword:="", ReadOnlyRecommended:=True, EmbedTrueTypeFonts:= _
False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False
Label39.Font.Size = 12
Label39.Caption = "Das Dokument wurde im Ordner: " & strDokNeu2 & " schreibgeschützt - gespeichert!"
'Anfang WordDoc schliesen und ggf. Word beenden
If Not WrdApp Is Nothing Then
wrdDoc.Close 0
If WrdApp.Documents.Count = 0 Then WrdApp.Quit
Set wrdDoc = Nothing
Set WrdApp = Nothing
End If
With Label39
.BackColor = &HC0FFC0
.Caption = "Die Datei " & """" & strDName & """" & " wurde geschlossen!"
End With
CommandButton14.Enabled = False
CommandButton15.Enabled = False
'Ende WordDoc schliesen und ggf. Word beenden
'Anfang - zu erledigende Aufgaben
'da Dokument1 unter neuem Namen in Ordner "Dokumente" gespeichert wird, muss u.a. Makro ausgeführt werden
Call Word_Vorlagen_Laufend_auflisten
Call ListBox3_aktualisieren
CommandButton13 = True
ListBox2.Enabled = True
CommandButton8 = True 'Auswahl löschen
Label31.Caption = "Die Datei " & """" & (Worksheets("Worddaten").Range("B24")) & """" & " wurde geschlossen!"
Label39.Caption = vbLf & vbLf & " Bitte neue Auswahl treffen oder mittels Button ""Beenden"" das Formular schliessen!"
'Ende - zu erledigende Aufgaben
Else
Do
Eingabe = InputBox("Bitte anderen Namenzusatz eingeben - da bereits vorhanden")
If StrPtr(Eingabe) = 0 Then
'Anfang WordDoc schliesen und ggf. Word beenden
If Not WrdApp Is Nothing Then
wrdDoc.Close 0
If WrdApp.Documents.Count = 0 Then WrdApp.Quit
Set wrdDoc = Nothing
Set WrdApp = Nothing
End If
With Label39
.BackColor = &HC0FFC0
.Caption = "Die Datei " & """" & strDName & """" & " wurde geschlossen!"
End With
CommandButton14.Enabled = False
CommandButton15.Enabled = False
'Ende WordDoc schliesen und ggf. Word beenden
'Anfang - zu erledigende Aufgaben
'da Dokument1 unter neuem Namen in Ordner "Dokumente" gespeichert wird, muss u.a. Makro ausgeführt werden
Call Word_Vorlagen_Laufend_auflisten
Call ListBox3_aktualisieren
CommandButton13 = True
ListBox2.Enabled = True
CommandButton8 = True 'Auswahl löschen
Label31.Caption = "Die Datei " & """" & (Worksheets("Worddaten").Range("B24")) & """" & " wurde geschlossen!"
Label39.Caption = vbLf & vbLf & " Bitte neue Auswahl treffen oder mittels Button ""Beenden"" das Formular schliessen!"
'Ende - zu erledigende Aufgaben
Exit Sub
End If
Loop While Eingabe = vbNullString
strDokNeu2 = ZielPfad & DatName & Eingabe & ".docx" 'strPfad & strDokName & Eingabe & strEndung
'Debug.Print strDokNeu2
'schreibgeschützt 'damit wird Dokument1 unter vorgegebenem Namen schreibgeschützt gespeichert
WrdApp.ActiveDocument.SaveAs Filename:=ZielPfad & DatName & Eingabe & ".docx", FileFormat:= _
wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
True, WritePassword:="", ReadOnlyRecommended:=True, EmbedTrueTypeFonts:= _
False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False
Label39.Font.Size = 12
Label39.Caption = "Das Dokument wurde im Ordner: " & strDokNeu2 & " schreibgeschützt - gespeichert!"
'Anfang WordDoc schliesen und ggf. Word beenden
If Not WrdApp Is Nothing Then
wrdDoc.Close 0
If WrdApp.Documents.Count = 0 Then WrdApp.Quit
Set wrdDoc = Nothing
Set WrdApp = Nothing
End If
With Label39
.BackColor = &HC0FFC0
.Caption = "Die Datei " & """" & strDName & """" & " wurde geschlossen!"
End With
CommandButton14.Enabled = False
CommandButton15.Enabled = False
'Ende WordDoc schliesen und ggf. Word beenden
'Anfang - zu erledigende Aufgaben
'da Dokument1 unter neuem Namen in Ordner "Dokumente" gespeichert wird, muss u.a. Makro ausgeführt werden
Call Word_Vorlagen_Laufend_auflisten
Call ListBox3_aktualisieren
CommandButton13 = True
ListBox2.Enabled = True
CommandButton8 = True 'Auswahl löschen
Label31.Caption = "Die Datei " & """" & (Worksheets("Worddaten").Range("B24")) & """" & " wurde geschlossen!"
Label39.Caption = vbLf & vbLf & " Bitte neue Auswahl treffen oder mittels Button ""Beenden"" das Formular schliessen!"
'Ende - zu erledigende Aufgaben
End If
'Ende nochmalige Prüfung für strFile2
Else
Label39.Font.Size = 12
Label39.Caption = "Abbruch - das Dokument wurde nicht gespeichert"
.Close False
If WrdApp.Documents.Count = 0 Then WrdApp.Quit 'beendet Word nur wenn kein weiteres Word geöffnet ist
CommandButton14.Enabled = False
CommandButton15.Enabled = False
'Anfang - zu erledigende Aufgaben
'da Dokument1 unter neuem Namen in Ordner "Dokumente" gespeichert wird, muss u.a. Makro ausgeführt werden
Call Word_Vorlagen_Laufend_auflisten
Call ListBox3_aktualisieren
CommandButton13 = True
ListBox2.Enabled = True
CommandButton8 = True 'Auswahl löschen
Label31.Caption = "Die Datei " & """" & (Worksheets("Worddaten").Range("B24")) & """" & " wurde geschlossen!"
Label39.Caption = vbLf & vbLf & " Bitte neue Auswahl treffen oder mittels Button ""Beenden"" das Formular schliessen!"
'Ende - zu erledigende Aufgaben
End If 'End if für Msgbox("Wollen Sie
End If 'End if für Dir(strDokNeu)
End With 'End with für wrdDoc
ListBox2.ListIndex = -1
CommandButton2.Enabled = True
On Error GoTo 0
End Sub
'Dokument öffnen
Private Sub CommandButton18_Click()
'Wichtig! Die Deklarationen müssen damit CommandButton18 richtig ausgeführt wird für alles in der Zeile direkt unter Option Explicit stehen
'Dim WrdApp As Object
'Dim wrdDoc As Object
Dim pfad As String
Dim strDName As String
Dim PflichtName As String 'neu für Pflichtfeld
Application.ScreenUpdating = False
'Hier wird der Dateiname der WORD-Vorlage erstellt - bitte anpassen !
pfad = ThisWorkbook.Path & "\" 'von Gerhard 2021_04_23
'Debug.Print Pfad
strDName = pfad & ListBox3.Value
'Debug.Print strDName
If ListBox3.ListIndex = -1 Then
Label31.Font.Size = 14
Label31.Caption = vbLf & " bitte ein Dokument auswählen"
Exit Sub
Else
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = True
WrdApp.WindowState = 1 '0 = Normal; 1 = Maximized; 2 = Minimized
Application.EnableEvents = False 'aus - verhindert die Ausführung von Makros
Set wrdDoc = WrdApp.Documents.Open(strDName)
''''' wrdDoc.SelectContentControlsByTag("Pflichtfeld").Item(1).Range = "Test"
''''' wrdDoc.SelectContentControlsByTag("Pflichtfeld").Item(1).Range = "Carl-von-Linde-Gymnasium"
wrdDoc.SelectContentControlsByTag("Pflichtfeld").Item(1).Range = PflichtName
Application.EnableEvents = True 'ein - verhindert die Ausführung von Makros
Label39 = ""
Label31.Font.Size = 13
Label31.Caption = vbLf & " Dokument wurde geöffnet"
CommandButton18.Enabled = False
CommandButton27.Enabled = True
wrdDoc.Activate
End If
End Sub
'Word-Dokument schliessen
Private Sub CommandButton27_Click()
'Wichtig! Die Deklarationen müssen damit CommandButton27 richtig ausgeführt wird für alles in der Zeile direkt unter Option Explicit stehen
'Dim WrdApp As Object
'Dim wrdDoc As Object 'für öffnen der Wordvorlage
Dim PflichtName As String 'neu für Pflichtfeld
Application.ScreenUpdating = False
On Error Resume Next 'benötigt für Prüfung ob ein Worddokument geöffnet ist
If Err.Number 70 Then 'benötigt für Prüfung ob ein Worddokument geöffnet ist
'Anfang WordDoc schliesen und ggf. Word beenden
If Not WrdApp Is Nothing Then
' wrdDoc.SelectContentControlsByTag("Pflichtfeld").Item(1).Range = "Test1"
wrdDoc.SelectContentControlsByTag("Pflichtfeld").Item(1).Range = PflichtName
wrdDoc.Close 0
If WrdApp.Documents.Count = 0 Then WrdApp.Quit
Set wrdDoc = Nothing
Set WrdApp = Nothing
End If
With Label31 'Label39
.BackColor = &HC0FFC0
.Caption = vbLf & " Die Datei ist geschlossen!" '"Die Datei " & """" & strDName & """" & " wurde geschlossen!"
End With
CommandButton18.Enabled = True
CommandButton27.Enabled = False
'Ende WordDoc schliesen und ggf. Word beenden
CommandButton17 = True
Else 'benötigt für Prüfung ob ein Worddokument geöffnet ist
If Not WrdApp Is Nothing Then
If WrdApp.Documents.Count = 0 Then WrdApp.Quit
Set wrdDoc = Nothing
Set WrdApp = Nothing
With Label31 'Label39
.BackColor = &HC0FFC0
.Caption = vbLf & " Die Datei ist geschlossen!"
End With
CommandButton18.Enabled = True
CommandButton27.Enabled = False
ListBox3.ListIndex = -1
End If
End If
On Error GoTo 0 'benötigt für Prüfung ob ein Worddokument geöffnet ist
Application.ScreenUpdating = True
End Sub
Vermutlich wird auf dem anderen Rechner das Dokument1 nicht richtig mit Werten gespeichert.Könnt ihr mir bitte helfen, wo sich der Fehler befindet?
Gruss
Peter