'------------------------------------------------------------------
' OpenIMS AutoCAD integration VBA.                  [Version 4.2.2]
' (c) 2001-2005 OpenSesame ICT, all rights reserved.
' See http://www.osict.com/openims/termsofuse.txt for more details.
'
' Implementation: Embed (!) into AutoCAD drawing
' Usage: Insert single line text object containing e.g. [[[version]]]
'        OR store the object in an attribute with the Enhanced Attribute Editor.
'        Fields and attributes can be disconnected by using !!! as value.
'------------------------------------------------------------------
 
' OPENIMS AutoCAD integration global variables
Dim OPENIMS_ActivateCounter
Dim OPENIMS_Count As Long
Dim OPENIMS_Keys() As String
Dim OPENIMS_Values() As String
Dim busybusy As Boolean
 
' Make sure OPENIMS_OnLoad is executed one time
Private Sub AcadDocument_Activate()
    OPENIMS_ActivateCounter = OPENIMS_ActivateCounter + 1
    If OPENIMS_ActivateCounter = 1 Then
        OPENIMS_OnLoad
    End If
End Sub
 
' Implement the metadata OpenIMS appended to the drawing file
' E.g. [[[version]]] is replaced by the appropriate "set_version"
Sub OPENIMS_OnLoad()
    Dim Key As String
    OPENIMS_ReadMeta
    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)
        End If
        If OPENIMS_Keys(I) = "exec_onload" Then ' execute custom VBA
            Eval (OPENIMS_Values(I))
        End If
    Next
    ThisDrawing.Regen acActiveViewport
End Sub
 
Function OPENIMS_MarkText(Text As String, ID As String) As Boolean
    OPENIMS_MarkText = OPENIMS_MarkTextObject(Text, ID) Or OPENIMS_MarkTextATTR(Text, ID)
End Function
 
' Mark a text object for future reference
Function OPENIMS_MarkTextObject(Text As String, ID As String) As Boolean
    Dim Object As Variant
    Dim Check As String
    Dim blkDef As AcadBlock
    OPENIMS_MarkTextObject = False
    For Each blkDef In ThisDrawing.Blocks
        For Each Object In blkDef
            On Error Resume Next
            Check = Object.TextString
            If LCase(Check) = LCase(Text) Then
                On Error GoTo 0
                Dim DataType(0 To 1) As Integer
                Dim Data(0 To 1) As Variant
                DataType(0) = 1001: Data(0) = "OpenIMS_ID_001"
                DataType(1) = 1000: Data(1) = ID
                Object.SetXData DataType, Data
                OPENIMS_MarkTextObject = True
            End If
        Next
    Next
End Function
 
' Mark an attribute for future reference
Function OPENIMS_MarkTextATTR(Text As String, ID As String) As Boolean
    Dim Obj As Object
    Dim Atts
    Dim blkDef As AcadBlock
    On Error Resume Next
    For Each blkDef In ThisDrawing.Blocks
        For Each Obj In blkDef
            If Obj.HasAttributes Then
                Atts = Obj.GetAttributes
                For a = LBound(Atts) To UBound(Atts)
                    Dim aar As AutoCAD.AcadAttributeReference
                    Set aar = Atts(a)
                    txt = ""
                    txt = aar.TextString
                    If txt = Text Then
                        On Error GoTo 0
                        Dim DataType(0 To 1) As Integer
                        Dim Data(0 To 1) As Variant
                        DataType(0) = 1001: Data(0) = "OpenIMS_ID_001"
                        DataType(1) = 1000: Data(1) = ID
                        aar.SetXData DataType, Data
                        On Error Resume Next
                        OPENIMS_MarkTextATTR = True
                    End If
                Next
            End If
        Next
    Next
    On Error GoTo 0
End Function
 
Function OPENIMS_SetText(ID As String, Text As String) As Boolean
  OPENIMS_SetText = OPENIMS_SetTextObject(ID, Text) Or OPENIMS_SetTextATTR(ID, Text)
End Function
 
' Change the content of a marked text object
Function OPENIMS_SetTextObject(ID As String, Text As String) As Boolean
    Dim DataType, Data As Variant
    Dim Check As String
    Dim blkDef As AcadBlock
    OPENIMS_SetTextObject = False
    On Error Resume Next
    For Each blkDef In ThisDrawing.Blocks
        For Each Object In blkDef
            On Error Resume Next
            Object.GetXData "OpenIMS_ID_001", DataType, Data
            Check = ""
            Check = Data(1)
            If Check = ID Then
                Object.TextString = Text & " "
                DataType(0) = 1001: Data(0) = "OpenIMS_VALUE_001"
                DataType(1) = 1000: Data(1) = Text & " "
                Object.SetXData DataType, Data
                OPENIMS_SetTextObject = True
            End If
            On Error GoTo 0
        Next
    Next
End Function
 
' Change the content of a marked attribute
Function OPENIMS_SetTextATTR(ID As String, Text As String) As Boolean
    Dim Obj As Object
    Dim Atts
    Dim blkDef As AcadBlock
    On Error Resume Next
    
    For Each blkDef In ThisDrawing.Blocks
        For Each Obj In blkDef
            If Obj.HasAttributes Then
                Atts = Obj.GetAttributes
                For a = LBound(Atts) To UBound(Atts)
                    Dim aar As AutoCAD.AcadAttributeReference
                    Set aar = Atts(a)
                    On Error Resume Next
                    aar.GetXData "OpenIMS_ID_001", DataType, Data
                    Check = ""
                    Check = Data(1)
                    On Error GoTo 0
                    If Check = ID Then
                        aar.TextString = Text & " "
                        DataType(0) = 1001: Data(0) = "OpenIMS_VALUE_001"
                        DataType(1) = 1000: Data(1) = Text & " "
                        aar.SetXData DataType, Data
                        OPENIMS_SetTextATTR = True
                    End If
                    On Error Resume Next
                Next
            End If
        Next
    Next
    On Error GoTo 0
End Function
 
Function OPENIMS_GetMyFullFilename() As String
    OPENIMS_GetMyFullFilename = _
      ThisDrawing.Application.ActiveDocument.Path & Chr(92) & _
      ThisDrawing.Application.ActiveDocument.Name
End Function
 
Function OPENIMS_GetMyFileSize() As Long
    OPENIMS_GetMyFileSize = FileLen(OPENIMS_GetMyFullFilename())
End Function
 
' Extract part of the current drawing 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
 
' Read and parse the metadata OpenIMS appended to the drawing 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
        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
    End If
End Sub
 
Private Sub AcadDocument_EndCommand(ByVal CommandName As String)
    Dim error As String
    If (Not busybusy) Then
        busybusy = True
        If (CommandName = "EATTEDIT" Or CommandName = "DDEDIT") Then
            Dim DataType, Data As Variant
            Dim blkDef As AcadBlock
            On Error Resume Next
            For Each blkDef In ThisDrawing.Blocks
                For Each Object In blkDef
                    On Error Resume Next
                    Object.GetXData "OpenIMS_VALUE_001", DataType, Data
                    Check = ""
                    Check = Data(1)
                    If Check <> "" Then
                        ts = ""
                        ts = Object.TextString
                        If Trim(ts) = "!!!" Then
                            Object.GetXData "OpenIMS_ID_001", DataType, Data
                            ID = ""
                            ID = Data(1)
                            error = error & "OpenIMS controlled field [[[" & ID & "]]] has been disconnected" & vbCrLf
                            DataType(0) = 1001: Data(0) = "OpenIMS_ID_001"
                            DataType(1) = 1000: Data(1) = ""
                            Object.SetXData DataType, Data
                            DataType(0) = 1001: Data(0) = "OpenIMS_VALUE_001"
                            DataType(1) = 1000: Data(1) = ""
                            Object.SetXData DataType, Data
                        ElseIf ts <> Check Then
                            Object.GetXData "OpenIMS_ID_001", DataType, Data
                            ID = ""
                            ID = Data(1)
                            Object.TextString = Check
                            ts = ""
                            ts = Object.TextString
                            If (ts = Check) Then error = error & "OpenIMS controlled field [[[" & ID & "]]] has been restored to " & Check & vbCrLf
                        End If
                    End If
                    On Error Resume Next
                    If Object.HasAttributes Then
                        Atts = Object.GetAttributes
                        For a = LBound(Atts) To UBound(Atts)
                            Dim aar As AutoCAD.AcadAttributeReference
                            Set aar = Atts(a)
                            On Error Resume Next
                            aar.GetXData "OpenIMS_VALUE_001", DataType, Data
                            Check = ""
                            Check = Data(1)
                            If Check <> "" Then
                                ts = ""
                                ts = aar.TextString
                                If Trim(ts) = "!!!" Then
                                    aar.GetXData "OpenIMS_ID_001", DataType, Data
                                    ID = ""
                                    ID = Data(1)
                                    error = error & "OpenIMS controlled field [[[" & ID & "]]] has been disconnected" & vbCrLf
                                    DataType(0) = 1001: Data(0) = "OpenIMS_ID_001"
                                    DataType(1) = 1000: Data(1) = ""
                                    aar.SetXData DataType, Data
                                    DataType(0) = 1001: Data(0) = "OpenIMS_VALUE_001"
                                    DataType(1) = 1000: Data(1) = ""
                                    aar.SetXData DataType, Data
                                ElseIf ts <> Check Then
                                    aar.GetXData "OpenIMS_ID_001", DataType, Data
                                    ID = ""
                                    ID = Data(1)
                                    aar.TextString = Check
                                    ts = ""
                                    ts = aar.TextString
                                    If (ts = Check) Then error = error & "OpenIMS controlled field [[[" & ID & "]]] has been restored to " & Check & vbCrLf
                                End If
                            End If
                            On Error Resume Next
                        Next
                    End If
                Next
            Next
        End If
        busybusy = False
    End If
    If (error <> "") Then MsgBox (error)
End Sub
 
Sub test()
    OPENIMS_MarkText "[[[1]]]", "1"
    OPENIMS_MarkText "[[[2]]]", "2"
    OPENIMS_MarkText "[[[3]]]", "3"
    OPENIMS_MarkText "[[[4]]]", "4"
    OPENIMS_MarkText "[[[5]]]", "5"
    OPENIMS_MarkText "[[[6]]]", "6"
    OPENIMS_SetText "1", "een"
    OPENIMS_SetText "2", "twee"
    OPENIMS_SetText "3", "drie"
    OPENIMS_SetText "4", "vier"
    OPENIMS_SetText "5", "vijf"
    OPENIMS_SetText "6", "zes"
End Sub