Automatische aktuelle Datumsangabe

[koter]

Hallo Siggi,

ein frohes neues Jahr!

Die Ergänzung:

Code:

Sub UpdateDateAndExport4()
   Dim PDFEinst As PDFVBASettings
   Dim currentDate As String, PDFName As String, FormatString As String, ProjektNr As String, Dateiname As String
   Dim x As Shape
   Dim s As Page
   Dim xR  As ShapeRange, xRall As New ShapeRange, xProjAlle As New ShapeRange
   Dim ds() As String
   
   If Documents.Count < 1 Then Exit Sub 'Abbrechen falls kein Dokument vorhanden ist
   Set PDFEinst = ActiveDocument.PDFSettings
   
   ' Aktuelles Datum im Format "DD.MM.YY"
   currentDate = Format(Date, "DD.MM.YY")
   ProjektNr = Projektnummer(True)
   
   For Each s In ActiveDocument.Pages 'Auf allen Seiten suchen
       Set xR = s.Shapes.FindShapes(Query:="@com.name.StartsWith('DatumHeute')")
       xRall.AddRange xR
   Next
   
   For Each s In ActiveDocument.Pages 'Auf allen Seiten suchen
       Set xR = s.Shapes.FindShapes(Query:="@com.name.StartsWith('ProjektNr')")
       xProjAlle.AddRange xR
   Next

  For Each x In xRall
      ' Überprüfen, ob die Form den Namen "DatumHeute" hat
      If x.Name = "DatumHeute" Then
          x.Text.Story = currentDate
          ElseIf Left(x.Name, 10) = "DatumHeute" Then ' Überprüfen, ob der Name der Form mit "DatumHeute" beginnt
          ds = Split(x.Name, "(")
          FormatString = Left(ds(1), Len(ds(1)) - 1)
          x.Text.Story = Format$(Date, FormatString)
          FormatString = ""
      End If
  Next
 
  For Each x In xProjAlle
      ' Überprüfen, ob die Form den Namen "ProjektNr" hat
      If x.Name = "ProjektNr" Then
          x.Text.Story = ProjektNr
      End If
  Next

  ' Dokument speichern
  ActiveDocument.Save

  PDFName = DateiDialog
  If PDFName = "" Then Exit Sub 'Abbrechen falls kein Name übergeben wurde
  If Not PDFEinst.ShowDialog Then Exit Sub 'Abbrechen falls Abbrechen gewählt wurde
  ActiveDocument.PublishToPDF PDFName

End Sub

Function DateiDialog() As String
   Dim CST As CorelScriptTools
   Dim CDRN As String, DN As String, RN As String
   Dim Antw
   
   Set CST = CorelScriptTools
   DN = ActiveDocument.Name
   DN = Left(DN, Len(DN) - 3) & "pdf"
   RN = CST.GetFileBox("(PDF)|*.pdf", "Als PDF freigeben", 1, DN)
   If Len(RN) < 1 Then DateiDialog = RN: Exit Function
   If Len(Dir(RN)) > 0 Then
       Antw = MsgBox("Soll die bestehende Datei überschrieben werden?", vbQuestion + vbYesNo, "Datei überschreiben")
       DateiDialog = ""
       If Antw = vbYes Then
           DateiDialog = RN
       End If
   Else
       DateiDialog = RN
   End If
End Function

Function Projektnummer(NurNummer As Boolean) As String
   Dim Dateiname As String, ProjektNrMit As String, ProjektNrOhne As String
   Dim ds() As String
   Dateiname = ActiveDocument.FileName
   Debug.Print Dateiname
   ds = Split(Dateiname, "_")
   ProjektNrMit = ds(0)
   ds = Split(ProjektNrMit, "-")
   ProjektNrOhne = ds(1)
   If NurNummer Then
       Projektnummer = ProjektNrOhne
   Else
       Projektnummer = ProjektNrMit
   End If
End Function

Ich habe nicht genau verstanden, ob der Suffix (WER-) auch eingetragen werden soll.
Falls ja, ändere die Zeile
ProjektNr = Projektnummer(True)
in
ProjektNr = Projektnummer(False)

Gruß

Koter