Type support
    ID As String
    TYP As Long
    MAXGAP As Double
    MINGAP As Double
    MAXPLATE As Double
    MINPLATE As Double
End Type

Sub block_prefix()
    Dim Name As String
    Dim PREFIX As String
    PREFIX = REPLACE(thisdrawing.Name, ".dwg", "")
    PREFIX = REPLACE(PREFIX, "T", "TYP_") & "-"
    'debug.print  PREFIX
    Dim blockref As AcadBlockReference
    Dim Block As AcadBlock
    Dim entity As AcadEntity
    For Each entity In thisdrawing.modelspace
        If LCASE(entity.objectname) = "acdbblockreference" Then
            Set blockref = entity
            'debug.print  PREFIX & BLOCKREF.effectivename
            For Each Block In thisdrawing.BLOCKS
                If Block.Name = blockref.effectivename Then
                    'debug.print  BLOCK.name
                    If InStr(Block.Name, PREFIX) = 0 Then
                        Block.Name = PREFIX & Block.Name
                    End If
                End If
            Next
        End If
    Next
End Sub



Sub block_SUFFIX_all()
    Dim Name As String
    Dim PREFIX As String
    Dim blockref As AcadBlockReference
    Dim Block As AcadBlock
    Dim entity As AcadEntity
    Dim SUFFIX As String
    SUFFIX = "_VA2"
    For Each Block In thisdrawing.BLOCKS
        If InStr(LCASE(Block.Name), "space") = 0 Then
            If InStr(Block.Name, SUFFIX) = 0 Then
                On Error Resume Next
                If InStr(Block.Name, "*") = 0 Then Block.Name = Block.Name & SUFFIX
            End If
        End If
    Next
End Sub


Sub block_remove_SUFFIX_all()
    Dim Name As String
    Dim PREFIX As String
    Dim blockref As AcadBlockReference
    Dim Block As AcadBlock
    Dim entity As AcadEntity
    Dim SUFFIX As String
    SUFFIX = "_voistalpine"
    For Each Block In thisdrawing.BLOCKS
        If InStr(LCASE(Block.Name), "space") = 0 Then
            If InStr(Block.Name, SUFFIX) > 0 Then
                If InStr(Block.Name, "*") = 0 Then
                    On Error Resume Next
                    Block.Name = REPLACE(Block.Name, SUFFIX, "")
                End If
            End If
        End If
    Next
End Sub

Sub prefix_layer()
    Dim LAYER As AcadLayer
    PREFIX = "zzz_"
    For Each LAYER In thisdrawing.LAYERS
        If LAYER.Name = "0" Or LAYER.Name = "Defpoints" Then GoTo weiter

        If InStr(LAYER.Name, PREFIX) = 0 Then
            On Error Resume Next
            LAYER.Name = PREFIX & LAYER.Name
        End If
weiter:

    Next
End Sub

Sub entlayerstoSUFFIX()

    Dim entity As AcadEntity
    Dim Block As AcadBlock
    For Each Block In thisdrawing.BLOCKS
        For Each entity In Block
            On Error Resume Next
            If InStr(entity.LAYER, "zzz_") = 0 Then entity.LAYER = "zzz_" & entity.LAYER
        Next
    Next
End Sub
Sub saveall()
    Dim DRAWING As AcadDocument
    For Each DRAWING In APPLICATION.documents
        'debug.print  DRAWING.name
        DRAWING.SAVE
    Next
End Sub
Sub CLEANTMP()
    On Error Resume Next
    Call layer_clone("TMP", "DefPOINTs")
    Call layer_clone("TMP", "0")

    Call DEL_ENTITYS_ON_LAYER("TMP")
    On Error GoTo 0
End Sub
Sub Block_explode_with_attributes()



    Dim entity As AcadEntity
    Dim BLO As AcadBlockReference
    Dim blo2 As AcadBlockReference

    Dim globalselectionset As AcadSelectionSet
    Set globalselectionset = Selection_set_by_layer("VBA_PLATE")
    Dim Point As Point3d
    Dim ROLE As String
    Dim ID As String
    Dim TYP As String
    Dim p
    Dim V
    Call CLEANTMP

    thisdrawing.SetVariable "DELOBJ", 0
    Call layer_clone("VBA_PLATE_SCREW", "0")
    Call layer_clone("VBA_PLATE_BOLT", "0")
    Call layer_clone("TMP", "0")


    For Each entity In thisdrawing.modelspace
        '        If entity.layer = "EXTRAPOLATION" Then entity.Delete
        If entity.LAYER = "VBA_PLATE_BOLT" Then entity.DELETE
        If entity.LAYER = "VBA_PLATE_SCREW" Then entity.DELETE


    Next


    For Each entity In thisdrawing.modelspace

        If LCASE(entity.objectname) = "acdbblockreference" Then
            Set BLO = entity
            If BLO.LAYER = "Defpoints" Then GoTo further
            If block_get_attribute(BLO, "ROLE") = "SYMBOL_PLATE" Then
                APPLICATION.update
                ROLE = block_get_attribute(BLO, "ROLE")
                ID = block_get_attribute(BLO, "ID")
                V = ""
                BLO.xeffectivescalefactor = 1
                BLO.yeffectivescalefactor = 1
                BLO.yeffectivescalefactor = 1
                If block_get_parameter(V, BLO, "TYP") Then

                    TYP = V


                End If


                'Call Layer_clone("VBA_PLATE_SCREW", "0")

                If TYP <> "" Then

                    Dim blo3 As AcadBlockReference

                    Dim entity2 As AcadEntity
                    Dim explodedObjects As Variant
                    Dim Name As String

                    BLO.COLOR = acGreen
                    p = BLO.insertionPoint
                    p(0) = ROUND(p(0), 3)
                    p(1) = ROUND(p(1), 3)
                    BLO.insertionPoint = p
                    BLO.update
                    explodedObjects = BLO.EXPLODE

                    ' Loop through the exploded objects
                    Dim i As Integer
                    V = 0
                    For i = 0 To UBound(explodedObjects)

                        Set entity2 = explodedObjects(i)
                        entity2.LAYER = "TMP"
                        If LCASE(entity2.objectname) = "acdbblockreference" Then

                            Set blo2 = entity2
                            NR = block_get_attribute(blo2, "NR")
                            subname = blo2.effectivename
                            p = blo2.insertionPoint

                            '                            P(0) = Round(P(0), 3)
                            '                            P(1) = Round(P(1), 3)


                            blo2.insertionPoint = p
                            Name = blo2.effectivename
                            Call block_set_attribute(blo2, "ID", ID)
                            Call block_set_attribute(blo2, "ROLE", ROLE)
                            Call block_set_attribute(blo2, "TYP", TYP)


                            If Name = "BOLT" Then



                                NR = block_get_attribute(blo2, "NR")


                                Set blo3 = DBGBALL(p, ID, True, "VBA_PLATE_SCREW")

                                If InStr(NR, "SM") > 0 Then
                                    blo3.LAYER = "VBA_PLATE_BOLT"
                                Else
                                    blo3.LAYER = "VBA_PLATE_SCREW"
                                End If
                                blo3.xeffectivescalefactor = 0.001
                                blo3.yeffectivescalefactor = 0.001
                                blo3.yeffectivescalefactor = 0.001

                                Call block_set_attribute(blo3, "ID", ID)
                                Call block_set_attribute(blo3, "TYP", TYP)
                                Call block_set_attribute(blo3, "NR", NR)

                                Call block_set_attribute(blo3, "ROLE", "SCREW")
                                Call block_set_parameter(blo3, "Position X", V)
                                Call block_set_parameter(blo3, "Position Y", V)
                                blo3.COLOR = acByLayer
                                blo3.update
                            Else
                                blo2.COLOR = acByLayer
                                blo2.LAYER = "VBA_PLATE_DELTA"
                                Call block_set_parameter(blo2, "Position X", V)
                                Call block_set_parameter(blo2, "Position Y", V)
                                Call block_set_attribute(blo2, "ID", ID)
                                Call block_set_attribute(blo2, "TYP", TYP)

                                blo2.xeffectivescalefactor = 0.001
                                blo2.yeffectivescalefactor = 0.001
                                blo2.yeffectivescalefactor = 0.001
                                blo2.insertionPoint(0) = p(0)
                                blo2.insertionPoint(1) = p(1)
                                If subname = STDBLOCK Then blo2.ROTATION = 0
                                blo2.update

                                blo2.COLOR = acByLayer

                            End If
                            If InStr(" BOLT 3D-BALL ", Name) = 0 Then entity2.LAYER = "TMP"
                            If InStr(Name, "schrott") > 0 Then entity2.LAYER = "TMP"

                        Else
                            entity2.COLOR = acByLayer
                            entity2.LAYER = "TMP"
                        End If


                    Next




                End If
            End If
        End If
        '  entity.color = acByLayer
further:
    Next
    Call CLEANTMP
End Sub



Sub BLOCK_CLONE(ByVal selectionsetobject, opt)
    Dim BNAME As String
    Dim p(2) As Double
    Dim ANGLE As Double
    Dim entity As AcadEntity
    Dim blockref As AcadBlockReference
    Dim BLOCKREF2 As AcadBlockReference
    Dim PIAPDICT As New DICTIONARY_VBA
    Dim Distance As Variant
    Dim PositionX As Variant
    Dim Positiony As Variant

    Dim SOURCE As AcadBlockReference
    Dim DEST As AcadBlockReference
    Dim n As Long

    Dim PARA As New DICTIONARY_VBA
    Dim PROP As New DICTIONARY_VBA
    Dim attr As New DICTIONARY_VBA
    APPLICATION.update
    Dim ALL As Boolean
    ALL = False
    If InStr(opt, "ALL") > 0 Then ALL = True
    n = 0

    For Each entity In selectionsetobject

        If LCASE(entity.objectname) = "acdbblockreference" Then

            If n = 0 Then
                Set SOURCE = entity

                If InStr(opt, "PARAMETER") > 0 Then Call block_PARAMETER_to_dictionary(SOURCE, PARA, ALL)
                If InStr(opt, "PROPERTY") > 0 Then Call block_PROPERTYS_to_dictionary(SOURCE, PROP)
                If InStr(opt, "ATTRIBUTE") > 0 Then Call block_ATTRIBUTE_to_dictionary(SOURCE, attr)


            Else
                Set DEST = entity

                If InStr(opt, "PARAMETER") > 0 Then Call block_PARAMETER_from_dictionary(DEST, PARA, ALL)
                If InStr(opt, "PROPERTY") > 0 Then Call block_PROPERTYS_from_dictionary(DEST, PROP)
                If InStr(opt, "ATTRIBUTE") > 0 Then Call block_ATTRIBUTE_from_dictionary(DEST, attr)


            End If


            n = n + 1
        End If
    Next


    


End Sub




Sub BLOCK_CLONE_REPLACE(ByVal selectionsetobject, opt)
    Dim BNAME As String
    Dim p(2) As Double
    Dim ANGLE As Double
    Dim entity As AcadEntity
    Dim blockref As AcadBlockReference
    Dim BLOCKREF2 As AcadBlockReference
    Dim PIAPDICT As New DICTIONARY_VBA
    Dim Distance As Variant
    Dim PositionX As Variant
    Dim Positiony As Variant

    Dim SOURCE As AcadBlockReference
    Dim DEST As AcadBlockReference
    Dim n As Long

    Dim PARA As New DICTIONARY_VBA
    Dim PROP As New DICTIONARY_VBA
    Dim attr As New DICTIONARY_VBA
    APPLICATION.update

    Call layer_clone("TMP", "0")
    sBlockName = InputBox("BLOCK NAME NEW", "BLOCK NEW", "*")
    If sBlockName = "*" Then
        Set entity = get_entity("PICK NEW BLOCK", "acddbblockreference")
        If entity Is Nothing Then Exit Sub
        Set blockref = entity
        sBlockName = blockref.effectivename
    End If
    

    If sBlockName = "" Then Exit Sub

    Dim REPPROP As Boolean
    Dim REPATTR As Boolean
    Dim REPPARA As Boolean

    REPPROP = SLOPEFORM.REPPROP
    REPATTR = SLOPEFORM.REPATTR
    REPPARA = SLOPEFORM.REPPARA


    Dim ALL As Boolean
    ALL = True
    For Each entity In selectionsetobject

        If LCASE(entity.objectname) = "acdbblockreference" Then

            ERR.Clear

            Set SOURCE = entity
            If REPPROP Then Call block_PROPERTYS_to_dictionary(SOURCE, PROP)
            If REPATTR Then Call block_ATTRIBUTE_to_dictionary(SOURCE, attr)
            If REPPARA Then Call block_PARAMETER_to_dictionary(SOURCE, PARA, ALL)

            p(0) = SOURCE.insertionPoint(0)
            p(1) = SOURCE.insertionPoint(1)
            p(2) = SOURCE.insertionPoint(2)


            Set DEST = block_insert(p, sBlockName, SOURCE.xscalefactor, SOURCE.xscalefactor, SOURCE.zscalefactor, SOURCE.ROTATION)


            If REPPROP Then Call block_PROPERTYS_from_dictionary(DEST, PROP)
            If REPATTR Then Call block_ATTRIBUTE_from_dictionary(DEST, attr)
            If REPPARA Then Call block_PARAMETER_from_dictionary(DEST, PARA, ALL)



            dwgunits = S2D(thisdrawing.GetVariable("INSUNITS"))
            bu = DEST.Insunits
            If bu <> dwgunits Then
                Dim SC As Double
                If dwgunits = 6 And bu = "Millimeter" Then SC = 0.001    'dwg meter, blo mm
                If dwgunits = 4 And bu = "Meter" Then SC = 1000    'dwg mm ,blo meter

                If SC <> 0 Then
                
                    DEST.ScaleEntity DEST.insertionPoint, SC
                
                End If
            End If


            PARA.RemoveAll
            PROP.RemoveAll
            attr.RemoveAll
            If ERR.Number = 0 Then
                Dim LAYER As AcadLayer
                Set LAYER = thisdrawing.LAYERS(SOURCE.LAYER)
                LAYER.Lock = False


                SOURCE.LAYER = "TMP"
            End If

            n = n + 1
        End If
    Next




End Sub
Function block_ATTRIBUTE_from_dictionary(entity As AcadEntity, dict As DICTIONARY_VBA, Optional PREFIX As String = "ATTR_", Optional nopadding As Boolean = False, Optional codemode As Boolean = False) As Boolean
    Dim BLO As AcadBlockReference
    On Error Resume Next
    If LCASE(entity.objectname) <> "acdbblockreference" Then
        On Error GoTo 0
        Exit Function
    End If
    Set BLO = entity
    Dim ATTLIST As Variant
    ERR.Clear
    block_ATTRIBUTE_from_dictionary = True
    Dim tagname As String
    Dim tagvalue As String
    Dim tagprompt As String
    Dim tagpreset As String
    Dim ATTRIB As Object    'AcadAttribute
    Dim DICT_TAGNAME As String
    Dim NP As Boolean
    On Error Resume Next
    'If blo Is Nothing Then Exit Function
    If BLO.hasattributes Then
        ATTLIST = BLO.GetAttributes
        For i = LBound(ATTLIST) To UBound(ATTLIST)
            'Set attrib = attlist(i)
            tagname = Trim(ATTLIST(i).TAGSTRING)
            If InStr(tagname, "__") = 0 Then
                tagvalue = ATTLIST(i).TEXTSTRING
                If right(tagname, 4) = "_001" Then tagname = left(tagname, Len(tagname) - 4)
                DICT_TAGNAME = PREFIX & tagname
                If dict.Exists(DICT_TAGNAME) Then tagvalue = dict.ITEM(DICT_TAGNAME)
                NP = nopadding
                If codemode Then
                    If left(tagvalue, 1) = "=" Then NP = False
                End If
                If NP = True Then tagvalue = REPLACE(tagvalue, Chr(34), "")
                
                
                ATTLIST(i).TEXTSTRING = tagvalue
                If ERR.Number <> 0 Then bblock_attribute_from_dictionary = False
            End If
        Next
    End If
    If ERR.Number <> 0 Then block_ATTRIBUTE_from_dictionary = False
End Function

Function block_ATTRIBUTE_to_dictionary(entity As AcadEntity, dict As DICTIONARY_VBA, Optional PREFIX As String = "ATTR_", Optional padding As Boolean = False, Optional codemode As Boolean = True) As Boolean

    Dim BLO As AcadBlockReference
    If LCASE(entity.objectname) <> "acdbblockreference" Then Exit Function
    Set BLO = entity
    Dim ATTLIST As Variant
    ERR.Clear
    block_ATTRIBUTE_to_dictionary = True
    Dim tagname As String
    Dim tagvalue As String
    Dim tagprompt As String
    Dim tagpreset As String
    Dim ATTRIB As AcadAttribute
    Dim DICT_TAGNAME As String
    Dim TV As String
 
    If codemode = False Then
        If padding Then tagvalue = Chr(34) & tagvalue & Chr(34)
    Else
    
        If Not left(tagvalue, 1) = "=" Then
            If padding Then tagvalue = Chr(34) & tagvalue & Chr(34)
        End If
    
    End If
    
    On Error Resume Next
    'If blo Is Nothing Then Exit Function
    If BLO.hasattributes Then
        ATTLIST = BLO.GetAttributes
        For i = LBound(ATTLIST) To UBound(ATTLIST)
            ' attrib = attlist(i)
            tagname = Trim(ATTLIST(i).TAGSTRING)
            tagvalue = Trim(ATTLIST(i).TEXTSTRING)
            '            On Error Resume Next
            '            tagprompt = Trim(attrib.PromptString)
            '            tagpreset = Trim(attrib.Preset)
            '            On Error GoTo 0
            If right(tagname, 4) = "_001" Then tagname = left(tagname, Len(tagname) - 4)
            
            DICT_TAGNAME = PREFIX & tagname
            
            If UCase(tagname) = tagname Then
                If dict.Exists(DICT_TAGNAME) Then
                    dict.ITEM(DICT_TAGNAME) = Trim(tagvalue)
                Else
                    dict.Add DICT_TAGNAME, tagvalue
                End If
            End If
            If ERR.Number <> 0 Then block_ATTRIBUTE_to_dictionary = False
        Next
    End If

    '    DICT_SET dict, "CP_X", str(blo.insertionPoint(0))
    '    DICT_SET dict, "CP_Y", str(blo.insertionPoint(1))
    '    DICT_SET dict, "CP_Z", str(blo.insertionPoint(2))
    '    DICT_SET dict, "CP_A", str(blo.rotation / PI * 180)
    '    DICT_SET dict, "BLOCKNAME", blo.name
    If ERR.Number <> 0 Then block_ATTRIBUTE_to_dictionary = False

End Function

Sub block_clone_parameters(ByRef blockref As AcadBlockReference, ByRef BLOCKREF2 As AcadBlockReference)
    Dim V As Variant

    Dim DYNPROP, dynprop2 As AcadDynamicBlockReferenceProperty
    Dim Variable, variable2 As Variant

    If blockref.effectivename <> BLOCKREF2.effectivename Then Exit Sub
    If Not blockref.isdynamicblock Then Exit Sub
    If Not BLOCKREF2.isdynamicblock Then Exit Sub


    Variable = blockref.GetDynamicBlockProperties
    variable2 = BLOCKREF2.GetDynamicBlockProperties

    For K = LBound(Variable) To UBound(Variable)
        Set DYNPROP = Variable(K)
        V = DYNPROP.value
        For L = LBound(variable2) To UBound(variable2)
            Set dynprop2 = variable2(L)
            If DynProp1.propertyName = dynprop2.propertyName Then
                Set dynprop2.value = DynProp1.value
            End If
        Next
    Next


End Sub

Sub block_copy_parameters(ByRef blockref As AcadBlockReference, ByRef BLOCKREF2 As AcadBlockReference)
    Dim V As Variant



    Dim DYNPROP, dynprop2 As AcadDynamicBlockReferenceProperty
    Dim Variable, variable2 As Variant


    Variable = blockref.GetDynamicBlockProperties
    variable2 = BLOCKREF2.GetDynamicBlockProperties
    If blockref.effectivename = BLOCKREF2.effectivename Then
        For K = LBound(Variable) To UBound(Variable)
            Set DYNPROP = Variable(K)
            If InStr("LENGTH WIDTH TYPE", UCase(DYNPROP.propertyName)) > 0 Then
                Set dynprop2 = variable2(K)
                ''debug.print
                V = DYNPROP.value
                If InStr(TypeName(V), ")") = 0 Then
                    dynprop2.value = V
                End If
            End If
        Next

    Else
        For K = LBound(Variable) To UBound(Variable)
            Set DYNPROP = Variable(K)
            If InStr("LENGTH WIDTH TYPE", UCase(DYNPROP.propertyName)) > 0 Then
                V = DYNPROP.value
                If InStr(TypeName(V), ")") = 0 Then
                    ' dynprop2.value = v
                    Call block_set_parameter(BLOCKREF2, DYNPROP.propertyName, V)
                End If
            End If
        Next


    End If
End Sub

Function block_get_attribute(BLO As AcadBlockReference, tagname, Optional found As Boolean = False) As String
    Dim ATTLIST As Variant
    On Error Resume Next
    If BLO.hasattributes Then
        ATTLIST = BLO.GetAttributes
        
        For i = LBound(ATTLIST) To UBound(ATTLIST)
        
            If UCase(ATTLIST(i).TAGSTRING) = tagname Or UCase(Trim(ATTLIST(i).TAGSTRING)) = tagname & "_001" Then
                block_get_attribute = ATTLIST(i).TEXTSTRING
                found = True
                Exit Function

            End If
        Next
    End If
End Function

Function block_get_parameter(ByRef V As Variant, blockref As AcadBlockReference, ByVal Name As String, Optional ucaseName As Boolean = True) As Boolean

    Dim DYNPROP As AcadDynamicBlockReferenceProperty
    Dim Variable As Variant
    Dim PROPNAME As String
    Dim TEMP As String
    If ucaseName Then Name = UCase(Name)
    block_get_parameter = False
    If blockref Is Nothing Then Exit Function
    If blockref.isdynamicblock Then
        Variable = blockref.GetDynamicBlockProperties

        For K = LBound(Variable) To UBound(Variable)
            Set DYNPROP = Variable(K)
            PROPNAME = DYNPROP.propertyName
            If ucaseName Then PROPNAME = UCase(PROPNAME)
            If PROPNAME = Name Then
                block_get_parameter = True
                V = DYNPROP.value
                Exit For
            End If
        Next
    End If
End Function

Function block_has_attribute(BLO As AcadBlockReference, tagname As String) As Boolean
    Dim ATTLIST As Variant
    On Error Resume Next
    block_has_attribute = False
    If BLO.hasattributes Then
        ATTLIST = BLO.GetAttributes
        For i = LBound(ATTLIST) To UBound(ATTLIST)
            If UCase(ATTLIST(i).TAGSTRING) = tagname Or UCase(Trim(ATTLIST(i).TAGSTRING)) = tagname & "_001" Then
                block_has_attribute = True
                Exit Function
            End If
        Next
    End If
End Function

Function block_has_parameter(blockref As AcadBlockReference, ByVal Name As String) As Boolean
    If blockref Is Nothing Then Exit Function
    block_has_parameter = False
    Dim DYNPROP As AcadDynamicBlockReferenceProperty
    Dim Variable As Variant
    Name = UCase(Name)
    If blockref Is Nothing Then Exit Function
    Variable = blockref.GetDynamicBlockProperties
    For K = LBound(Variable) To UBound(Variable)
        Set DYNPROP = Variable(K)                        'Check for variable and when found ask for input
        If UCase(DYNPROP.propertyName) = Name Then
            block_has_parameter = True
            Exit Function
        End If
    Next
End Function

Function block_PARAMETER_from_dictionary(entity As AcadEntity, dict As DICTIONARY_VBA, Optional ALL As Boolean = False, Optional roundthem As Long = -1, Optional nospaces As Boolean = False) As Boolean

    Dim blockref As AcadBlockReference
    Dim DYNPROP As AcadDynamicBlockReferenceProperty
    Dim Variable As Variant
    Dim V As Variant
    Dim v2 As Variant
    
    Dim proptagname As String
    Dim proptagvalue As String
    Dim proptagunits As String
    Dim proptagdescription As String
    Dim CACHE As DICTIONARY_VBA
    
    
    Set CACHE = New DICTIONARY_VBA
    
    
    Call block_PARAMETER_to_dictionary(entity, CACHE, ALL, nospaces)
    
    Dim K As Long
    Dim VT As typeofVar
    block_PARAMETER_from_dictionary = False
    On Error Resume Next
    If LCASE(entity.objectname) <> "acdbblockreference" Then
        On Error GoTo 0
        Exit Function
    End If

    Set blockref = entity
    On Error Resume Next

    block_PARAMETER_from_dictionary = True

    If Not blockref.isdynamicblock Then
        On Error GoTo 0
        Exit Function
    End If
    
    
    
    ERR.Clear
    Variable = blockref.GetDynamicBlockProperties

    For K = LBound(Variable) To UBound(Variable)
        Set DYNPROP = Variable(K)


        proptagname = Trim(DYNPROP.propertyName)
        
        If ALL = False Then proptagname = UCase(proptagname)

        If DYNPROP.propertyName = proptagname Then
            proptagunits = DYNPROP.UnitsType
            proptagdescription = DYNPROP.DESCRIPTION

            V = DYNPROP.value

            DICT_TAGNAME = "PARA_" & proptagname
            
            If nospaces Then
                DICT_TAGNAME = REPLACE(DICT_TAGNAME, " ", "__")
            End If
            
            On Error GoTo 0
            If dict.Exists(CStr(DICT_TAGNAME)) Then
                dictvalue = dict.ITEM(CStr(DICT_TAGNAME))
                
                If CACHE.Exists(CStr(DICT_TAGNAME)) Then
                    testValue = CACHE.ITEM(CStr(DICT_TAGNAME))
                    If roundthem > -1 Then
                        testValue = REPLACE(testValue, ",", ".")
                        If IsNumeric(testValue) = True Then
                            TVALUE = val(testValue)
                            TVALUE = ROUND(TVALUE, Abs(roundthem))
                            testValue = Trim(STR(value))
                        End If
                    End If
                End If
                
                
                If roundthem > -1 Then
                    dictvalue = REPLACE(dictvalue, ",", ".")
                    If IsNumeric(dictvalue) = True Then
                        value = val(dictvalue)
                        value = ROUND(value, Abs(roundthem))
                        dictvalue = Trim(STR(value))
                    End If
                End If

                Call prepare_variant(V, dictvalue)
                v2 = V
                Call prepare_variant(v2, testValue)
                    

                On Error Resume Next
                If V <> v2 Then
                DYNPROP.value = V
                End If
                If ERR.Number <> 0 Then
                'debug.print  err.DESCRIPTION
                block_PARAMETER_from_dictionary = False
                End If
            End If

        End If
    Next

End Function
Sub prepare_variant(V, dictvalue)
    Dim VARTYP
    VARTYP = VarType(V)
    If VARTYP < vbArray Then
        Select Case VARTYP

            Case vbEmpty    '0
                V = ""
            Case vbNull  '1
                V = ""
                '            Case vbInteger    '2
                '                tagvalue = Trim(str(V))
                '            Case vbLong    '3
                '                tagvalue = Trim(str(V))
                '            Case vbSingle    '4
                '                tagvalue = Trim(str(V))
                '            Case vbDouble  '5
                '                tagvalue = Trim(str(V))
                '            Case vbCurrency  '6
                '                tagvalue = Trim(str(V))
            Case vbDate  '7
                V = Trim(dictvalue)
            Case vbString  '8
                V = Trim(dictvalue)
            Case vbObject    '9
                V = ""
            Case vbError    '10
                V = ""
            Case vbBoolean    '11
                If V = "TRUE" Then V = True Else V = False
            Case vbVariant    '12
                V = ""
            Case vbDataObject    '13
                V = ""
                '            Case vbDecimal    '14
                '                tagvalue = Trim(str(V))
                '            Case vbByte    '15
                '                tagvalue = Trim(str(V))
            Case Else
                V = val(dictvalue)
        End Select
                        
    End If
                        
                        
         
End Sub



Function block_PARAMETER_to_dictionary(entity As AcadEntity, dict As DICTIONARY_VBA, Optional ALL As Boolean = False, Optional nospaces As Boolean = False) As Boolean
    block_PARAMETER_to_dictionary = False
    Dim blockref As AcadBlockReference
    If LCASE(entity.objectname) <> "acdbblockreference" Then Exit Function
    Set blockref = entity
    If dict Is Nothing Then Exit Function
    ERR.Clear
    block_PARAMETER_to_dictionary = True
    Dim VS As String
    Dim DYNPROP As AcadDynamicBlockReferenceProperty
    Dim Variable() As Object
    Dim V As Variant
    Dim proptagname As String
    Dim proptagvalue As String
    Dim proptagunits As String
    Dim proptagdescription As String
    Dim DICT_TAGNAME As String
    Dim K As Long
    Dim VT As typeofVar
    Dim arr As Variant
    Dim LASTPROPNAME As String
    If Not blockref.isdynamicblock Then Exit Function
    
    Variable = blockref.GetDynamicBlockProperties
    
    Dim ARRAYSTRING As String
    Dim ARRAYNAME As String
    dict.RemoveAll
    
    
    
    For K = UBound(Variable) To LBound(Variable) Step -1
        On Error GoTo 0
        'Err.Clear
        
        ARRAYNAME = ""
        ARRAYSTRING = ""
        
        Set DYNPROP = Variable(K)
        
        proptagname = Trim(DYNPROP.propertyName)
        
        proptagunits = DYNPROP.UnitsType
        
        proptagdescription = DYNPROP.DESCRIPTION
        
        VT = VarType(DYNPROP.value)
        
        
        ''debug.print  proptagname
        
        If proptagname <> "Origin" Then
            DICT_TAGNAME = "PARA_" & proptagname
            If nospaces Then DICT_TAGNAME = REPLACE(DICT_TAGNAME, " ", "__")
        End If
        
        If Len(ERR.DESCRIPTION) > 0 Then
            ''debug.print  "ERROR HEAD", proptagname, Err.DESCRIPTION
        End If

        If ALL = False Then proptagname = UCase(proptagname)

        If DYNPROP.propertyName = proptagname Then
        'ARRAY OR NOT
            If VarType(DYNPROP.value) < vbArray Then

        
                If ARRAYNAME <> "" Then
                    ARRAYNAME = "ARRAY_" & proptagname & "|" & ARRAYNAME
                    ''debug.print  ARRAYNAMe
                    If dict.Exists(ARRAYNAME) Then
                        If ERR.Number <> 0 Then
                            ''debug.print  Err.DESCRIPTION, "DYNABLOCK exists"
                            block_PARAMETER_to_dictionary = False
                        End If
                        'Err.Clear
                        dict.ITEM(ARRAYNAME) = Trim(ARRAYSTRING)
                        If ERR.Number <> 0 Then
                            ''debug.print  Err.DESCRIPTION, "DYNABLOCK item "
                            block_PARAMETER_to_dictionary = False
                        End If
                    Else
                        'Err.Clear
                        ''debug.print  "??" & DICT_TAGNAME
                        dict.Add ARRAYNAME, ARRAYSTRING
                    
                        If ERR.Number <> 0 Then
                            ''debug.print  Err.DESCRIPTION, "DYNABLOCK dictinary add"
                            block_PARAMETER_to_dictionary = False
                        End If
                        ''debug.print  "*", DICT.ITEM(DICT_TAGNAME)
                    End If
                    ARRAYNAME = ""
                End If
                
                
                
                
                If VT = vbString Then
                    ''debug.print  Err.DESCRIPTION
                    VS = DYNPROP.value
                Else
                    V = DYNPROP.value
                End If
          
   
                Select Case VT

                    Case vbDouble
                     
                        tagvalue = Trim(STR(V))
                    Case vbString  '8
                       
                        tagvalue = VS

                    Case vbEmpty    '0
                        tagvalue = ""
                    Case vbNull  '1
                        tagvalue = ""
                        '            Case vbInteger    '2
                        '                tagvalue = Trim(str(V))
                        '            Case vbLong    '3
                        '                tagvalue = Trim(str(V))
                        '            Case vbSingle    '4
                        '                tagvalue = Trim(str(V))
                        '            Case vbDouble  '5
                        '                tagvalue = Trim(str(V))
                        '            Case vbCurrency  '6
                        '                tagvalue = Trim(str(V))
                    Case vbDate  '7
                        tagvalue = Trim(V)

                        
                    Case vbObject    '9
                        tagvalue = ""
                    Case vbError    '10
                        tagvalue = ""
                    Case vbBoolean    '11
                        If V Then tagvalue = "TRUE" Else tagvalue = "FALSE"
                    Case vbVariant    '12
                        tagvalue = ""
                    Case vbDataObject    '13
                        tagvalue = ""
                        '            Case vbDecimal    '14
                        '                tagvalue = Trim(str(V))
                        '            Case vbByte    '15
                        '                tagvalue = Trim(str(V))
                    Case Else
                        tagvalue = Trim(STR(V))
                End Select
                    
                    
                
                If ERR.Number <> 0 Then
                    ''debug.print  Err.DESCRIPTION, "DYNABLOCK"
                    block_PARAMETER_to_dictionary = False
                End If
                
                'Err.Clear
                If dict.Exists(DICT_TAGNAME) Then
                    If ERR.Number <> 0 Then
                        ''debug.print  Err.DESCRIPTION, "DYNABLOCK exists"
                        block_PARAMETER_to_dictionary = False
                    End If
                    'Err.Clear
                    dict.ITEM(DICT_TAGNAME) = Trim(tagvalue)
                    If ERR.Number <> 0 Then
                        ''debug.print  Err.DESCRIPTION, "DYNABLOCK item "
                        block_PARAMETER_to_dictionary = False
                    End If
                Else
                    'Err.Clear
                    ''debug.print  "??" & DICT_TAGNAME
                    dict.Add DICT_TAGNAME, tagvalue
                    
                    If ERR.Number <> 0 Then
                        ''debug.print  Err.DESCRIPTION, "DYNABLOCK dictinary add"
                        block_PARAMETER_to_dictionary = False
                    End If
                    ''debug.print  "*", DICT.ITEM(DICT_TAGNAME)
                End If
                
                
                If ERR.Number <> 0 Then
                    ''debug.print  Err.DESCRIPTION
                    block_PARAMETER_to_dictionary = False
                End If
                
                '########################################################################
            Else 'VBARRAY
            
                
                
                V = DYNPROP.value
                Dim ARRS As String
                ARRS = ""
                For j = LBound(V, 1) To UBound(V, 1)
                
                    arr = V(j)
                    Dim ArrType
                    VT = VarType(arr)
                    If VT = vbString Then
                        VS = V(j)
                    Else
                        arr = V(j)
                        ''debug.print  Err.DESCRIPTION
                    End If
       
                    Select Case VT
                        Case vbDouble
                            tagvalue = Trim(STR(arr))
                        Case vbString
                            tagvalue = Trim(arr)
                        Case vbEmpty    '0
                            tagvalue = ""
                        Case vbNull  '1
                            tagvalue = "VBNULL"
                            '            Case vbInteger    '2
                            '                tagvalue = Trim(str(V))
                            '            Case vbLong    '3
                            '                tagvalue = Trim(str(V))
                            '            Case vbSingle    '4
                            '                tagvalue = Trim(str(V))
                            '            Case vbDouble  '5
                            '                tagvalue = Trim(str(V))
                            '            Case vbCurrency  '6
                            '                tagvalue = Trim(str(V))
                        Case vbDate  '7
                            tagvalue = Trim(arr)
                        Case vbString  '8
                            tagvalue = Trim(arr)
                        Case vbObject    '9
                            tagvalue = "OBJECT"
                        Case vbError    '10
                            tagvalue = "VBERROR"
                        Case vbBoolean    '11
                            If arr Then tagvalue = "TRUE" Else tagvalue = "FALSE"
                        Case vbVariant    '12
                            tagvalue = "VARIANT"
                        Case vbDataObject    '13
                            tagvalue = "VBDATAOBJECT"
                            '            Case vbDecimal    '14
                            '                tagvalue = Trim(str(V))
                            '            Case vbByte    '15
                            '                tagvalue = Trim(str(V))
                        Case Else
                           
                            tagvalue = Trim(STR(arr))
                    End Select
                    ARRS = ARRS & tagvalue & vbTab
                Next
                ARRAYNAME = ""
                ARRAYSTRING = ""
                If ARRS <> "" Then
                    ARRS = left(ARRS, Len(ARRS) - 1)
                    ARRAYSTRING = ARRS
                    ARRAYNAME = proptagname
                    ''debug.print  ARRS
                End If
                
                
                
                
            End If
        End If
    Next
    ''debug.print  "done"
    'vbEmpty 0 Empty (uninitialized)
    'vbNull 1 Null (no valid data)
    'vbInteger 2 Integer
    'vbLong 3 Long integer
    'vbSingle 4 Single-precision floating-point number
    'vbDouble 5 Double-precision floating-point number
    'vbCurrency 6 Currency value
    'vbDate 7 Date value
    'vbString 8 String
    'vbObject 9 Object
    'vbError 10 Error value
    'vbBoolean 11 Boolean value
    'vbVariant 12 Variant (used only with arrays of variants)
    'vbDataObject 13 A data access object
    'vbDecimal 14 Decimal value
    'vbByte 17 Byte value
    'vbUserDefinedType 36 Variants that contain user-defined types
    'vbArray 8192 Array
    
    
   ' 'debug.print  DICT.count
    
block_PARAMETER_to_dictionary = True
End Function
Sub ENTITY_clone_propertys(MASTER As AcadEntity, copy As AcadEntity)
    Dim dict As DICTIONARY_VBA
    Set dict = New DICTIONARY_VBA
    If ENTITYS_PROPERTYS_to_dictionary(MASTER, dict, True) Then
        Call ENTITYS_PROPERTYS_from_dictionary(copy, dict, True)
    End If
    
End Sub


Sub TAG_TO_DICTIONARY(dict As DICTIONARY_VBA, ByRef tagname As String, ByRef tagvalue As String, Optional add_padding As Boolean = False)
    Dim DICT_TAGNAME  As String
    Dim TV As String
    TV = tagvalue
    If add_padding Then TV = Chr(34) & Trim(tagvalue) & Chr(34)
    DICT_TAGNAME = Trim(tagname)
    If IsNumeric(tagvalue) Then
        tagvalue = REPLACE(tagvalue, ",", ".")
    End If
    If UCase(tagname) = tagname Then
        If dict.Exists(DICT_TAGNAME) Then
            dict.ITEM(DICT_TAGNAME) = TV
        Else
            dict.Add DICT_TAGNAME, TV
        End If
    End If
End Sub




Sub TAG_FROM_DICTIONARY(dict As DICTIONARY_VBA, ByRef tagname As String, tagvalue As Variant, Optional remove_padding As Boolean = False)
    Dim DICT_TAGNAME  As String
    DICT_TAGNAME = UCase(tagname)
    If dict.Exists(DICT_TAGNAME) Then
        tagvalue = dict.ITEM(DICT_TAGNAME)
        If Not IsNumeric(tagvalue) Then
            If remove_padding Then tagvalue = REPLACE(tagvalue, Chr(34), "")
        
            tagvalue = Trim(REPLACE(tagvalue, ",", "."))
        End If
    End If
End Sub

Sub block_PROPERTYS_from_dictionary(entity As AcadEntity, dict As DICTIONARY_VBA, Optional ALL As Boolean, Optional PREFIX As String)
    On Error Resume Next
    If LCASE(entity.objectname) <> "acdbblockreference" Then

        On Error GoTo 0
        Exit Sub
    End If
    Dim blockref As AcadBlockReference
    Dim ANGLE As String
    Dim scale_x As String
    Dim scale_y As String
    Dim scale_z As String
    Dim ScaleX As String
    Dim ScaleY As String
    Dim scaleZ As String
    Dim Material As String
    Dim HYPERLINKS As String
    Dim x As String
    Dim Y As String
    Dim z As String


 
    Set blockref = entity
   
    Call TAG_FROM_DICTIONARY(dict, PREFIX & "BLOCKREF_ROTATION", ANGLE)
    Call TAG_FROM_DICTIONARY(dict, PREFIX & "BLOCKREF_EFF_SCALE_X", scale_x)
    Call TAG_FROM_DICTIONARY(dict, PREFIX & "BLOCKREF_EFF_SCALE_Y", scale_y)
    Call TAG_FROM_DICTIONARY(dict, PREFIX & "BLOCKREF_EFF_SCALE_Z", scale_z)
    Call TAG_FROM_DICTIONARY(dict, PREFIX & "BLOCKREF_SCALE_X", ScaleX)
    Call TAG_FROM_DICTIONARY(dict, PREFIX & "BLOCKREF_SCALE_Y", ScaleY)
    Call TAG_FROM_DICTIONARY(dict, PREFIX & "BLOCKREF_SCALE_Z", scaleZ)
    'Call TAG_FROM_DICTIONARY(dict, PREFIX & "BLOCKREF_EFFECTIVE_NAME", blockref.EffectiveName)

     
    blockref.ROTATION = val(ANGLE)
    
    If blockref.isdynamicblock Then
        If blockref.xeffectivescalefactor <> val(scale_x) Then blockref.xeffectivescalefactor = val(scale_x)
        If blockref.yeffectivescalefactor <> val(scale_y) Then blockref.yeffectivescalefactor = val(scale_y)
        If blockref.zeffectivescalefactor <> val(scale_z) Then blockref.zeffectivescalefactor = val(scale_z)
        
    Else
        If blockref.xscalefactor <> val(ScaleX) Then blockref.xscalefactor = val(ScaleX)
        If blockref.yscalefactor <> val(ScaleY) Then blockref.yscalefactor = val(ScaleY)
        If blockref.zscalefactor <> val(scaleZ) Then blockref.zscalefactor = val(scaleZ)
  
    End If

        
    If ALL Then
    
    
    
    
        Dim retcolor As AcadAcCmColor
        Dim TRUECOLOR As String
        Dim LINETYPE As String
        Dim LINETYPESCALE As String
        Dim LINEWEIGHT As String
        Dim LAYER As String
        Dim TRANSPARENCY As String
        
        
        Dim COLOR As String
        Dim H() As String
    
        Dim R As Long
        Dim G As Long
        Dim B As Long
   
    
        '  On Error Resume Next
        Call TAG_FROM_DICTIONARY(dict, PREFIX & "BLOCKREF_COLOR", COLOR)
        Call TAG_FROM_DICTIONARY(dict, PREFIX & "BLOCKREF_LAYER", LAYER, True)
        Call TAG_FROM_DICTIONARY(dict, PREFIX & "BLOCKREF_LINETYPE", LINETYPE, True)
        Call TAG_FROM_DICTIONARY(dict, PREFIX & "BLOCKREF_LINETYPESCALE", LINETYPESCALE)
        Call TAG_FROM_DICTIONARY(dict, PREFIX & "BLOCKREF_LINEWEIGHT", LINEWEIGHT)
        Call TAG_FROM_DICTIONARY(dict, PREFIX & "BLOCKREF_MATERIAL", Material, True)
        Call TAG_FROM_DICTIONARY(dict, PREFIX & "BLOCKREF_TRANSPARENCY", TRANSPARENCY)
        Call TAG_FROM_DICTIONARY(dict, PREFIX & "BLOCKREF_TRUECOLOR", TRUECOLOR, True)
        Call TAG_FROM_DICTIONARY(dict, PREFIX & "BLOCKREF_HYPERLINKS", HYPERLINKS, True)
        Call ENTITY_HYPERLINKS_FROM_STRING(blockref, HYPERLINKS)
  
        H = Split(TRUECOLOR)
        R = val(H(0))
        G = val(H(1))
        B = val(H(2))
        If R + G + B <> 0 Then
            Set retcolor = AINTERFACE.IColor
            Call retcolor.SetRGB(R, G, B)
            blockref.TRUECOLOR = retcolor
        End If
        
        
        
        COLOR = REPLACE(COLOR, ",", " ")
        
        
        
        If IsNumeric(COLOR) Then
            blockref.COLOR = STR(COLOR)

        Else
            If InStr(COLOR, " ") > 0 Then
                H = Split(COLOR)
                R = val(H(0))
                G = val(H(1))
                B = val(H(2))
            End If
        End If
               
        
        blockref.Material = Material
        blockref.LINEWEIGHT = val(LINEWEIGHT)
        blockref.LINETYPE = LINETYPE
        blockref.LINETYPESCALE = val(LINETYPESCALE)
          
        blockref.LAYER = LAYER
          
        blockref.BLOCKREFTRANSPARENCY = TRANSPARENCY
        blockref.Material = Material
        If HYPERLINKS <> "" Then Call ENTITY_HYPERLINKS_FROM_STRING(blockref, HYPERLINKS)

        Dim p(2) As Double
        Call TAG_FROM_DICTIONARY(dict, PREFIX & "BLOCKREF_INSERTATION_POINT_X", x)
        Call TAG_FROM_DICTIONARY(dict, PREFIX & "BLOCKREF_INSERTATION_POINT_Y", Y)
        Call TAG_FROM_DICTIONARY(dict, PREFIX & "BLOCKREF_INSERTATION_POINT_Z", z)

        p(0) = val(x)
        p(1) = val(Y)
        p(2) = val(z)
        
        Dim IP
        
        IP = p
        blockref.insertionPoint = IP
    
    


        
    End If
    
   

End Sub


Function ENTITYS_PROPERTYS_to_dictionary(entity As AcadEntity, dict As DICTIONARY_VBA, Optional ALL As Boolean = False, Optional PREFIX As String) As Boolean
    ENTITYS_PROPERTYS_to_dictionary = False
    ERR.Clear
    ' On Error Resume Next
    Dim retcolor As AcadAcCmColor
    Dim TRUECOLOR As String
    Dim HYPERLINKS As String
    Dim GUID As String
    Call ENTITY_HYPERLINKS_TO_STRING(entity, HYPERLINKS)
    Call XDATA_Get("GUID", entity, GUID)
    Call TAG_TO_DICTIONARY(dict, PREFIX & "ENTITY_GUID", GUID, True)
    Set retcolor = AINTERFACE.IColor
    Set retcolor = entity.TRUECOLOR
    TRUECOLOR = D2S(retcolor.red) & " " & D2S(retcolor.green) & " " & D2S(retcolor.blue)
    Call TAG_TO_DICTIONARY(dict, PREFIX & "ENTITY_COLOR", D2S(entity.COLOR), True)
    Call TAG_TO_DICTIONARY(dict, PREFIX & "ENTITY_HANDLE", entity.handle, True)
    Call TAG_TO_DICTIONARY(dict, PREFIX & "ENTITY_OBJECTNAME", LCASE(entity.objectname), True)
    
    Call TAG_TO_DICTIONARY(dict, PREFIX & "ENTITY_LINEWEIGHT", Trim(D2S(entity.LINEWEIGHT)))
    Call TAG_TO_DICTIONARY(dict, PREFIX & "ENTITY_LINETYPE", entity.LINETYPE, True)
    Call TAG_TO_DICTIONARY(dict, PREFIX & "ENTITY_LINETYPESCALE", D2S(entity.LINETYPESCALE))
    Call TAG_TO_DICTIONARY(dict, PREFIX & "ENTITY_LAYER", entity.LAYER, True)
    Call TAG_TO_DICTIONARY(dict, PREFIX & "ENTITY_TRANSPARENCY", entity.ENTITYTRANSPARENCY, True)
    Call TAG_TO_DICTIONARY(dict, PREFIX & "ENTITY_TRUECOLOR", TRUECOLOR, True)
    Call TAG_TO_DICTIONARY(dict, PREFIX & "ENTITY_MATERIAL", entity.Material, True)
    Call TAG_TO_DICTIONARY(dict, PREFIX & "ENTITY_HYPERLINKS", HYPERLINKS, True)
    
    Dim EON As String
    EON = LCASE(entity.objectname)
    If InStr(EON, "text") > 0 Then
        Call TAG_TO_DICTIONARY(dict, PREFIX & "ENTITY_TEXTSTRING", entity.TEXTSTRING, True)
    End If
    
    If InStr(EON, "line") > 0 Then
        Call TAG_TO_DICTIONARY(dict, PREFIX & "ENTITY_LENGTH", entity.LENGTH, False)
    End If
    
    
    
    If InStr(EON, "circle") > 0 Then
        Call TAG_TO_DICTIONARY(dict, PREFIX & "ENTITY_RADIUS", entity.radius, True)
        Call TAG_TO_DICTIONARY(dict, PREFIX & "ENTITY_DIAMETER", entity.DIAMETER, True)
    End If
    
    If InStr("acdblwpolyline acdbpolyline acdbhatch acdbsection", EON) > 0 Then
        Call TAG_TO_DICTIONARY(dict, PREFIX & "ENTITY_ELEVATION", entity.ELEVATION, False)
    End If
    
    If ERR.Number = 0 Then ENTITYS_PROPERTYS_to_dictionary = True
End Function
Function ENTITYS_PROPERTYS_from_dictionary(entity As AcadEntity, dict As DICTIONARY_VBA, Optional ALL As Boolean = False, Optional PREFIX As String) As Boolean
    ENTITYS_PROPERTYS_from_dictionary = False
    
    
    ERR.Clear
    
    Dim retcolor As AcadAcCmColor
    Dim TRUECOLOR As String
    Dim LINETYPE As String
    Dim LINETYPESCALE As String
    Dim LINEWEIGHT As String
    Dim LAYER As String
    Dim TRANSPARENCY As String
    Dim Material As String
    Dim HYPERLINKS As String
    Dim TEXTSTRING As String
    Dim ELEVATION As Double
    Dim COLOR As String
    Dim H() As String
    
    Dim R As Long
    Dim G As Long
    Dim B As Long
    
    
    On Error Resume Next
    Call TAG_FROM_DICTIONARY(dict, PREFIX & "ENTITY_COLOR", COLOR, True)
    Call TAG_FROM_DICTIONARY(dict, PREFIX & "ENTITY_HEIGHT", Height)
    Call TAG_FROM_DICTIONARY(dict, PREFIX & "ENTITY_LAYER", LAYER, True)
    Call TAG_FROM_DICTIONARY(dict, PREFIX & "ENTITY_LINETYPE", LINETYPE, True)
    Call TAG_FROM_DICTIONARY(dict, PREFIX & "ENTITY_LINETYPESCALE", LINETYPESCALE)
    Call TAG_FROM_DICTIONARY(dict, PREFIX & "ENTITY_LINEWEIGHT", LINEWEIGHT)
    Call TAG_FROM_DICTIONARY(dict, PREFIX & "ENTITY_MATERIAL", Material, True)
    Call TAG_FROM_DICTIONARY(dict, PREFIX & "ENTITY_TRANSPARENCY", TRANSPARENCY, True)
    Call TAG_FROM_DICTIONARY(dict, PREFIX & "ENTITY_TRUECOLOR", TRUECOLOR, True)
    Call TAG_FROM_DICTIONARY(dict, PREFIX & "ENTITY_TEXTSTRING", TEXTSTRING, True)
    Call TAG_FROM_DICTIONARY(dict, PREFIX & "ENTITY_HYPERLINKS", HYPERLINKS, True)
    If Len(HYPERLINKS) > 0 Then Call ENTITY_HYPERLINKS_FROM_STRING(entity, HYPERLINKS)
    
    If Len(TRUECOLOR) > 0 Then
        H = Split(TRUECOLOR)
        R = val(H(0))
        G = val(H(1))
        B = val(H(2))
    End If
    
    If R + G + B <> 0 Then
        Set retcolor = AINTERFACE.IColor
        Call retcolor.SetRGB(R, G, B)
        If Len(TRUECOLOR) > 0 Then
            entity.TRUECOLOR = retcolor
        End If
        

    Else
        If COLOR <> "" Then entity.COLOR = COLOR

    End If
    
    Dim EON As String
    EON = LCASE(entity.objectname)
    
    If IsNumeric(LINEWEIGHT) Then entity.LINEWEIGHT = val(LINEWEIGHT)
    If Len(LINETYPE) > 0 Then entity.LINETYPE = LINETYPE
    If IsNumeric(LINETYPESCALE) Then entity.LINETYPESCALE = val(LINETYPESCALE)
    
    If Len(LAYER) > 0 Then entity.LAYER = LAYER
    If Len(TRANSPARENCY) > 0 Then entity.ENTITYTRANSPARENCY = TRANSPARENCY
    If Len(Material) > 0 Then entity.Material = Material
    
    If InStr(EON, "text") > 0 Then
        If dict.Exists("ENTITY_TEXTSTRING") Then entity.TEXTSTRING = TEXTSTRING
    End If
    
    If InStr("acdblwpolyline acdbpolyline acdbhatch acdbsection", EON) > 0 Then
        Call TAG_FROM_DICTIONARY(dict, PREFIX & "ENTITY_ELEVATION", ELEVATION)
         entity.ELEVATION = ELEVATION
    End If
    
    If ERR.numer = 0 Then ENTITYS_PROPERTYS_from_dictionary = True
End Function


Sub stresstest()
    'debug.print  Now()
    For U = 0 To 1000

        Call test_SUPERBLOCK_
        ''debug.print  U
        DoEvents
    Next
    'debug.print  Now()
    'debug.print  "done"
End Sub
Sub test_SUPERBLOCK_()
    Dim entity As AcadEntity
    For Each entity In thisdrawing.PickfirstSelectionSet
        Call SB_grip_stretch(entity)
    Next
End Sub
Sub testehyps()
    Dim entity As AcadEntity
    Dim s As String
    Dim dict As DICTIONARY_VBA
    Set dict = New DICTIONARY_VBA
    For Each entity In thisdrawing.PickfirstSelectionSet
        Call ENTITY_HYPERLINKS_TO_STRING(entity, s)
        
        Call ENTITYS_PROPERTYS_to_dictionary(entity, dict)
        Call ENTITYS_PROPERTYS_from_dictionary(entity, dict)
        Exit For
    Next
    'debug.print  s
End Sub
Function ENTITY_HYPERLINKS_TO_STRING(entity As AcadEntity, s As String, Optional Delim As String = vbTab, Optional DLINE As String = vbTab) As Boolean
    Dim LINK As AcadHyperlink
    If entity.HYPERLINKS.count = 0 Then Exit Function
    s = ""
    For Each LINK In entity.HYPERLINKS
        s = s & LINK.URL & Delim
        s = s & LINK.URLDescription & Delim
        s = s & LINK.URLNamedLocation & DLINE
    Next
    s = left(s, Len(s) - 1)
End Function

Function ENTITY_HYPERLINKS_FROM_STRING(entity As AcadEntity, s As String, Optional Delim As String = vbTab, Optional DLINE As String = vbTab) As Boolean
'    If S = "" Then Exit Function
'    Dim LINK As AcadHyperlink
'    Dim LINKS()
'    Dim URL()
'    LINKS = Split(S, DLINE)
'    For i = LBound(LINKS) To UBound(LINKS)
'        If Trim(LINKS(i)) <> "" Then
'            URL = Split(LINKS(i), DELIM)
'            entity.HYPERLINKS.Add URL(0), URL(1), URL(2)
'        End If
'    Next

End Function



Function block_PROPERTYS_to_dictionary(entity As AcadEntity, dict As DICTIONARY_VBA, Optional ALL As Boolean = False, Optional PREFIX As String) As Boolean
    
    block_PROPERTYS_to_dictionary = False
    If LCASE(entity.objectname) <> "acdbblockreference" Then Exit Function
    
    ERR.Clear
    
    Dim GUID As String
    Dim blockref As AcadBlockReference
    Set blockref = entity
   
    V = blockref.insertionPoint
    
    
    
   
    
    
    
    Call TAG_TO_DICTIONARY(dict, PREFIX & "BLOCKREF_EFF_SCALE_X", STR(blockref.xeffectivescalefactor))
    Call TAG_TO_DICTIONARY(dict, PREFIX & "BLOCKREF_EFF_SCALE_Y", STR(blockref.yeffectivescalefactor))
    Call TAG_TO_DICTIONARY(dict, PREFIX & "BLOCKREF_EFF_SCALE_Z", STR(blockref.zeffectivescalefactor))
    
    
    Call TAG_TO_DICTIONARY(dict, PREFIX & "BLOCKREF_INSERTATION_POINT_X", STR(V(0)))
    Call TAG_TO_DICTIONARY(dict, PREFIX & "BLOCKREF_INSERTATION_POINT_Y", STR(V(1)))
    Call TAG_TO_DICTIONARY(dict, PREFIX & "BLOCKREF_INSERTATION_POINT_Z", STR(V(2)))
    
    Call TAG_TO_DICTIONARY(dict, PREFIX & "BLOCKREF_ROTATION", STR(blockref.ROTATION))
    Call TAG_TO_DICTIONARY(dict, PREFIX & "BLOCKREF_SCALE_X", STR(blockref.xscalefactor))
    Call TAG_TO_DICTIONARY(dict, PREFIX & "BLOCKREF_SCALE_Y", STR(blockref.yscalefactor))
    Call TAG_TO_DICTIONARY(dict, PREFIX & "BLOCKREF_SCALE_Z", STR(blockref.zscalefactor))
    
    
   
 

    If ALL Then
        Dim retcolor As AcadAcCmColor
        Dim TRUECOLOR As String
    
        Dim HYPERLINKS As String
        Call ENTITY_HYPERLINKS_TO_STRING(entity, HYPERLINKS)
        
        Set retcolor = AINTERFACE.IColor
        Set retcolor = entity.TRUECOLOR
        TRUECOLOR = D2S(retcolor.red) & " " & D2S(retcolor.green) & " " & D2S(retcolor.blue)
    
        Call XDATA_Get("GUID", blockref, GUID)
        Call TAG_TO_DICTIONARY(dict, PREFIX & "BLOCKREF_GUID", GUID, True)
    
        Call TAG_TO_DICTIONARY(dict, PREFIX & "BLOCKREF_HYPERLINKS", HYPERLINKS, True)
        Call TAG_TO_DICTIONARY(dict, PREFIX & "BLOCKREF_MATERIAL", blockref.Material, True)
        Call TAG_TO_DICTIONARY(dict, PREFIX & "BLOCKREF_TRUECOLOR", TRUECOLOR, True)
        Call TAG_TO_DICTIONARY(dict, PREFIX & "BLOCKREF_COLOR", blockref.COLOR)
        Call TAG_TO_DICTIONARY(dict, PREFIX & "BLOCKREF_LINEWEIGHT", D2S(blockref.LINEWEIGHT))
        Call TAG_TO_DICTIONARY(dict, PREFIX & "BLOCKREF_LINETYPE", blockref.LINETYPE, True)
        Call TAG_TO_DICTIONARY(dict, PREFIX & "BLOCKREF_LINETYPESCALE", D2S(blockref.LINETYPESCALE))
        Call TAG_TO_DICTIONARY(dict, PREFIX & "BLOCKREF_NAME", blockref.Name, True)
        Call TAG_TO_DICTIONARY(dict, PREFIX & "BLOCKREF_EFFECTIVE_NAME", blockref.effectivename, True)
        Call TAG_TO_DICTIONARY(dict, PREFIX & "BLOCKREF_HANDLE", "~" & blockref.handle, True)
        Call TAG_TO_DICTIONARY(dict, PREFIX & "BLOCKREF_LAYER", blockref.LAYER, True)

        
        G = GROUP_find_by_entity(entity)
        Call TAG_TO_DICTIONARY(dict, PREFIX & "BLOCKREF_GROUPS", CStr(G), True)
    End If
    If ERR.Number = 0 Then block_PROPERTYS_to_dictionary = True
    
    
    
    
   
   
End Function



Sub block_set_attribute(BLO As AcadBlockReference, tagname, tagvalue)
    Dim ATTLIST As Variant
    If BLO Is Nothing Then Exit Sub
    If BLO.hasattributes Then
        tagname = Trim(UCase(tagname))
        ATTLIST = BLO.GetAttributes
        For i = LBound(ATTLIST) To UBound(ATTLIST)
            '''debug.print  "#" & UCase(attlist(i).TagString) & "#", tagname
            If UCase(ATTLIST(i).TAGSTRING) = tagname Or UCase(Trim(ATTLIST(i).TAGSTRING)) = tagname & "_001" Then
                'On Error Resume Next
                ATTLIST(i).TEXTSTRING = "" & tagvalue

                ' attlist(I).Update
                ' On Error GoTo 0
                Exit Sub
            End If
        Next

    End If
End Sub

Function block_set_parameter(blockref As AcadBlockReference, ByVal Name As String, value As Variant, Optional ucaseName As Boolean = True) As Boolean
    block_set_parameter = False
    If blockref Is Nothing Then Exit Function
    Dim DYNPROP As AcadDynamicBlockReferenceProperty
    Dim PROPNAME As String
    Dim Variable As Variant
    Dim TEMP As String
    Dim BV As Variant
    If Name = "" Then Exit Function
    If ucaseName Then Name = UCase(Name)
    Variable = blockref.GetDynamicBlockProperties
    For K = LBound(Variable) To UBound(Variable)
        Set DYNPROP = Variable(K)
        PROPNAME = DYNPROP.propertyName
        If ucaseName Then PROPNAME = UCase(PROPNAME)
        'Check for variable and when found ask for input
        If PROPNAME = Name Then
            If DYNPROP.ReadOnly = False Then
                BV = DYNPROP.value
                On Error Resume Next
                ERR.Clear
                If DYNPROP.value <> value Then
                    DYNPROP.value = value
                End If
                If ERR.Number = 0 Then block_set_parameter = True
                If ERR.Number <> 0 Then
                'debug.print  err.DESCRIPTION
                End If
                On Error GoTo 0
                ERR.Clear
                
                Exit Function
            End If
        End If
    Next
    On Error GoTo 0
End Function


Public Sub AtribStrProp()
    'Build the selection set
    Dim objBlkRef As AcadBlockReference
    Dim objGen As Object
    Dim varPnt As Variant
    Dim intCnt As Integer
    Dim varAtts As Variant
    Dim strPrompt As String
    Dim TAGS() As Variant
    Dim Text() As String
    strPrompt = "Select a block with attributes: "
    thisdrawing.Utility.GetEntity objGen, varPnt, strPrompt
    If TypeOf objGen Is AcadBlockReference Then
        Set objBlkRef = objGen
        Call BindXData(objBlkRef)
        ' TADA - Magic here
        Set objAttStr = APPLICATION.GetInterfaceObject("OpmX.Property.1")
        ' Now fill the arrays
        If objBlkRef.hasattributes Then
            varAtts = objBlkRef.GetAttributes
            ReDim TAGS(UBound(varAtts))
            ReDim Text(UBound(varAtts))
            For intCnt = LBound(varAtts) To UBound(varAtts)
                TAGS(intCnt) = varAtts(intCnt).TAGSTRING
                Text(intCnt) = varAtts(intCnt).TEXTSTRING
            Next
        End If
        'Set all of the information for the new property
        objAttStr.CategoryName = "Attribute Samples"
        objAttStr.classname = "AcDbBlockReference"
        objAttStr.DESCRIPTION = "Values from Attributes"
        objAttStr.DisplayName = "Used Values"
        objAttStr.SetDataSource "VBDESIGN", 1000, 1
        objAttStr.SetEnums Text, TAGS
        objAttStr.ReadOnly = False
        ' Now add it in!
        objAttStr.Add
    End If
End Sub


'Creates a layer if it does not exist in current drawing.
Private Sub AttributeInBlocks(ByRef TheBlock As AcadBlockReference)

    Dim ATTLIST As Variant
    Dim i As Integer

    ATTLIST = TheBlock.GetAttributes
    For i = LBound(ATTLIST) To UBound(ATTLIST)
        Select Case ATTLIST(i).TAGSTRING
            Case "TAG_A"
                'debug.print  ATTLIST(I).TEXTSTRING
            Case "TAG_B"
                'debug.print  ATTLIST(I).TEXTSTRING
                ATTLIST(i).TEXTSTRING = "some text"
            Case "TAG_C"
                'debug.print  ATTLIST(I).TEXTSTRING
        End Select
    Next

End Sub

Public Sub AttributesON()
    Dim objEnt As AcadEntity
    Dim objBlkRef As AcadBlockReference
    Dim objAtt As AcadAttributeReference
    Dim varPnt As Variant
    Dim varAtts As Variant
    Dim strPrmt As String
    Dim intCnt As Integer
    On Error GoTo Err_Control
    strPrmt = "Select Block with invisible attribute(s): "
    thisdrawing.Utility.GetEntity objEnt, varPnt, strPrmt
    If TypeOf objEnt Is AcadBlockReference Then
        Set objBlkRef = objEnt
        If objBlkRef.hasattributes Then
            varAtts = objBlkRef.GetAttributes
            For intCnt = LBound(varAtts) To UBound(varAtts)
                Set objAtt = varAtts(intCnt)
                If objAtt.INVISIBLE = True Then
                    objAtt.INVISIBLE = False
                End If
            Next intCnt
        Else
            MsgBox "No attributes found."
        End If
    Else
        MsgBox "Selected entity is not a block reference."
    End If
Exit_Here:
    Exit Sub
Err_Control:
    'debug.print  err.DESCRIPTION
    Resume Exit_Here
End Sub

Public Sub AttributesToText()
    Dim varPnt As Variant
    Dim varPoint As Variant
    Dim varAtts As Variant
    Dim varHt As Variant
    Dim intCnt As Integer
    Dim objBLK As Object
    Dim strPrompt As String

    On Error GoTo Err_Control:

    strPrompt = vbCrLf & "Pick START point for text column: "
    varPnt = thisdrawing.Utility.GetPoint(prompt:=strPrompt)
    strPrompt = vbCrLf & "Pick block with attributes to convert: "
    thisdrawing.Utility.GetEntity objBLK, varPoint, strPrompt
    If TypeOf objBLK Is AcadBlockReference Then
        If objBLK.hasattributes Then
            varAtts = objBLK.GetAttributes
            For intCnt = LBound(varAtts) To UBound(varAtts)
                varHt = varAtts(intCnt).Height
                If thisdrawing.ACTIVESPACE = acModelSpace Then
                    thisdrawing.modelspace.AddText varAtts(intCnt).TEXTSTRING, varPnt, varHt
                Else
                    thisdrawing.PaperSpace.AddText varAtts(intCnt).TEXTSTRING, varPnt, varHt
                End If

                varPnt(1) = varPnt(1) + (CDbl(varHt) * 1.5)
            Next
        End If
    End If
Exit_Here:
    Exit Sub
Err_Control:
    'debug.print  err.DESCRIPTION
    Resume Exit_Here
End Sub

Private Sub CommandButton4_Click()
    
    Dim Element As Object
    Dim elementBlock As AcadBlockReference
    Dim ArrayAttributes As Variant
    Dim i As Integer
    Dim PNAME As Variant
    Dim lookuptbl As Variant
    Dim WIDTH As Double
    Dim Height As Double
    
    For Each elementBlock In thisdrawing.modelspace
        If elementBlock.isdynamicblock = True Then
           
            Set lookuptbl = elementBlock.GetDynamicBlockProperties

            'The stuff below is for reference only
            ListBox1.AddItem PNAME
            ListBox2.AddItem lookuptbl(4).propertyName
            ListBox2.AddItem lookuptbl(4).value
            'ListBox2 = lookuptbl(4).AllowedValues(1)
            'I cant seem to get the AllowedValues but I can see them in the watch window.
            ListBox2.AddItem " "
            ListBox2.AddItem lookuptbl(5).propertyName
            ListBox2.AddItem lookuptbl(5).value
            ListBox2.AddItem " "
            ListBox2.AddItem lookuptbl(0).propertyName
            ListBox2.AddItem lookuptbl(0).value
        End If
    Next
End Sub