Option Explicit
 
'------------------------------------------------------------------
' OpenIMS Microsoft Visio 2003 integration VBA.
' [Version 1.1.0 - 20070222]
' (c) 2001-2005 OpenSesame ICT, all rights reserved.
' See http://www.osict.com/openims/termsofuse.txt for more details.
'
' Implementation: Embed into Visio 2003 document (perhaps define strPassword)
' Usage: Enter [[[version]]] somewhere in your document
'
' Additional header / footer information using function: HeaderFooter()
'
'
' Note: Set security settings to medium or low
'       in Macro Security Settings
'
'------------------------------------------------------------------
 
' OPENIMS Microsoft Visio integration global variables
Dim OPENIMS_Count As Long
Dim OPENIMS_Keys() As String
Dim OPENIMS_Values() As String
 
' Functions used to freeze the 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()
    Dim key As String, i As Integer
'    Application.ScreenUpdating = False
 
    On Error GoTo 0
    ' fetch all meta data
    OPENIMS_ReadMeta
    
    ' find all fields with [[[<<<meta>>>]]], and add if necessary OPENIMS_<<<meta>>> custom field
    FindBracketsAndAddCustomField
 
    ' find OPENIMS_<<<meta>>> custom fields in shapes. If found replace shape text
    ' with reference to custom field
    ProcessShapesWithOpenimsCustomFields
   
    HeaderFooter
   
    On Error GoTo 0
'    Application.ScreenUpdating = True
End Sub
 
' Detect if Word is running inside IE
Function OPENIMS_IE() As Boolean
    Dim TheLen As Integer
    
    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:") 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
    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()
    Dim Size As Long, Count As Long
    Dim List As String, Mode As String, key As String, value As String
    Dim i As Integer
 
    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
        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
 
Function DoesOPENIMSpropertyExist(vsoShape As Visio.Shape) As String
    ' check if for given shape an "OPENIMS_" custom property exists
    Dim vsoCell As Visio.Cell
    Dim i As Integer, rows As Integer
    Dim ValName As String, PromptName As String, LabelName As String
    rows = vsoShape.RowCount(Visio.visSectionProp)
    If rows > 0 Then
        DoesOPENIMSpropertyExist = ""
        For i = 0 To rows - 1
            Set vsoCell = vsoShape.CellsSRC(Visio.visSectionProp, i, 0)
            ValName = vsoCell.ResultStr(Visio.visNone)
            Set vsoCell = vsoShape.CellsSRC(Visio.visSectionProp, i, 1)
            PromptName = vsoCell.ResultStr(Visio.visNone)
            Set vsoCell = vsoShape.CellsSRC(Visio.visSectionProp, i, 2)
            LabelName = vsoCell.ResultStr(Visio.visNone)
            If Left(LabelName, 8) = "OPENIMS_" Then
                DoesOPENIMSpropertyExist = LabelName
                Exit For
            End If
        Next i
    Else
        DoesOPENIMSpropertyExist = ""
    End If
End Function
 
Function DoesCustompropertyExist(vsoShape As Visio.Shape, propname As String)
    ' check if for given shape an "OPENIMS_" custom property exists
    Dim vsoCell As Visio.Cell
    Dim i As Integer, rows As Integer
    Dim ValName As String, PromptName As String, LabelName As String
    rows = vsoShape.RowCount(Visio.visSectionProp)
    If rows > 0 Then
        DoesCustompropertyExist = False
        For i = 0 To rows - 1
            Set vsoCell = vsoShape.CellsSRC(Visio.visSectionProp, i, 0)
            ValName = vsoCell.ResultStr(Visio.visNone)
            Set vsoCell = vsoShape.CellsSRC(Visio.visSectionProp, i, 1)
            PromptName = vsoCell.ResultStr(Visio.visNone)
            Set vsoCell = vsoShape.CellsSRC(Visio.visSectionProp, i, 2)
            LabelName = vsoCell.ResultStr(Visio.visNone)
            If LabelName = propname Then
                DoesCustompropertyExist = True
                Exit For
            End If
        Next i
    Else
        DoesCustompropertyExist = False
    End If
End Function
 
Sub ModifyCustomfield(vsoShape As Visio.Shape, name As String, value As String)
    Dim value2 As String
    value2 = Replace(value, Chr(34), Chr(34) & Chr(34))
    vsoShape.Cells("Prop." & name & ".Value").Formula = Chr(34) & value2 & Chr(34)
End Sub
 
Sub AddCustomfield(vsoShape As Visio.Shape, name As String, value As String)
    Dim newrow As Integer
    Dim vsoCell As Visio.Cell
    value = Replace(value, """", """""""")
    newrow = vsoShape.AddNamedRow(Visio.visSectionProp, name, 0)
    Set vsoCell = vsoShape.CellsSRC(Visio.visSectionProp, newrow, 2)
    vsoCell.Formula = """" & name & """"
    Set vsoCell = vsoShape.CellsSRC(Visio.visSectionProp, newrow, 0)
    vsoCell.Formula = """" & value & """"
End Sub
 
Sub FindBracketsAndAddCustomField()
    Dim vsoCharacters As Visio.Characters
    Dim vsoShape As Visio.Shape
    ' traverse all shapes
    ' look in every shape for [[[<<<meta>>>]]]
    ' if it exists, and there is no OPENIMS_ custom field then add OPENIMS_<<<meta>>> custom field
    Dim h As Integer, i As Integer, j As Integer, key As String
    For h = 1 To Application.ActiveDocument.Pages.Count
    'For i = 1 To Application.ActiveWindow.Page.Shapes.Count
    For i = 1 To Application.ActiveDocument.Pages(h).Shapes.Count
        'Set vsoShape = Application.ActiveWindow.Page.Shapes.ItemFromID(i)
        Set vsoShape = Application.ActiveDocument.Pages(h).Shapes.ItemFromID(i)
        'Set vsoCharacters = Application.ActiveWindow.Page.Shapes.ItemFromID(i).Characters
        Set vsoCharacters = vsoShape.Characters
 
        'If vsoCharacters.Text <> "" Then
        If vsoCharacters.CharCount > 0 Then
            If InStr(1, vsoCharacters.Text, "[[[", vbTextCompare) Then
                For j = 1 To OPENIMS_Count
                    If Left(OPENIMS_Keys(j), 4) = "set_" Then ' set a value
                        key = LCase(Right(OPENIMS_Keys(j), Len(OPENIMS_Keys(j)) - 4))
                        If InStr(1, LCase(vsoCharacters.Text), "[[[" & key & "]]]", vbTextCompare) Then
                            'TTT vsoCharacters1.Text = Replace(vsoCharacters1.Text, "[[[Referentie]]]", "XXXXXX")
                            ' if there is no OPENIMS_ custom field, add it
                            If DoesOPENIMSpropertyExist(vsoShape) = "" Then
                                AddCustomfield vsoShape, "OPENIMS_" & key, OPENIMS_Values(j)
                            End If
                        End If
                    End If
                Next j
            End If
        End If
    Next i
    Next h
End Sub
 
Sub ProcessShapesWithOpenimsCustomFields()
    Dim vsoShape As Visio.Shape
    Dim vsoCharacters As Visio.Characters
    ' traverse all shapes
    ' look in every shape for the first OPENIMS_ custom field
    ' if found, fill custom field with value and replace text with reference to custom field
    Dim h As Integer, i As Integer, j As Integer, key As String, OPENIMS_property As String
 
    For h = 1 To Application.ActiveDocument.Pages.Count
        'For i = 1 To Application.ActiveWindow.Page.Shapes.Count
        For i = 1 To Application.ActiveDocument.Pages(h).Shapes.Count
            'Set vsoShape = Application.ActiveWindow.Page.Shapes.ItemFromID(i)
            Set vsoShape = Application.ActiveDocument.Pages(h).Shapes.ItemFromID(i)
            OPENIMS_property = DoesOPENIMSpropertyExist(vsoShape)
            If OPENIMS_property <> "" Then
                For j = 1 To OPENIMS_Count
                    If Left(OPENIMS_Keys(j), 4) = "set_" Then ' set a value
                        key = "OPENIMS_" & LCase(Right(OPENIMS_Keys(j), Len(OPENIMS_Keys(j)) - 4))
                        If key = OPENIMS_property Then
                            ' fill custom field with value
                            ModifyCustomfield vsoShape, OPENIMS_property, OPENIMS_Values(j)
                            ' fill text of shape with reference to custom field
                            Set vsoCharacters = vsoShape.Characters
                            vsoCharacters.AddCustomFieldU "Prop." & OPENIMS_property, visFmtNumGenNoUnits
                        End If
                    End If
                Next j
            End If
        Next i
    Next h
End Sub
 
Private Sub Document_DocumentOpened(ByVal doc As IVDocument)
    OPENIMS_OnLoad
End Sub


Public Sub HeaderFooter()
'Dim OldText As String
'Dim szFooter As String
'OldText = "[[[name]]]"

'ThisDocument.HeaderCenter = "Document Title" & OldText
''Build footer string
'szFooter = "version : [[[version]]]"
''Set footer of current document
''ThisDocument.FooterCenter = szFooter
'ThisDocument.FooterCenter = "Document Title " & OPENIMS_GetMeta("name")
End Sub