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 [[[<<>>]]], and add if necessary OPENIMS_<<>> custom field
FindBracketsAndAddCustomField
' find OPENIMS_<<>> 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 [[[<<>>]]]
' if it exists, and there is no OPENIMS_ custom field then add OPENIMS_<<>> 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