Update document properties

Tue, 15 Jul 2008 23:23:06 +0200

Update document properties

Find and write parent foldername

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

Split parts of filename

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

Select ListBox entries

Tue, 15 Jul 2008 23:20:31 +0200

Select ListBox entries

Takes a comma-separated list and selects matching entries of a ListBox.

Private Sub MarkMe(List As ListBox, Items As TextBox)
  Dim MergedData As Variant
  Dim iArray As Variant
 
  If (Not IsNull(Items.Value)) Then MergedData = Items.Value
 
  iArray = Split(MergedData, ",", -1, vbTextCompare)
 
  ' set everything to false (deselect all)
  For intI = 0 To List.ListCount
    List.Selected(intI) = False
  Next intI
 
  For Each curItem In iArray
    curItem = Trim(curItem)
    For intI = 0 To List.ListCount
      If List.ItemData(intI) = curItem Then
        List.Selected(intI) = True
        Exit For
      End If
    Next intI
  Next curItem
End Sub

Update ListBox from comma-separated text

Tue, 15 Jul 2008 23:19:51 +0200

Update ListBox from comma-separated text

Updates a comma-separated text in a TextBox, adding newly selected values in a ListBox or removing deselected ones, leaving everything not in the ListBox untouched.

Private Sub UpdateMe(List As ListBox, Items As TextBox)
  Dim MergedData As String
  Dim iArray As Variant
  Dim nArray As Variant
  Dim Found As Boolean
 
  If (Not IsNull(Items.Value)) Then
    MergedData = Items.Value
    iArray = Split(MergedData, ",", -1, vbTextCompare)
  Else
    iArray = Array()
  End If
  nArray = Array("PRE")
 
  For intI = 0 To List.ListCount
    If List.Selected(intI) Then
      nArray = Split(Join(nArray, ",") & "," & List.ItemData(intI), ",", -1, vbTextCompare)
    End If
  Next intI
  For Each curItem In iArray
    curItem = Trim(curItem)
    Found = False
    For intI = 0 To List.ListCount
      If List.ItemData(intI) = curItem Then
        Found = True
      End If
    Next intI
    If Not Found Then nArray = Split(Join(nArray, ",") & "," & curItem, ",", -1, vbTextCompare)
  Next curItem
 
  MergedData = Join(nArray, ", ")
  MergedData = Replace(MergedData, "PRE, ", "")
  MergedData = Replace(MergedData, "PRE", "")
  Items.Value = MergedData
End Sub

mbirth's Wiki snippets:vba

Update document properties

Update document properties

Find and write parent foldername

Split parts of filename

Select ListBox entries

Select ListBox entries

VBA

VBA

Update ListBox from comma-separated text

Update ListBox from comma-separated text