Update document properties

Private Sub Document_Open()
  '
  ' Kopfnamen-Makro
  ' Aktualisiert die Bezeichnung in der Kopfzeile anhand des Pfads
  ' Erstellt 12.11.2007 von Markus Birth <mbirth@webwriters.de>
  '
  ' WICHTIG!!!!
  ' Im Ordner mit den Abteilungsbüchern muss eine Datei
  ' .rootmarker.NichtLöschen.txt
  ' existieren, damit die Bezeichnung richtig gesetzt wird

  Set fs = CreateObject("Scripting.FileSystemObject")
 
  Dim FN
  FN = ThisDocument.Name
  FP = ThisDocument.Path
  CRLF = Chr(13) & Chr(10)
 
  HBTIT = "Evangelisches" & CRLF & "Waldkrankenhaus" & CRLF & "Spandau"
  RootM = ".rootmarker.NichtLöschen.txt"
 
 
 
  BeautyName = Left(FN, Len(FN) - 4)
 
  ' Find Rootmarker
  IsFound = False
  RMP = FP
  Do
    If (fs.FileExists(RMP & "\" & RootM)) Then
      IsFound = True
    Else
      pi = InStrRev(RMP, "\")
      If (pi > 0) Then RMP = Left(RMP, pi - 1)
    End If
  Loop Until (IsFound Or pi = 0)
 
  If (IsFound) Then
    ' Root marker found in RMP, now find first folder
    FF = Mid(FP, Len(RMP) + 1)
    If (Left(FF, 1) = "\") Then FF = Mid(FF, 2)
    If (InStr(FF, "\") <> 0) Then FF = Left(FF, InStr(FF, "\") - 1)
 
    ' remove digits or spaces from beginning of text
    While (InStr("0123456789 .", Left(FF, 1)) <> 0)
      FF = Mid(FF, 2)
    Wend
 
    AddProp "AbtTitel", FF & CRLF & HBTIT
  Else
    AddProp "AbtTitel", HBTIT
  End If
End Sub
 
Private Sub AddProp(PName, PVal)
  ' Fügt eine DokumentenVariable dem Dokument hinzu oder ändert eine bestehende
  ' Erstellt am 28.09.2005 von Markus Birth <mbirth@webwriters.de>
  num = 0
  For Each e In ThisDocument.CustomDocumentProperties
    If e.Name = PName Then num = 1
  Next e
 
  If num = 0 Then
    ThisDocument.CustomDocumentProperties.Add PName, False, msoPropertyTypeString, PVal
  Else
    ThisDocument.CustomDocumentProperties(PName).Value = PVal
  End If
End Sub

Private Sub Document_Open()
  '
  ' Kopfnamen-Makro
  ' Aktualisiert die Bezeichnung in der Kopfzeile anhand des Dateinamens
  ' Erstellt 28.09.2005 von Markus Birth <mbirth@webwriters.de>
  '
  ' WICHTIG!!!!
  ' Das Dokument muss unter einem Verzeichnis "Band II" oder "PHB II" liegen,
  ' damit das entsprechende PHB erkannt wird. Außerdem muss der Dateiname
  ' folgende Richtlinien erfüllen:
  '      <sortierung>_<kapitel> <Bezeichnung>_<Version>
  ' z.B. 101_1.1 Pflege- und Versorgungskonzept_3.doc
  '

  Dim FN
  FN = ThisDocument.Name
  FP = ThisDocument.Path
 
  PHBNUM = ""    ' "Band"
  PHBCHA = ""    ' "Kapitel"
  PHBTIT = ""    ' "Titel"
  PHBVER = 1     ' "Version"
  BeautyName = Left(FN, Len(FN) - 4)
 
  ' Find "Band" or "PHB" in path and read the word thereafter
  bi = InStr(1, FP, "Band", vbTextCompare)
  If bi = 0 Then bi = InStr(1, FP, "PHB", vbTextCompare)
  If bi <> 0 Then
    bi2 = InStr(bi, FP, " ", vbTextCompare)
    If bi2 = 0 Then bi2 = InStr(bi + 1, FP, "_", vbTextCompare)
    If bi2 <> 0 Then
      bi3 = InStr(bi2 + 1, FP, " ", vbTextCompare)
      If bi3 = 0 Then bi3 = InStr(bi2 + 1, FP, "_", vbTextCompare)
      If bi3 <> 0 Then
        PHBNUM = " " & Mid(FP, bi2 + 1, bi3 - bi2 - 1) & ":"
      End If
    End If
  End If
 
  ' Find chapter, chapter title and version
  ci = InStr(1, FN, "_", vbTextCompare)
  If ci <> 0 Then
    ci2 = InStr(ci + 1, FN, " ", vbTextCompare)
    ci3 = InStr(ci + 1, FN, "_", vbTextCompare)
    If ci3 = 0 Then
      ci3 = InStr(ci + 1, FN, ".doc", vbTextCompare)
    Else
      ci4 = InStr(ci3 + 1, FN, ".doc", vbTextCompare)
      PHBVER = Mid(FN, ci3 + 1, ci4 - ci3 - 1)
    End If
    If ci2 <> 0 Then
      PHBCHA = " " & Mid(FN, ci + 1, ci2 - ci - 1)
      PHBTIT = Mid(FN, ci2 + 1, ci3 - ci2 - 1)
    Else
      PHBTIT = Mid(FN, ci + 1, ci3 - ci - 1)
    End If
    BeautyName = "PHB" & PHBNUM & PHBCHA & " " & Chr(150) & " " & PHBTIT
  End If
 
  AddProp "BeautyName", BeautyName
  AddProp "Version", PHBVER
End Sub
 
Private Sub AddProp(PName, PVal)
  ' Fügt eine DokumentenVariable dem Dokument hinzu oder ändert eine bestehende
  ' Erstellt am 28.09.2005 von Markus Birth <mbirth@webwriters.de>
  num = 0
  For Each e In ThisDocument.CustomDocumentProperties
    If e.Name = PName Then num = 1
  Next e
 
  If num = 0 Then
    ThisDocument.CustomDocumentProperties.Add PName, False, msoPropertyTypeString, PVal
  Else
    ThisDocument.CustomDocumentProperties(PName).Value = PVal
  End If
End Sub