'------------------------------------------------------------------
' OpenIMS Microsoft Word integration VBA.           [Version 4.2.16]
' (c) 2001-2005 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
'
'------------------------------------------------------------------
 
' OPENIMS Microsoft Word integration global variables
Dim OPENIMS_Count As Long
Dim OPENIMS_Keys() As String
Dim OPENIMS_Values() As String
 
Dim FoundBrackets(100, 100) As Boolean
Dim FoundBracketsHeaderFooter(100, 100) As Boolean
Dim FoundFooter(100, 100) As Boolean
 
' 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
 
' Make sure OPENIMS_OnLoad is executed
Sub Autoopen()
    If Not OPENIMS_IE() Then
        OPENIMS_OnLoad
    End If
End Sub
 
Public Function OPENIMS_GetMeta(FieldName As String)
    Dim i As Integer
    If (OPENIMS_Count = 0) Then OPENIMS_ReadMeta
    For i = 1 To OPENIMS_Count
        If OPENIMS_Keys(i) = "set_" & FieldName Then
            OPENIMS_GetMeta = OPENIMS_Values(i)
        End If
    Next i
End Function
 
' Implement the metadata OpenIMS appended to the file
' E.g. [[[version]]] is replaced by the appropriate "set_version"
Sub OPENIMS_OnLoad()
    
    statActiveProtectionType = ActiveDocument.ProtectionType
    If statActiveProtectionType <> wdNoProtection Then
      strPassword = "16762cvl" ' replace with password if one is present
      On Error Resume Next
      ActiveDocument.Unprotect strPassword
      On Error GoTo 0
    End If
 
    Dim Key As String
    Application.ScreenUpdating = False
    On Error Resume Next
    If FindWindow("OpusApp", vbNullString) > 0 Then
        LockWindowUpdate FindWindow("OpusApp", vbNullString)
    End If
    On Error GoTo 0
    OPENIMS_ReadMeta
    OPENIMS_SearchTextForBrackets
 
    For i = 1 To OPENIMS_Count
        If Left(OPENIMS_Keys(i), 4) = "set_" Then ' set a value
            Key = Right(OPENIMS_Keys(i), Len(OPENIMS_Keys(i)) - 4)
            OPENIMS_MarkText "[[[" & Key & "]]]", Key
            OPENIMS_SetText Key, OPENIMS_Values(i)
            OPENIMS_ReplaceText "<<<" & Key & ">>>", OPENIMS_Values(i)
        End If
    Next
 
    Selection.HomeKey wdStory
    On Error Resume Next
    If FindWindow("OpusApp", vbNullString) > 0 Then
        LockWindowUpdate 0&
    End If
 
    On Error GoTo 0
    Application.ScreenUpdating = True
    If statActiveProtectionType <> wdNoProtection Then
      On Error Resume Next
      ActiveDocument.Protect statActiveProtectionType, True, strPassword
      On Error GoTo 0
    End If
End Sub
 
' Mark a text object for future reference
Sub OPENIMS_SearchTextForBrackets()
    Dim aStory As Range, bStory As Range
    Dim Text As String
    Dim i As Integer, j As Integer
    
    i = 0
   
    Text = "[[["
    
    For Each aStory In ActiveDocument.StoryRanges
        i = i + 1
        j = 1
        aStory.Find.ClearFormatting
        With aStory.Find
            .Text = Text
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        aStory.Find.Execute
        
        If aStory.Find.Found Then
            FoundBrackets(i, j) = True
        Else
            FoundBrackets(i, j) = False
        End If
 
        Set bStory = aStory ' THB
        While Not (bStory.NextStoryRange Is Nothing)
            j = j + 1
            Set bStory = bStory.NextStoryRange
            bStory.Find.ClearFormatting
            With bStory.Find
                .Text = Text
                .Forward = True
                .Wrap = wdFindContinue
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
            End With
            bStory.Find.Execute
            If bStory.Find.Found Then
                FoundBrackets(i, j) = True
            Else
                FoundBrackets(i, j) = False
            End If
        Wend
    Next aStory
 
    Dim hfHeaderFooter As HeaderFooter
    Dim aSection As Section
    i = 0
    For Each sSection In ActiveDocument.Sections
        i = i + 1
        j = 0
        For Each hfHeaderFooter In sSection.Headers
            j = j + 1
            Set aStory = hfHeaderFooter.Range
            aStory.Find.ClearFormatting
            With aStory.Find
                  .Text = Text
                  .Forward = True
                  .Wrap = wdFindContinue
                  .Format = False
                  .MatchCase = False
                  .MatchWholeWord = False
                  .MatchWildcards = False

                  .MatchSoundsLike = False
                  .MatchAllWordForms = False
            End With
            aStory.Find.Execute
            If aStory.Text = Text Then
                FoundBracketsHeaderFooter(i, j) = True
            Else
                FoundBracketsHeaderFooter(i, j) = False
            End If
        Next
    Next sSection
    i = 0
    For Each sSection In ActiveDocument.Sections
        i = i + 1
        j = 0
        For Each hfHeaderFooter In sSection.Footers
            j = j + 1
            Set aStory = hfHeaderFooter.Range
            aStory.Find.ClearFormatting
            With aStory.Find
                  .Text = Text
                  .Forward = True
                  .Wrap = wdFindContinue
                  .Format = False
                  .MatchCase = False
                  .MatchWholeWord = False
                  .MatchWildcards = False
                  .MatchSoundsLike = False
                  .MatchAllWordForms = False
            End With
            aStory.Find.Execute
            If aStory.Find.Found Then
                FoundFooter(i, j) = True
            Else
                FoundFooter(i, j) = False
            End If
        Next
    Next sSection
End Sub
 
' Mark a text object for future reference
Sub OPENIMS_MarkText(Text As String, ID As String)
    Dim aStory As Range, bStory As Range
    
    Dim i As Integer, j As Integer
    
    i = 0
    For Each aStory In ActiveDocument.StoryRanges
        i = i + 1
        j = 1
        If FoundBrackets(i, j) = False Then
 
        Else
            aStory.Find.ClearFormatting
            With aStory.Find
                .Text = Text
                .Forward = True
                .Wrap = wdFindContinue
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
            End With
            aStory.Find.Execute
            While aStory.Find.Found
                aStory.Fields.Add Range:=aStory, Type:=wdFieldEmpty, Text:= _
                    "MACROBUTTON OPENIMS_FIELD_" & ID & "   ", PreserveFormatting:=False
                aStory.Find.Execute
            Wend
        End If
 
        Set bStory = aStory ' THB
        While Not (bStory.NextStoryRange Is Nothing)
            j = j + 1
            Set bStory = bStory.NextStoryRange
            If FoundBrackets(i, j) = False Then
 
            Else
                bStory.Find.ClearFormatting
                With bStory.Find
                    .Text = Text
                    .Forward = True
                    .Wrap = wdFindContinue
                    .Format = False
                    .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                End With
                bStory.Find.Execute
                While bStory.Find.Found
                    bStory.Fields.Add Range:=bStory, Type:=wdFieldEmpty, Text:= _
                        "MACROBUTTON OPENIMS_FIELD_" & ID & " " & Text, PreserveFormatting:=False
                    bStory.Find.Execute
                Wend
            End If
        Wend
    Next aStory
 
    Dim hfHeaderFooter As HeaderFooter
    Dim aSection As Section
    i = 0
    For Each sSection In ActiveDocument.Sections
        i = i + 1
        j = 0
        For Each hfHeaderFooter In sSection.Headers
            j = j + 1
            Set aStory = hfHeaderFooter.Range
            If FoundBracketsHeaderFooter(i, j) = False Then
 
            Else
                aStory.Find.ClearFormatting
                With aStory.Find
                    .Text = Text
                    .Forward = True
                    .Wrap = wdFindContinue
                    .Format = False
                    .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                End With
                aStory.Find.Execute
                While aStory.Find.Found
                    aStory.Fields.Add Range:=aStory, Type:=wdFieldEmpty, Text:= _
                        "MACROBUTTON OPENIMS_FIELD_" & ID & " " & Text, PreserveFormatting:=False
                    aStory.Find.Execute
                Wend
            End If
        Next
    Next sSection
 
    i = 0
    For Each sSection In ActiveDocument.Sections
        i = i + 1
        j = 0
        For Each hfHeaderFooter In sSection.Footers
            j = j + 1
            Set aStory = hfHeaderFooter.Range
            If FoundFooter(i, j) = False Then
 
            Else
                aStory.Find.ClearFormatting
                With aStory.Find
                    .Text = Text
                    .Forward = True
                    .Wrap = wdFindContinue
                    .Format = False
                    .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                End With
                aStory.Find.Execute
                While aStory.Find.Found
                    aStory.Fields.Add Range:=aStory, Type:=wdFieldEmpty, Text:= _
                        "MACROBUTTON OPENIMS_FIELD_" & ID & " " & Text, PreserveFormatting:=False
                    aStory.Find.Execute
                Wend
            End If
        Next
    Next sSection
End Sub
 
' Change the content of a marked text object
Sub OPENIMS_SetText(ID As String, Text As String)
    On Error Resume Next
    If ActiveDocument.Bookmarks.Exists("openims_" & ID) = True Then
        Selection.GoTo What:=wdGoToBookmark, Name:="openims_" & ID
        Selection.Delete
        Selection.InsertAfter Text
        ActiveDocument.Bookmarks.Add Range:=Selection.Range, Name:="openims_" & ID
    End If
    On Error GoTo 0
    Dim aStory As Range
    Dim aField As Field
    Start = " MACROBUTTON OPENIMS_FIELD_" & ID & " "
    For Each aStory In ActiveDocument.StoryRanges
        For Each aField In aStory.Fields
            If Left(aField.Code.Text, Len(Start)) = Start Then
                aField.Code.Text = Start & Text
            End If
        Next aField
        While Not (aStory.NextStoryRange Is Nothing)
            Set aStory = aStory.NextStoryRange
            For Each aField In aStory.Fields
                If Left(aField.Code.Text, Len(Start)) = Start Then
                    aField.Code.Text = Start & Text
                End If
            Next aField
        Wend
    Next aStory
    Dim hfHeaderFooter As HeaderFooter
    Dim aSection As Section
    For Each sSection In ActiveDocument.Sections
        For Each hfHeaderFooter In sSection.Headers
            Set aStory = hfHeaderFooter.Range
            For Each aField In aStory.Fields
                If Left(aField.Code.Text, Len(Start)) = Start Then
                    aField.Code.Text = Start & Text
                End If
            Next aField
        Next
    Next sSection
    For Each sSection In ActiveDocument.Sections
        For Each hfHeaderFooter In sSection.Footers
            Set aStory = hfHeaderFooter.Range
            For Each aField In aStory.Fields
                If Left(aField.Code.Text, Len(Start)) = Start Then
                    aField.Code.Text = Start & Text
                End If
            Next aField
        Next
    Next sSection
End Sub
 
' Detect if Word is running inside IE
Function OPENIMS_IE() As Boolean
    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 = ReplaceACharacter(strIN, "#D", "!")
    strIN = ReplaceACharacter(strIN, "#C", "*")
    strIN = ReplaceACharacter(strIN, "#B", Chr(0))
    strIN = ReplaceACharacter(strIN, "#A", "#")
    
    '--- replace is not implemented in Word 97 VBA ---
    'strIN = Replace(strIN, "#D", "!")
    'strIN = Replace(strIN, "#C", "*")
    'strIN = Replace(strIN, "#B", Chr(0))
    'strIN = Replace(strIN, "#A", "#")
    
    OPENIMS_DecodeMetadata = strIN
End Function

' NOTE! This function only works if two characters are replaced by one
Function ReplaceACharacter(InWhat As String, FindWhat As String, ReplaceWith As String) As String
    Dim StartAtCharacter As Long
    StartAtCharacter = 1
    StartAtCharacter = InStr(StartAtCharacter, InWhat, FindWhat)
    Do While StartAtCharacter <> 0
        InWhat = Left$(InWhat, StartAtCharacter - 1) _
                & ReplaceWith _
                & Mid$(InWhat, StartAtCharacter + 2)
        StartAtCharacter = InStr(StartAtCharacter + 1, InWhat, FindWhat)
    Loop
    ReplaceACharacter = InWhat
End Function
 
' Read and parse the metadata OpenIMS appended to the file
Sub OPENIMS_ReadMeta()
    Dim Size As Long, Count As Long
    Dim List As String, Mode As String, Key As String, Value As String
    OPENIMS_Count = 0
    If (OPENIMS_GetFilepart(OPENIMS_GetMyFileSize() - 13, 14) = _
                                                       "OpenIMS_Marker") Then
        Size = Val(OPENIMS_GetFilepart(OPENIMS_GetMyFileSize() - 23, 10))
        List = OPENIMS_GetFilepart(OPENIMS_GetMyFileSize() - 23 - Size, Size)
        For i = 1 To Len(List) - 1
            If Mid(List, i, 1) = "*" Then
                Count = Count + 1
            End If
        Next i
        ReDim OPENIMS_Keys(1 To Count / 2) As String
        ReDim OPENIMS_Values(1 To Count / 2) As String
        Mode = "key"
        For i = 1 To Len(List) - 1
            If Mid(List, i, 1) = "*" Then
                If Mode = "key" Then
                    Mode = "value"
                Else
                    Mode = "key"
                    OPENIMS_Count = OPENIMS_Count + 1
                    OPENIMS_Keys(OPENIMS_Count) = Key
                    OPENIMS_Values(OPENIMS_Count) = Value
                    Key = ""
                    Value = ""
                End If
            Else
                If Mode = "key" Then
                    Key = Key & Mid(List, i, 1)
                Else
                    Value = Value & Mid(List, i, 1)
                End If
            End If
        Next i
        ' clean up meta data
        For i = 1 To OPENIMS_Count
            OPENIMS_Values(i) = OPENIMS_DecodeMetadata(OPENIMS_Values(i))
        Next i
    End If
End Sub



' Mark a text object for future reference
Sub OPENIMS_ReplaceText(Text As String, Value As String)
    Dim aStory As Range
    For Each aStory In ActiveDocument.StoryRanges
      again = True
      While again
        again = False
        aStory.Find.ClearFormatting
        With aStory.Find
            .Text = Text
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        aStory.Find.Execute
        If aStory.Text = Text Then
            aStory.Text = Value
        End If
      Wend
    Next aStory
End Sub