Option Explicit
'------------------------------------------------------------------
' OpenIMS Microsoft Word integration VBA.          [Version 4.2.23]
' revision: 21 jan 2008 Bas Cost Budde
' additions:
'  speed;
'  first time run only;
'  removal of line with only empty fields unless field code ends in +,-,_ ;
'
' (c) 2001-2008 OpenSesame ICT, all rights reserved.
' See http://www.osict.com/openims/termsofuse.txt for more details.
'
' Implementation: Embed into Word document (perhaps define strPassword)
' Usage: Enter [[[version]]] somewhere in your document
' Supports write-once fields as <<<fieldname>>>
'
' Will (!) work inside IE. (SSL-proof)
'
' Note: Enable "Trust access to Visual Basic Projects"
'      in Macro Security Settings
'
' Note: be sure to adapt CUSTOMER_ type routines
'------------------------------------------------------------------
' OPENIMS Microsoft Word integration global variables

'consts for functionality switches
Const OPENIMS_RUNONCE = False
Const OPENIMS_KEEPEMPTYLINES = True
Const OPENIMS_LEAVEPLAINTEXT = False

Const cPrefix = "MACROBUTTON OPENIMS_FIELD_"
Const nPrefixlen = 26 'Len(cPrefix)'the compiler doesn't buy that

Public OPENIMS_Metakeys As New Collection 'used in parseFields
Public OPENIMS_Metadata As New Collection
Public OPENIMS_keysUsed As String
Public OPENIMS_ERROR As Variant
Dim OPENIMS_DataIsRead As Boolean 'is set to true after initial metadata import

'consts for single run function
Const ASK = 12 'any number
Const FLAGNAME = "OPENIMS_FLAG"

' Functions used to freeze the Microsoft Word window while the macro is running
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function LockWindowUpdate Lib "user32" _
    (ByVal hwndLock As Long) As Long

Sub AutoOpen()
Dim t As Double
    t = Timer
    If Not OPENIMS_RUNONCE Or Not WeHaveRun(ASK) Then
        If Not OPENIMS_IE() Then
            OPENIMS_OnLoad
            If OPENIMS_LEAVEPLAINTEXT Then CUSTOMER_ScanFields
            ' restore normal view
            If ActiveDocument.ActiveWindow.Panes.Count >= 2 Then
                ActiveDocument.ActiveWindow.ActivePane.Close
            End If
            If ActiveWindow.View.SplitSpecial = wdPaneNone Then
                ActiveWindow.ActivePane.View.Type = wdPrintView
            Else
                ActiveWindow.View.Type = wdPrintView
            End If
        End If
    End If
    t = Timer - t
    Debug.Print "Macro execution time="; Int(t * 1000); "ms"
End Sub

Public Function OPENIMS_GetMeta(FieldName As String) As String
'gets a value from the internal structure (getter)
'note you supply the real fieldname, whereas it is stored with the 'set_' prefix
Dim i As Integer
'retrained to use collection
On Error Resume Next
    OPENIMS_EnsureMeta
    OPENIMS_GetMeta = "" '
    OPENIMS_GetMeta = OPENIMS_Metadata("set_" & FieldName)
    OPENIMS_ERROR = Err
End Function

Sub OPENIMS_OnLoad()
Dim i As Integer
Dim hasReplaceonceFields As Boolean
Dim Key As String
Dim cPassword As String
Dim protType As Long
Dim bDocProtected As Boolean
On Error Resume Next
    protType = ActiveDocument.ProtectionType
    bDocProtected = (protType <> wdNoProtection)
    If bDocProtected Then
      cPassword = "16762cvl" ' replace with password if one is present
      On Error Resume Next
      ActiveDocument.Unprotect cPassword
      On Error GoTo 0
    End If
    Application.ScreenUpdating = False
    On Error Resume Next
    If FindWindow("OpusApp", vbNullString) > 0 Then
        LockWindowUpdate FindWindow("OpusApp", vbNullString)
    End If
    On Error GoTo 0
    OPENIMS_DataIsRead = False
    OPENIMS_EnsureMeta
    OPENIMS_ImplementMetaData
    OPENIMS_ApplyMetaData 'there is a slight overlap in function because implementdata sets the values as well
    'it may be rebuilt to not do so
    Selection.HomeKey wdStory
    On Error Resume Next
    If FindWindow("OpusApp", vbNullString) > 0 Then
        LockWindowUpdate 0&
    End If
    On Error GoTo 0
    
    'refresh page numbers in the table of content
    Dim toc As TableOfContents
    For Each toc In ActiveDocument.TablesOfContents
        toc.Update
    Next
    
    WeHaveRun 'sets the flag
    Application.ScreenUpdating = True
    If bDocProtected Then
      On Error Resume Next
      ActiveDocument.Protect protType, True, cPassword
      On Error GoTo 0
    End If
End Sub

Sub OPENIMS_ImplementField(objF As Field)
'actual data fill
Dim cKey As String
Dim cValue As String
Dim cText As String
Dim nStart As Long
    cText = objF.Code.Text
    nStart = InStr(cText, cPrefix)
    cKey = Mid(cText, nStart + nPrefixlen, InStr(nPrefixlen, cText, " ") - nPrefixlen - nStart)
    cValue = OPENIMS_GetMeta(cKey)
    objF.Code.Text = cPrefix & cKey & " " & cValue
Debug.Print "OPENIMS_ImplementField key='"; cKey; "' value="; cValue
End Sub

Function isOPENIMSfield(cName As String) As Boolean
Debug.Print ":"; Trim(cName); ":"
Dim bRes As Boolean
    bRes = (Left(Trim(cName), nPrefixlen) = cPrefix)
Debug.Print " ? "; bRes
    isOPENIMSfield = bRes
End Function

Sub OPENIMS_ApplyMetaData()
' writes metadata values in fields that exist in the document
Dim aStory As Range, bStory As Range
Dim aField As Field
Dim objHF As HeaderFooter
Dim objSec As Section
Debug.Print "applying metadata"
    'examine all text
    For Each bStory In ActiveDocument.StoryRanges
        Set aStory = bStory
        Do Until aStory Is Nothing
          For Each aField In aStory.Fields
              If isOPENIMSfield(aField.Code.Text) Then
                  aField.Select
                  OPENIMS_ImplementField aField
              End If
          Next
        Set aStory = aStory.NextStoryRange
       Loop
    Next
    'examine headers and footers
    For Each objSec In ActiveDocument.Sections
        'headers
        For Each objHF In objSec.Headers
            Set aStory = objHF.Range
            For Each aField In aStory.Fields
                If isOPENIMSfield(aField.Code.Text) Then
                    aField.Select
                    OPENIMS_ImplementField aField
                End If
            Next
        Next
        'and footers
        For Each objHF In objSec.Footers
            Set aStory = objHF.Range
            For Each aField In aStory.Fields
                If isOPENIMSfield(aField.Code.Text) Then
                    aField.Select
                    OPENIMS_ImplementField aField
                End If
            Next
        Next
    Next
End Sub

Function OPENIMS_ImplementMetaData() As Boolean
'change bracket notation into document fields
'this is a function because I thought I needed the result, ie whether it had found fields to implement
' but I do not use that result as yet
Dim aStory As Range, bStory As Range
Dim objHF As HeaderFooter
Dim objSec As Section
Dim bRes As Boolean
    bRes = False
    For Each aStory In ActiveDocument.StoryRanges
        Set bStory = aStory 'make a copy to shift along the ranges in this type
        Do Until bStory Is Nothing
            bRes = bRes Or OPENIMS_CheckRange(bStory)
            Set bStory = bStory.NextStoryRange
        Loop
    Next
    For Each objSec In ActiveDocument.Sections
        For Each objHF In objSec.Headers
            bRes = bRes Or OPENIMS_CheckRange(objHF.Range)
        Next
        For Each objHF In objSec.Footers
            bRes = bRes Or OPENIMS_CheckRange(objHF.Range)
        Next
    Next
    OPENIMS_ImplementMetaData = bRes
End Function

Sub OPENIMS_PruneMeta()
'this routine is not called!
'it will discard all metadata from the structure that is not represented in the document
' (marked in the KeyIsUsed structure)
' this will speed up custom (BJZNH) procedures considerably without having me to rewrite them
Dim i As Long
Dim cKey As String, Item As Variant
    i = 1
    Do While i <= OPENIMS_Metakeys.Count
        cKey = OPENIMS_Metakeys(i)
        If OPENIMS_KeyIsUsed(cKey) Then
'Debug.Print "keep "; cKey
            i = i + 1
        Else
            OPENIMS_Metakeys.Remove i
            OPENIMS_Metadata.Remove i
        End If
    Loop
End Sub

Function OPENIMS_CheckRange(obj As Range) As Boolean
' check some range for marker occurrences; if so, create the appropriate word field/plain text
Dim bRes As Boolean
    bRes = False
    OPENIMS_SetFind obj.Find, "\[\[\[*\]\]\]"
    obj.Find.Execute
    Do While obj.Find.Found
        bRes = True
        OPENIMS_MakeField obj
        obj.Find.Execute
    Loop
    OPENIMS_SetFind obj.Find, "\<\<\<*\>\>\>"
    obj.Find.Execute
    Do While obj.Find.Found
        OPENIMS_MakeText obj
        obj.Find.Execute
    Loop
    obj.Find.Execute "\[\[\{", ReplaceWith:="[[[", Replace:=wdReplaceAll
    obj.Find.Execute "\}\]\]", ReplaceWith:="]]]", Replace:=wdReplaceAll
    OPENIMS_CheckRange = bRes
End Function

Sub OPENIMS_MakeField(obj As Range)
'actual replace of the marker text by the field
Dim cKey As String
Dim cValue As String
    'remove brackets
    cKey = Mid(obj.Text, 4, Len(obj.Text) - 6)
    cValue = OPENIMS_GetMeta(cKey)
    If OPENIMS_ERROR Then
        'error meaning key is not in the dataset
        ' we must do something to the brackets to prevent endless loop
        obj.Text = "[[{" & cKey & "}]]"
    Else
        OPENIMS_MarkAsUsed "set_" & cKey
        obj.Fields.Add Range:=obj, Type:=wdFieldEmpty, Text:= _
            cPrefix & cKey & " " & cValue, PreserveFormatting:=False
    End If
End Sub

Sub OPENIMS_MakeText(obj As Range)
'actual replace of the marker by the plaintext
Dim cKey As String
Dim cValue As String
    cKey = Mid(obj.Text, 4, Len(obj.Text) - 6)
    cValue = OPENIMS_GetMeta(cKey)
    'we don't markasused because there is no pointer left in the document
    obj.Text = cValue
End Sub

Sub OPENIMS_SetFind(ByRef obj As Find, cText As String)
'## created BCB 070727
'helper routine to shorten the procedure code
    With obj
        .ClearFormatting
        .Text = cText
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = (InStr(cText, "*") > 0) 'patch for makeField & makeText
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
End Sub

Sub OPENIMS_MarkAsUsed(cKey As String)
' note when a field actually occurred in the document
' when the init routine has finished, it may clean up all unused metadata
    On Error Resume Next
    OPENIMS_keysUsed = OPENIMS_keysUsed & ":" & cKey
End Sub

Function OPENIMS_KeyIsUsed(cKey As String) As Boolean
'getter
    OPENIMS_KeyIsUsed = (InStr(OPENIMS_keysUsed, cKey) > 0)
End Function

' Detect if Word is running inside IE
Function OPENIMS_IE() As Boolean
Dim theLen As Long
    theLen = 0
    On Error Resume Next
    theLen = OPENIMS_GetMyFileSize()
    On Error GoTo 0
    OPENIMS_IE = theLen = 0
End Function

Function OPENIMS_GetMyFullFilename() As String
    OPENIMS_GetMyFullFilename = ActiveDocument.FullName
    If ((InStr(1, ActiveDocument.FullName, "http:")) Or (InStr(1, ActiveDocument.FullName, "https:"))) Then
        OPENIMS_GetMyFullFilename = ActiveDocument.VBProject.FileName
    Else
        OPENIMS_GetMyFullFilename = ActiveDocument.FullName
    End If
End Function

Function OPENIMS_GetMyFileSize() As Long
    OPENIMS_GetMyFileSize = FileLen(OPENIMS_GetMyFullFilename())
End Function

' Extract part of the current file as string
Function OPENIMS_GetFilepart(Start As Long, Size As Long) As String
Dim FileNo As Integer
Dim FileName As String
Dim Bytes() As Byte
Dim Result As String
Dim i As Long
    FileNo = FreeFile
    FileName = OPENIMS_GetMyFullFilename()
    Open FileName For Binary Access Read As #FileNo
    ReDim Bytes(0 To Size - 1) As Byte
    Get #FileNo, Start, Bytes
    Close #FileNo
    For i = 0 To Size - 1
        Result = Result & Chr(Bytes(i))
    Next
    OPENIMS_GetFilepart = Result
End Function

' decode metadata: some character need de-escaping:
' #A -> #
' #B -> chr(0)
' #C -> *
' #D -> !
Function OPENIMS_DecodeMetadata(strIN As String) As String
    strIN = Replace(strIN, "#D", "!")
    strIN = Replace(strIN, "#C", "*")
    strIN = Replace(strIN, "#B", Chr(0))
    strIN = Replace(strIN, "#A", "#")
    OPENIMS_DecodeMetadata = strIN
End Function

' Read and parse the metadata OpenIMS appended to the file
Sub OPENIMS_ReadMeta()
'the parsing was sped up by actively looking for '*' instead of treating each character separately
Dim nFilesize As Long
Dim Size As Long
Dim cList As String
Dim nPos As Long
Dim cMode As String
Dim cKey As String
Dim cWord As String
    nFilesize = OPENIMS_GetMyFileSize()
    If OPENIMS_GetFilepart(nFilesize - 13, 14) = "OpenIMS_Marker" Then
        Size = Val(OPENIMS_GetFilepart(nFilesize - 23, 10))
        cList = OPENIMS_GetFilepart(nFilesize - 23 - Size, Size)
    Else
        Exit Sub
    End If
    Set OPENIMS_Metakeys = New Collection
    Set OPENIMS_Metadata = New Collection
    OPENIMS_keysUsed = ""
    cMode = "key"
    cKey = ""
    nPos = InStr(cList, "*")
    Do Until cList = "" Or nPos = 0
        If nPos = 1 Then
            cWord = ""
        Else
            cWord = Left(cList, nPos - 1)
        End If
        If nPos = Len(cList) Then
            cList = ""
        Else
            cList = Mid(cList, nPos + 1)
        End If
        Select Case cMode
        Case "key"
            cKey = cWord
            cMode = "value"
        Case "value"
            OPENIMS_SetMeta cKey, OPENIMS_DecodeMetadata(cWord)
            cMode = "key"
        End Select
        nPos = InStr(cList, "*")
    Loop
    OPENIMS_DataIsRead = True
'Debug.Print OPENIMS_Metakeys.Count; "items"
End Sub

Sub OPENIMS_SetMeta(cKey As String, cValue As String)
'adds a tuple to the internal structure (setter)
On Error Resume Next
'Debug.Print "adding data pair "; cKey; ","; cValue
    OPENIMS_Metakeys.Add cKey, cKey
    OPENIMS_Metadata.Add cValue, cKey
End Sub

Sub OPENIMS_EnsureMeta()
'I'm not taking the time yet to figure out whether this wrapper is necessary
'every routine that relies on the metadata internal structure should call this first
    If OPENIMS_DataIsRead = False Then
        OPENIMS_ReadMeta
        CUSTOMER_ExtendMeta
    End If
End Sub

'******************************
' customer specific functions *
'******************************

Sub CUSTOMER_ExtendMeta()
    OPENIMS_SetMeta "set_special_dms_tussenvoegsel", "aaa"
End Sub

Public Sub CUSTOMER_ScanFields()
'customer-specific treatment for fields with empty value
Dim aStory As Range, bStory As Range
Dim aField As Field
Dim objHF As HeaderFooter
Dim objSec As Section
    For Each bStory In ActiveDocument.StoryRanges
        Set aStory = bStory
        Do Until aStory Is Nothing
          For Each aField In aStory.Fields
              If InStr(aField.Code.Text, cPrefix) > 0 Then
                  aField.Select
                  OPENIMS_DoField aField
              End If
          Next
        Set aStory = aStory.NextStoryRange
       Loop
    Next
    For Each objSec In ActiveDocument.Sections
        For Each objHF In objSec.Headers
            Set aStory = objHF.Range
            For Each aField In aStory.Fields
                If InStr(aField.Code.Text, cPrefix) > 0 Then
                    aField.Select
                    OPENIMS_DoField aField
                End If
            Next
        Next
        For Each objHF In objSec.Footers
            Set aStory = objHF.Range
            For Each aField In aStory.Fields
                If InStr(aField.Code.Text, cPrefix) > 0 Then
                    aField.Select
                    OPENIMS_DoField aField
                End If
            Next
        Next
    Next
End Sub

Sub OPENIMS_DoField(objF As Field)
Dim cKey As String
Dim cText As String
Dim nPos As Long
Dim bRun As Boolean
'Debug.Print "OPENIMS_DoField"
'is every field on this line empty?
    If OPENIMS_KEEPEMPTYLINES Then
        bRun = True
    Else
        bRun = Not KillEmptyLine(objF)
    End If
    If bRun Then
        cText = objF.Code.Text
        nPos = InStr(cText, cPrefix)
        cKey = Mid(cText, nPos + nPrefixlen, InStr(nPos + nPrefixlen, cText, " ") - nPrefixlen - nPos)
        'pass to new routine
        CUSTOMER_TreatField cKey
    End If
End Sub

Sub CUSTOMER_TreatField(cKey As String)
Dim cVal As String
    cVal = OPENIMS_GetMeta(cKey)
    Select Case cKey
    Case "dms_voorvoegsels"
        'capitalize first letter
        cVal = StrConv(cVal, vbProperCase)
    Case "special_dms_tussenvoegsel"
        'deze vorm krijgt wel een hoofdletter
        cVal = StrConv(OPENIMS_GetMeta("dms_tussenvoegsel"), vbProperCase)
    Case "dms_auteur"
        'namens-functionaliteit
        If OPENIMS_GetMeta("dms_namens") <> "" Then 'use instead of auteur
            cVal = OPENIMS_GetMeta("dms_namens")
        End If
    End Select
    'when we are here, either the field has a value,
    ' or it is empty but there are other fields in the same paragraph
    ' there shall not be an empty line, because that would have been completely removed
    'when value, write the value;
    'when empty, remove the field and one adjacent space, if present
    If cVal = "" Then
        Selection.Expand wdWord
        Selection.Delete
    Else
        Selection.Text = cVal
    End If
End Sub

Function WeHaveRun(Optional how) As Boolean
'if the parameter is provided, test the flag
'if not, set the flag
Dim V As Variables
Dim Item As Variant
Dim i As Integer
    Set V = ActiveDocument.Variables
    i = 0
    For Each Item In V
        If Item.Name = FLAGNAME Then i = Item.Index
    Next
    If IsMissing(how) Then
        'raise the flag!
        If i = 0 Then
            V.Add FLAGNAME, True
        Else
            V(FLAGNAME) = True 'funny, though, considering the functionality meant.
            ' this can happen, of course, when someone (you?) has reset the flag
        End If
    Else
        'test the flag
        If i = 0 Then
            WeHaveRun = False
        Else
            WeHaveRun = V(i).Value
        End If
    End If
End Function

Public Sub ni()
'developer utility function to overcome single shot run
    ActiveDocument.Variables(FLAGNAME) = False
    AutoOpen
End Sub

Function KillEmptyLine(objF As Field) As Boolean
Dim f As Fields
Dim r As Range
Dim idx As Field
Dim nPos As Long
Dim bEmpty As Boolean
'Debug.Print "KillEmptyLine"
' On Error Resume Next
    Set r = Selection.Range
    r.Expand wdParagraph
    Set f = r.Fields
    bEmpty = True
    For Each idx In f
        nPos = InStr(nPrefixlen, idx.Code.Text, " ")
        If nPos > 0 Then
            ' does the field have a value?
            If Trim(Mid(idx.Code.Text, nPos)) <> "" Then
                bEmpty = False
            End If
            ' is the field a keepline type?
            Select Case Mid(idx.Code.Text, nPos - 1, 1)
            Case "+", "-", "_"
                bEmpty = False
            End Select
        End If
    Next
    If bEmpty Then
        Selection.Expand wdParagraph
        Selection.Delete
    End If
    KillEmptyLine = bEmpty
End Function

Public Sub dumpp()
Dim idx As Variant
    OPENIMS_EnsureMeta
    For Each idx In OPENIMS_Metakeys
        Debug.Print idx; "="; OPENIMS_Metadata(idx)
    Next
End Sub