Hi,
Ich würde den alten Block umbenennen und dann die neue Blockdefinition "irgendwie" einlesen.
Sprich als DWG oder aus einer anderen Zeichnung einkopieren.
Nun kann man die Propertys, Attribute, Parameter gemütlich auslesen und temporär in z.B einem Scripting dictionary speichern.
Nun fügt man den neuen Block ein und setzt die gerade gespeicherten Eigenschaften. SObald man mit allen Blöckebn fertig ist, können die alten umbenannten gelöscht werden. Als auch denen Block Definition
Das klappt gefahrlos mit allen Blocktypen. Hintenrum an den definitionen rumzufummeln halte ich für keine gute Idee.
Gerade wenn man viel Atribute hat oder Parameter müssen die dann neu generiert werden bzw mit Attsync angepasst werden. Spätestens da ist das Neueinfügen Welten schneller.
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 Scripting.DICTIONARY
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 Scripting.DICTIONARY
Dim PROP As New Scripting.DICTIONARY
Dim attr As New Scripting.DICTIONARY
Application.UPDATE
Call layer_clone("TMP", "0")
sBlockName = InputBox("BLOCK NAME NEW", "BLOCK NEW", "")
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 Scripting.DICTIONARY) 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
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
' tagprompt = attlist(i).PromptString
' tagpreset = attrib.Preset
If Right(tagname, 4) = "_001" Then tagname = Left(tagname, Len(tagname) - 4)
dict_tagname = "ATTR_" & tagname
If dict.Exists(dict_tagname) Then ATTLIST(i).TEXTSTRING = dict.ITEM(dict_tagname)
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 Scripting.DICTIONARY) 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
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 = "ATTR_" & 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
If err.Number <> 0 Then block_ATTRIBUTE_to_dictionary = False
End Function
Function block_PARAMETER_from_dictionary(entity As AcadEntity, dict As Scripting.DICTIONARY, Optional all As Boolean = False, Optional roundthem As Long = -1) As Boolean
Dim blockref As AcadBlockReference
On Error Resume Next
If LCase(entity.ObjectName) <> "acdbblockreference" Then
On Error GoTo 0
Exit Function
End If
Set blockref = entity
err.Clear
block_PARAMETER_from_dictionary = True
Dim DynProp As AcadDynamicBlockReferenceProperty
Dim Variable As Variant
Dim V As Variant
Dim proptagname As String
Dim proptagvalue As String
Dim proptagunits As String
Dim proptagdescription As String
Dim k As Long
Dim VT As typeofVar
If Not blockref.IsDynamicBlock Then Exit Function
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 dict.Exists(dict_tagname) Then
dictvalue = dict.ITEM(dict_tagname)
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
'Debug.Print proptagname, , proptagvalue, vartype(V)
Select Case VarType(V)
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
On Error Resume Next
DynProp.Value = V
If err.Number <> 0 Then block_PARAMETER_from_dictionary = False
End If
End If
Next
End Function
Function block_PARAMETER_to_dictionary(entity As AcadEntity, dict As Scripting.DICTIONARY, Optional all As Boolean = False) As Boolean
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 DynProp As AcadDynamicBlockReferenceProperty
Dim Variable As Variant
Dim V As Variant
Dim proptagname As String
Dim proptagvalue As String
Dim proptagunits As String
Dim proptagdescription As String
Dim k As Long
Dim VT As typeofVar
If Not blockref.IsDynamicBlock Then Exit Function
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
Debug.Print proptagname, , proptagvalue, VarType(V)
Select Case VarType(V)
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 vbString '8
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
On Error Resume Next
Debug.Print V
tagvalue = Trim(str(V))
End Select
If dict.Exists(dict_tagname) Then
dict.ITEM(dict_tagname) = Trim(tagvalue)
Else
dict.Add dict_tagname, tagvalue
End If
If err.Number <> 0 Then block_PARAMETER_to_dictionary = False
End If
Next
End Function
Sub block_PROPERTYS_from_dictionary(entity As AcadEntity, dict As Scripting.DICTIONARY)
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 x As String
Dim y As String
Dim z As String
Set blockref = entity
Call TAG_FROM_DICTIONARY(dict, "BLOCKREF_ROTATION", ANGLE)
Call TAG_FROM_DICTIONARY(dict, "BLOCKREF_EFF_SCALE_X", scale_x)
Call TAG_FROM_DICTIONARY(dict, "BLOCKREF_EFF_SCALE_Y", scale_y)
Call TAG_FROM_DICTIONARY(dict, "BLOCKREF_EFF_SCALE_Z", scale_z)
Call TAG_FROM_DICTIONARY(dict, "BLOCKREF_SCALE_X", scaleX)
Call TAG_FROM_DICTIONARY(dict, "BLOCKREF_SCALE_Y", scaleY)
Call TAG_FROM_DICTIONARY(dict, "BLOCKREF_SCALE_Z", scaleZ)
'Call TAG_FROM_DICTIONARY(dict, "BLOCKREF_EFFECTIVE_NAME", blockref.EffectiveName)
Call TAG_FROM_DICTIONARY(dict, "BLOCKREF_INSERTATION_POINT_X", x)
Call TAG_FROM_DICTIONARY(dict, "BLOCKREF_INSERTATION_POINT_Y", y)
Call TAG_FROM_DICTIONARY(dict, "BLOCKREF_INSERTATION_POINT_Z", z)
blockref.Rotation = val(ANGLE)
blockref.XEffectiveScaleFactor = val(scale_x)
blockref.YEffectiveScaleFactor = val(scale_y)
blockref.ZEffectiveScaleFactor = val(scale_z)
blockref.XScaleFactor = val(scaleX)
blockref.YScaleFactor = val(scaleY)
blockref.ZScaleFactor = val(scaleZ)
End Sub
Sub block_PROPERTYS_to_dictionary(entity As AcadEntity, dict As Scripting.DICTIONARY, Optional all As Boolean = False)
If LCase(entity.ObjectName) <> "acdbblockreference" Then Exit Sub
Dim blockref As AcadBlockReference
Set blockref = entity
Call TAG_TO_DICTIONARY(dict, "BLOCKREF_ROTATION", str(blockref.Rotation))
Call TAG_TO_DICTIONARY(dict, "BLOCKREF_EFF_SCALE_X", str(blockref.XEffectiveScaleFactor))
Call TAG_TO_DICTIONARY(dict, "BLOCKREF_EFF_SCALE_Y", str(blockref.YEffectiveScaleFactor))
Call TAG_TO_DICTIONARY(dict, "BLOCKREF_EFF_SCALE_Z", str(blockref.ZEffectiveScaleFactor))
Call TAG_TO_DICTIONARY(dict, "BLOCKREF_SCALE_X", str(blockref.XScaleFactor))
Call TAG_TO_DICTIONARY(dict, "BLOCKREF_SCALE_Y", str(blockref.YScaleFactor))
Call TAG_TO_DICTIONARY(dict, "BLOCKREF_SCALE_Z", str(blockref.XScaleFactor))
Call TAG_TO_DICTIONARY(dict, "BLOCKREF_INSERTATION_POINT_X", str(blockref.InsertionPoint(0)))
Call TAG_TO_DICTIONARY(dict, "BLOCKREF_INSERTATION_POINT_Y", str(blockref.InsertionPoint(1)))
Call TAG_TO_DICTIONARY(dict, "BLOCKREF_INSERTATION_POINT_Z", str(blockref.InsertionPoint(2)))
If all Then
Call TAG_TO_DICTIONARY(dict, "BLOCKREF_EFFECTIVE_NAME", blockref.EffectiveName)
Call TAG_TO_DICTIONARY(dict, "BLOCKREF_HANDLE", blockref.HANDLE)
Call TAG_TO_DICTIONARY(dict, "BLOCKREF_LAYER", blockref.LAYER)
Call TAG_TO_DICTIONARY(dict, "BLOCKREF_COLOR", blockref.color)
Dim g As String
g = GROUP_find_by_entity(entity)
Call TAG_TO_DICTIONARY(dict, "BLOCKREF_GROUPS", g)
End If
End Sub
------------------
Wer es nicht versucht, hat schon verlorn
Und bei 3 Typos gibts den vierten gratis !
<<< for sale !
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP