Word2003Makro Dokument automatisch in neuem Unterordner speichern und ausdrucken
Hallo,
bin neu hier im Forum und "Laie" im VBA Programmieren. Es wäre nett, wenn mich jemand unterstützen könnte, die noch offenen Fragen zu klären.
Vielen Dank schon einmal im Voraus.
Wir sind eine Beratungsstelle, in der wir Gesprächsprotokolle mit Word2003 erstellen, die in zwei Versionen auf einem Serverlaufwerk abgespeichert werden sollen (1. Verlauf, 2. mit Anhang persönliche Notizen). Dies habe ich versucht über Makros in Word 2003 zu lösen.
Im ersten Makro wird das Worddokument, nach Abfrage des Speicheror-tes und –Namens abgespeichert. Dann wird ein Teil des Textes kopiert und unten angehängt, so dass man seine persönlichen Notizen anhängen kann. Dieses erste Makro (s. Anhang) funktioniert gut, bis darauf, dass der zuerst vorgeschlagene Speicherort nicht der jeweilige Desktop des jeweils angemeldeten Benutzers ist.
_________________________________________________
Sub PersönlichesProtokoll()
'
' PersönlichesProtokoll Makro
' Makro aufgezeichnet am 06.02.2013 von T.Mueller
'
Dim dialog As Object
Dim pfad As String
Dim datei As String
pfad = "B:\8. FALL - VERWALTUNG\5. LAUFENDE FÄLLE\Gesprächsprotokoll"
Set dialog = Application.FileDialog(msoFileDialogSaveAs)
With dialog
.InitialFileName = pfad
.Show
End With
If dialog <> False Then dialog.Execute
Selection.InsertBreak Type:=wdPageBreak
Selection.InsertBreak Type:=wdSectionBreakNextPage
Selection.HomeKey Unit:=wdStory
Selection.MoveDown Unit:=wdLine, Count:=3, Extend:=wdExtend
Selection.Copy
Selection.EndKey Unit:=wdStory
Selection.PasteAndFormat (wdPasteDefault)
Selection.TypeText Text:="Persönliche Notizen:"
Selection.TypeParagraph
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=21, Extend:=wdExtend
Selection.Font.Bold = wdToggle
With Selection.ParagraphFormat
.LeftIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpace1pt5
.Alignment = wdAlignParagraphLeft
.WidowControl = True
.KeepWithNext = True
.KeepTogether = False
.PageBreakBefore = False
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = CentimetersToPoints(0)
.OutlineLevel = wdOutlineLevelBodyText
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
.AutoAdjustRightIndent = True
.DisableLineHeightGrid = False
.FarEastLineBreakControl = True
.WordWrap = True
.HangingPunctuation = True
.HalfWidthPunctuationOnTopOfLine = False
.AddSpaceBetweenFarEastAndAlpha = True
.AddSpaceBetweenFarEastAndDigit = True
.BaseLineAlignment = wdBaselineAlignAuto
End With
Selection.MoveDown Unit:=wdLine, Count:=1
End Sub
_________________________________________________
Im zweiten Makro soll nun die Datei erneut abgespeichert werden und anschließend in ganzer Länge ausgedruckt werden. Auch das habe ich per Makro hinbekommen. Jetzt aber die Besonderheiten:
Der Dateiname soll gleich bleiben, aber in einem neu zu erstellenden Un-terordner, mit dem pauschalen Namen "PN" (für persönliche Notizen), in-nerhalb des bestehenden Ordners, abgespeichert werden. Zum Teil be-steht der PN Ordner schon (wenn zuvor Protokolle erstellt wurden), zum Teil auch nicht (erstes Protokoll). Der Ordner PN sollte also nur dann erstellt werden, wenn er noch nicht besteht. Nach dem Abspeichern soll die ge-samte Datei automatisch ausgedruckt werden.
Meine Schwierigkeit besteht nun darin, erstens den bestehenden Pfad zum Abspeichern auszulesen, zweitens zu sondieren, ob ein PN Ordner be-steht, drittens, diesen bei Bedarf einzufügen und dann die Datei dort ab-zuspeichern. Zudem hat sich beim Probieren oftmals gezeigt, dass im zwei-ten Makro beim Abspeichern als „Speicherort“ die Dokumentvorlagenauswahl angezeigt wurde und nicht die Ordnerstruktur für die Protokolle.
_________________________________________________
Sub ProtokollAusdrucken()
'
' ProtokollAusdrucken Makro
' Makro erstellt am 26.02.2013 von T.Mueller
'
Dim dialog As Object
Dim pfad As String
Dim datei As String
dname = ActiveDocument.Name
MsgBox (dname)
pfad = "B:\8. FALL - VERWALTUNG\5. LAUFENDE FÄLLE\Gesprächsprotokoll"
Set dialog = Application.FileDialog(msoFileDialogSaveAs)
With dialog
.InitialFileName = pfad
.Show
End With
Application.PrintOut Filename:="", Range:=wdPrintAllDocument, Item:= _
wdPrintDocumentContent, Copies:=1, Pages:="", PageType:=wdPrintAllPages, _
ManualDuplexPrint:=False, Collate:=True, Background:=True, PrintToFile:= _
False, PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
PrintZoomPaperHeight:=0
End Sub
_________________________________________________
Soweit die Beschreibung des Problems. Kann jemand weiterhelfen und mir zeigen, wie ich die Makros programmieren kann. Vielen Dank schon ein-mal im Voraus.
Im ersten Makro wird das Worddokument, nach Abfrage des Speicheror-tes und –Namens abgespeichert. Dann wird ein Teil des Textes kopiert und unten angehängt, so dass man seine persönlichen Notizen anhängen kann. Dieses erste Makro (s. Anhang) funktioniert gut, bis darauf, dass der zuerst vorgeschlagene Speicherort nicht der jeweilige Desktop des jeweils angemeldeten Benutzers ist.
_________________________________________________
Sub PersönlichesProtokoll()
'
' PersönlichesProtokoll Makro
' Makro aufgezeichnet am 06.02.2013 von T.Mueller
'
Dim dialog As Object
Dim pfad As String
Dim datei As String
pfad = "B:\8. FALL - VERWALTUNG\5. LAUFENDE FÄLLE\Gesprächsprotokoll"
Set dialog = Application.FileDialog(msoFileDialogSaveAs)
With dialog
.InitialFileName = pfad
.Show
End With
If dialog <> False Then dialog.Execute
Selection.InsertBreak Type:=wdPageBreak
Selection.InsertBreak Type:=wdSectionBreakNextPage
Selection.HomeKey Unit:=wdStory
Selection.MoveDown Unit:=wdLine, Count:=3, Extend:=wdExtend
Selection.Copy
Selection.EndKey Unit:=wdStory
Selection.PasteAndFormat (wdPasteDefault)
Selection.TypeText Text:="Persönliche Notizen:"
Selection.TypeParagraph
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=21, Extend:=wdExtend
Selection.Font.Bold = wdToggle
With Selection.ParagraphFormat
.LeftIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpace1pt5
.Alignment = wdAlignParagraphLeft
.WidowControl = True
.KeepWithNext = True
.KeepTogether = False
.PageBreakBefore = False
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = CentimetersToPoints(0)
.OutlineLevel = wdOutlineLevelBodyText
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
.AutoAdjustRightIndent = True
.DisableLineHeightGrid = False
.FarEastLineBreakControl = True
.WordWrap = True
.HangingPunctuation = True
.HalfWidthPunctuationOnTopOfLine = False
.AddSpaceBetweenFarEastAndAlpha = True
.AddSpaceBetweenFarEastAndDigit = True
.BaseLineAlignment = wdBaselineAlignAuto
End With
Selection.MoveDown Unit:=wdLine, Count:=1
End Sub
_________________________________________________
Im zweiten Makro soll nun die Datei erneut abgespeichert werden und anschließend in ganzer Länge ausgedruckt werden. Auch das habe ich per Makro hinbekommen. Jetzt aber die Besonderheiten:
Der Dateiname soll gleich bleiben, aber in einem neu zu erstellenden Un-terordner, mit dem pauschalen Namen "PN" (für persönliche Notizen), in-nerhalb des bestehenden Ordners, abgespeichert werden. Zum Teil be-steht der PN Ordner schon (wenn zuvor Protokolle erstellt wurden), zum Teil auch nicht (erstes Protokoll). Der Ordner PN sollte also nur dann erstellt werden, wenn er noch nicht besteht. Nach dem Abspeichern soll die ge-samte Datei automatisch ausgedruckt werden.
Meine Schwierigkeit besteht nun darin, erstens den bestehenden Pfad zum Abspeichern auszulesen, zweitens zu sondieren, ob ein PN Ordner be-steht, drittens, diesen bei Bedarf einzufügen und dann die Datei dort ab-zuspeichern. Zudem hat sich beim Probieren oftmals gezeigt, dass im zwei-ten Makro beim Abspeichern als „Speicherort“ die Dokumentvorlagenauswahl angezeigt wurde und nicht die Ordnerstruktur für die Protokolle.
_________________________________________________
Sub ProtokollAusdrucken()
'
' ProtokollAusdrucken Makro
' Makro erstellt am 26.02.2013 von T.Mueller
'
Dim dialog As Object
Dim pfad As String
Dim datei As String
dname = ActiveDocument.Name
MsgBox (dname)
pfad = "B:\8. FALL - VERWALTUNG\5. LAUFENDE FÄLLE\Gesprächsprotokoll"
Set dialog = Application.FileDialog(msoFileDialogSaveAs)
With dialog
.InitialFileName = pfad
.Show
End With
Application.PrintOut Filename:="", Range:=wdPrintAllDocument, Item:= _
wdPrintDocumentContent, Copies:=1, Pages:="", PageType:=wdPrintAllPages, _
ManualDuplexPrint:=False, Collate:=True, Background:=True, PrintToFile:= _
False, PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
PrintZoomPaperHeight:=0
End Sub
_________________________________________________
Soweit die Beschreibung des Problems. Kann jemand weiterhelfen und mir zeigen, wie ich die Makros programmieren kann. Vielen Dank schon ein-mal im Voraus.
Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben
Content-Key: 202786
Url: https://administrator.de/contentid/202786
Ausgedruckt am: 29.03.2024 um 09:03 Uhr
6 Kommentare
Neuester Kommentar
Hi Office-Explorer, Willkommen im Forum,
Zu deinem ersten Problem:
Für dein zweites Problem sollte dir folgender Code weiterhelfen:
p.s. Bitte poste deinen Code der Übersicht halber mit Code-Tags, Danke.
Formatierungen in den Beiträgen
Grüße Uwe
Zu deinem ersten Problem:
Zitat von @Office-Explorer:
Dieses erste Makro (s.
Anhang) funktioniert gut, bis darauf, dass der zuerst vorgeschlagene Speicherort nicht der jeweilige Desktop des jeweils
angemeldeten Benutzers ist.
Dein Pfad zu einem Ordner sollte mit einem Backslash(\} enden dann sollte der Dialog den Ordner richtig übernehmen.Dieses erste Makro (s.
Anhang) funktioniert gut, bis darauf, dass der zuerst vorgeschlagene Speicherort nicht der jeweilige Desktop des jeweils
angemeldeten Benutzers ist.
pfad = "B:\8. FALL - VERWALTUNG\5. LAUFENDE FÄLLE\Gesprächsprotokoll\"
Für dein zweites Problem sollte dir folgender Code weiterhelfen:
'Pfad des aktuellen Dokuments
mainfolder = ActiveDocument.Path
'Pfad zum Subfolder "PN"
pnSubFolder = mainfolder & "\PN"
If Dir(subfolder, vbDirectory) <> vbNullString Then
'Ordner PN existiert
Else
'Ordner PN existiert noch nicht, also erstelle Ihn
MkDir (subfolder)
End If
p.s. Bitte poste deinen Code der Übersicht halber mit Code-Tags, Danke.
Formatierungen in den Beiträgen
Grüße Uwe
Sub ProtokollAusdrucken()
Dim dialog As Object
Dim pfad As String
Dim datei As String
dname = ActiveDocument.Name
'Pfad des aktuellen Dokuments
mainfolder = ActiveDocument.Path
'Pfad zum Subfolder "PN"
pnSubFolder = mainfolder & "\PN"
If Dir(pnSubFolder, vbDirectory) = vbNullString Then
MkDir (pnSubFolder)
End If
ActiveDocument.SaveAs2 FileName:=pnSubFolder & "\" & dname
Application.PrintOut Filename:="", Range:=wdPrintAllDocument, Item:= _
wdPrintDocumentContent, Copies:=1, Pages:="", PageType:=wdPrintAllPages, _
ManualDuplexPrint:=False, Collate:=True, Background:=True, PrintToFile:= _
False, PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
PrintZoomPaperHeight:=0
End Sub