#10
von d'r Bastler » 27. Jun 2024, 17:52
Moin allerseits,
das Thema liegt zwar schon eine Weile, aber nachdem mich der erntereiche Sommer dazu zwingt immer neue Rezepte zu notieren, habe ich mich der Automatisierung des Ganzen noch einmal gewidmet.
Für den folgenden Code braucht man eine USF mit einer TextBox, einer ComboBox und einem CommandButton. Die Combo wird aus einem Array im Code (
der in die Userform gehört) gefüllt. Als Vorlage dient ein Rezept-Layout, das die Textmarke "titel" enthält. Da müsst Ihr selbst kreativ werden
Code: Alles auswählen
Option Explicit
Public sPath As String
Private Sub UserForm_Initialize()
Dim i As Integer, f As Integer
Dim aChapter ' Array
sPath = ThisDocument.Path & "\"
aChapter = Array("Basics", "Getränke", "Vorspeisen", "Suppen & Saucen", "Nudeln & Eintöpfe", "Gemüse", _
"Fisch", "Geflügel", "Schwein", "Kalb", "Rind", "Lamm", "Beilagen", "Salate", "Süßspeisen", "Gebäck")
cbxFolder.List = aChapter
For i = 0 To UBound(aChapter)
If Dir$(sPath & aChapter(i), vbDirectory) = "" Then
MkDir sPath & aChapter(i)
f = f + 1
End If
Next
If f > 0 Then
MsgBox f & " neue Ordner angelegt!", , "insgesamt " & i
End If
lblName.Caption = "Bitte beachten: Titel = Dateiname!" & vbNewLine & "Keine unzulässigen Zeichen!"
End Sub
Private Sub cbxFolder_Change()
Dim sText As String
Dim rng As Range
'' Bookmark head
If ActiveDocument.Bookmarks.Exists("head") Then
Set rng = ActiveDocument.Bookmarks("head").Range
rng.Text = cbxFolder.Value
Else
MsgBox "Bookmark head?"
End If
sText = cbxFolder.Text
With ActiveDocument
.Bookmarks.Add Range:=rng, Name:="head"
End With
End Sub
Private Sub cmdMakeFile_Click()
Dim sDocName As String, sDocPath As String, sDocFolder As String
Dim rng As Range
'' Titel vorhanden?
sDocName = tbxTitel.Text
If Len(sDocName) < 2 Then
MsgBox "Bitte Titel eingeben!", , "Hinweis"
Exit Sub
End If
''Kapitel ausgewählt?
sDocFolder = cbxFolder.Value
If cbxFolder.ListIndex < 0 Then
MsgBox "Bitte Kapitel auswählen!", , "Hinweis"
Exit Sub
End If
'' Bookmark title
If ActiveDocument.Bookmarks.Exists("title") Then
Set rng = ActiveDocument.Bookmarks("title").Range
rng.Text = sDocName
Else
MsgBox "Bookmark title?"
End If
sDocPath = ThisDocument.Path & "\" & sDocFolder & "\"
Application.DisplayAlerts = False
sDocName = sDocPath & sDocName & ".docx"
ActiveDocument.SaveAs2 FileName:=sDocName, FileFormat:=wdFormatXMLDocument
Unload Me
Application.Documents.Open FileName:=sDocName
MsgBox sDocName, , "Neue Datei angelegt!"
End Sub
Die Lösung war letztlich die richtige Reihenfolge der letzten drei Befehle. Nach der MsgBox steht das neue Dok mit Titel da wie eine Eins. Die neue Datei enthält noch Makros, die aber beim nächsten Öffnen verschwinden.
Liebe Grüße und Dank für alle vorherige Unterstützung.
Moin allerseits,
das Thema liegt zwar schon eine Weile, aber nachdem mich der erntereiche Sommer dazu zwingt immer neue Rezepte zu notieren, habe ich mich der Automatisierung des Ganzen noch einmal gewidmet.
Für den folgenden Code braucht man eine USF mit einer TextBox, einer ComboBox und einem CommandButton. Die Combo wird aus einem Array im Code ([b]der in die Userform gehört[/b]) gefüllt. Als Vorlage dient ein Rezept-Layout, das die Textmarke "titel" enthält. Da müsst Ihr selbst kreativ werden ;-)
[code]Option Explicit
Public sPath As String
Private Sub UserForm_Initialize()
Dim i As Integer, f As Integer
Dim aChapter ' Array
sPath = ThisDocument.Path & "\"
aChapter = Array("Basics", "Getränke", "Vorspeisen", "Suppen & Saucen", "Nudeln & Eintöpfe", "Gemüse", _
"Fisch", "Geflügel", "Schwein", "Kalb", "Rind", "Lamm", "Beilagen", "Salate", "Süßspeisen", "Gebäck")
cbxFolder.List = aChapter
For i = 0 To UBound(aChapter)
If Dir$(sPath & aChapter(i), vbDirectory) = "" Then
MkDir sPath & aChapter(i)
f = f + 1
End If
Next
If f > 0 Then
MsgBox f & " neue Ordner angelegt!", , "insgesamt " & i
End If
lblName.Caption = "Bitte beachten: Titel = Dateiname!" & vbNewLine & "Keine unzulässigen Zeichen!"
End Sub
Private Sub cbxFolder_Change()
Dim sText As String
Dim rng As Range
'' Bookmark head
If ActiveDocument.Bookmarks.Exists("head") Then
Set rng = ActiveDocument.Bookmarks("head").Range
rng.Text = cbxFolder.Value
Else
MsgBox "Bookmark head?"
End If
sText = cbxFolder.Text
With ActiveDocument
.Bookmarks.Add Range:=rng, Name:="head"
End With
End Sub
Private Sub cmdMakeFile_Click()
Dim sDocName As String, sDocPath As String, sDocFolder As String
Dim rng As Range
'' Titel vorhanden?
sDocName = tbxTitel.Text
If Len(sDocName) < 2 Then
MsgBox "Bitte Titel eingeben!", , "Hinweis"
Exit Sub
End If
''Kapitel ausgewählt?
sDocFolder = cbxFolder.Value
If cbxFolder.ListIndex < 0 Then
MsgBox "Bitte Kapitel auswählen!", , "Hinweis"
Exit Sub
End If
'' Bookmark title
If ActiveDocument.Bookmarks.Exists("title") Then
Set rng = ActiveDocument.Bookmarks("title").Range
rng.Text = sDocName
Else
MsgBox "Bookmark title?"
End If
sDocPath = ThisDocument.Path & "\" & sDocFolder & "\"
Application.DisplayAlerts = False
sDocName = sDocPath & sDocName & ".docx"
ActiveDocument.SaveAs2 FileName:=sDocName, FileFormat:=wdFormatXMLDocument
Unload Me
Application.Documents.Open FileName:=sDocName
MsgBox sDocName, , "Neue Datei angelegt!"
End Sub
[/code]
Die Lösung war letztlich die richtige Reihenfolge der letzten drei Befehle. Nach der MsgBox steht das neue Dok mit Titel da wie eine Eins. Die neue Datei enthält noch Makros, die aber beim nächsten Öffnen verschwinden.
Liebe Grüße und Dank für alle vorherige Unterstützung.