(Aktuelle) Kalenderwoche als Dokumenteigenschaft

Über die Feldfunktionen lassen sich bequem Datums- und Zeitinformationen in ein Dokument integrieren.
Leider gibt es jedoch keine Feldfunktion für die (aktuelle) Kalenderwoche.

Mit nachstehender Funktion lässt sich aus einem Datum die Kalenderwoche (nach DIN 1355) berechnen und als Eigenschaft (benutzerdefinierte Dokumenteigenschaft) dem aktuellen Dokument zur Verfügung stellen.

Die Einbindung in das Dokument erfolgt dann ganz normal über das DOCPROPERTY-Feld:

{ DOCPROPERTY KW }

Funktion zum Berechnen der Kalenderwoche aus einem Datum:

Function KWoche(d As Date) As Integer  
'Kalenderwochen nach DIN 1355  
'Algorithmus von Christoph Kremer, Aachen  
  Dim t&
  t = DateSerial(Year(d + (8 - Weekday(d)) Mod 7 - 3), 1, 1)
  KWoche = (d - t - 3 + (Weekday(t) + 1) Mod 7) \ 7 + 1
End Function 

Damit diese Funktion in dem Dokument verwendet werden kann, wird z.B. im AutoNew-Makro die Kalenderwoche in eine benutzerdefinierte Dokumenteigenschaft (CustomDocumentProperties) gespeichert.
Ist diese Dokumenteigenschaft noch nicht vorhanden, wird sie neu angelegt. Anderenfalls mit dem aktuellen Wert belegt.

Sub AutoNew()  
Dim oProp As DocumentProperty
On Error Resume Next
Set oProp = ActiveDocument.CustomDocumentProperties("KW")
On Error GoTo 0
If oProp Is Nothing Then
  Set oProp = ActiveDocument.CustomDocumentProperties.Add(Name:="KW", LinkToContent:=False, _
    Type:=msoPropertyTypeNumber, Value:=KWoche(Now))
End If
  oProp.Value = KWoche(Now)
End Sub  

Da die Funktion  KWoche jedes im Aufruf angegebene Datum verwendet, lässt sich daraus auch eine allgemein gültige Berechnungsfunktion erstellen:

Sub KWocheAusDatum()  
Const c_Titel As String = "Kalenderwoche berechnen"
Dim dDate As Date, sDate As String
sDate = InputBox("Bitte ein Datum (Tag.Monat.Jahr) eingeben", c_Titel, Format(Now, "dd.mm.yyyy"))
If IsDate(sDate) = True Then
  MsgBox "Der " & dDate & " liegt in der " & KWoche(dDate) & ". Kalenderwoche", vbInformation, c_Titel
Else
  MsgBox "Kein gültiges Datum (Datumsformat) angegeben!", vbCritical, c_Titel
End If
End Sub