Presetting Dynamic Block Properties

[conveyor1]

Afternoon,

Currently have a VBA program that inserts a dynamic block onto the drawing.  It then updates the Dynamic Block Properties, Attributes and Layer settings based on the addition information provided by the user.  And typically this process from start to finish takes about 1 to 2 seconds per dynamic block.

However, if we need to add in multiple blocks, you can see how the amount of time really can increase.

Using some timers in the code, I found the biggest cause of the time increase is updating the dynamic block properties.  Is there a way in VBA to update or set the Dynamic Block Properties before inserting?  My thought is AutoCAD inserts the block first in its base state then it has to redraw it again based on the values.

General Code

Private Sub UpdateDynamicBlockTags()

' Change Dynamic Block Values Based on Tag

    Dim objBRef As AcadBlockReference
    Dim dblangle As Double
    Dim BLKINSERTPT As ACAD_POINT

    Set objBRef = ThisDrawing.ModelSpace.InsertBlock(BLKINSERTPT, UserForm1.TextBox14.text, 1, 1, 1, dblangle)

    Dim dybprop As Variant

    Dim i As Integer

    If objBRef.ObjectName = "AcDbBlockReference" Then

        If objBRef.IsDynamicBlock Then

            dybprop = objBRef.GetDynamicBlockProperties

            For i = LBound(dybprop) To UBound(dybprop)

                If dybprop(i).PropertyName <> "Origin" Then

                    If dybprop(i).PropertyName = "LENGTH" Then

                        dybprop(i).Value = Length_Tag

                    End If

                End If

            Next i

        End If

    End If

End Sub

Please let me know when you can.

[norman.yuan · Accepted solution]

Your code of setting block reference's dynamic property is OK (except for the outermost

If objBref.ObjectName="AcDbBlockReference" Then...

which is not necessary, because the objBref is created by InsertBlock(), which makes it AcadBlockReference for sure.

You are correct that when a dynamic block is inserted, it is at its "base" state. Only when its dynamic property/properties is changed, upon the moment of change, AutoCAD would decide if an anonymous block definition is required, and if yes, AutoCAD creates a new anonymous block definition and change the inserted block reference to be the reference of the new anonymous, and AutoCAD may also need to adjust/change the block reference's attributes, if the dynamic property has anything to do with the attributes. All of this takes time and computer power, but 1 or 2 second per block reference is quite long. You probably have a very complicated dynamic block, or the drawing has 2 many complicated dynamic blocks. Yes, using dynamic blocks excessively would degrade AutoCAD performance noticeably/significantly.

So, I do not see there is much you can do in terms of setting dynamic properties with code. Rather, if possible, try to design your dynamic block as simple as possible, and avoid to use huge number of dynamic blocks in a drawing with most block references having different property values.

[conveyor1]

Morning,

That is what I thought.

If that is the case, I have the following question.

When the macro inserts 10 dynamic blocks in a row, I see the first block
come in at its final state, then the second, third, etc.

Is it possible to have the screen not update until all ten blocks have been
inserted and the subroutine has completed? Could this reduce some
processing time?

Please let me know your thoughts.

[norman.yuan]

Is it possible to have the screen not update until all ten blocks have been
inserted and the subroutine has completed? Could this reduce some
processing time?

Please let me know your thoughts.

---

Probably not with VBA/AutoCAD COM API. If you do it with .NET API, yes, it is possible to do all work in one transaction, so that the view only get updated once (at the end of transaction). Besides, AutoCAD .NET API code runs faster then VBA code, as Autodesk claims (one more reason to leave VBA and migrate to AutoCAD .NET API).

[conveyor1]

Afternoon,

I am also trying to move to VB.net. So if it is possible and it would
speed up the process, what would you have as a recommendation?

[norman.yuan]

With AutoCAD .NET API, you would do the multiple block inserting within one Transaction, that would only update the screen at the end (when the Transaction is committed), which would certainly speed the process up a little bit. However, since you said it took 1 or 2 seconds for each block inserting in VBA, I suspect it could mainly be because of the dynamic block itself, so you may not see much "speed" gain even with .NET API.

Nonetheless, if i were capable of doing VBA and .NET API (even not that good yet), I would stop wasting time with VBA and focus on .NET API (maybe only doing VBA for some immediate/quick fix).

[conveyor1]

Just an update.  This was originally being developed on AutoCAD 2013.  We did some testing on 2016 and 2018 and the speed difference has been significantly increased.  If anyone know what could of changed from 2013 to 16 for such a performance update, please let me know.

[buianhtuan.cdt]

Sub TBR23OrdinateDimensionCheckOrigin()
'(VBA AutoCad)Ordinate Dimension Check Origin,[ODCO]

'Creat OD00Arr()
Dim OD00Arr() As Variant
Dim k As Integer
Dim objSelectOnScreen As AcadSelectionSet
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "DIMENSION"
Dim EachEntity As AcadDimOrdinate
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
objSelectOnScreen.Select acSelectionSetAll, , , FT, FD
If objSelectOnScreen.count = 0 Then
MsgBox "No Dimension Obj"
objSelectOnScreen.Delete
Exit Sub
End If
For Each EachEntity In objSelectOnScreen
If EachEntity.ObjectName = "AcDbOrdinateDimension" Then
If Round(EachEntity.Measurement, 3) = 0 Then
ReDim Preserve OD00Arr(0 To k)
Set OD00Arr(k) = EachEntity
k = k + 1
End If
End If
Next
objSelectOnScreen.Clear
If Func70IsEmptyArray(OD00Arr) = True Then
MsgBox "No 0 Ordinate Dimension"
Exit Sub
End If

'Define XorY
Dim ODObj As AcadDimOrdinate
Dim XorY As String
Dim MinPoint As Variant
Dim MaxPoint As Variant
Dim DeltaX As Double
Dim DeltaY As Double

'Define XY0Value Arr
Dim X0Value As Double
Dim X0ValueArr() As Variant
Dim Y0Value As Double
Dim Y0ValueArr() As Variant
Dim kX As Integer
Dim kY As Integer
Dim BeforeTextPosion As Variant
Dim AfterTextPosition As Variant
Dim pi As Double: pi = 4 * Atn(1)

For i = LBound(OD00Arr) To UBound(OD00Arr)
Set ODObj = OD00Arr(i)
'Define XorY
ODObj.GetBoundingBox MinPoint, MaxPoint
DeltaX = MaxPoint(0) - MinPoint(0)
DeltaY = MaxPoint(1) - MinPoint(1)
If DeltaX >= DeltaY Then
XorY = "Y"
Else
XorY = "X"
End If

'Define XY0Value Arr
BeforeTextPosion = ODObj.TextPosition
Select Case XorY
Case "Y"
AfterTextPosition = Thisdrawing.Utility.PolarPoint(BeforeTextPosion, -pi / 2, 10000)
ODObj.TextPosition = AfterTextPosition
ODObj.GetBoundingBox MinPoint, MaxPoint
Y0Value = MaxPoint(1)
ODObj.TextPosition = BeforeTextPosion
ReDim Preserve Y0ValueArr(0 To kY)
Y0ValueArr(kY) = Y0Value
kY = kY + 1
Case "X"
AfterTextPosition = Thisdrawing.Utility.PolarPoint(BeforeTextPosion, pi, 10000)
AfterTextPosition = Thisdrawing.Utility.PolarPoint(AfterTextPosition, -pi / 2, 10000)
ODObj.TextPosition = AfterTextPosition
ODObj.GetBoundingBox MinPoint, MaxPoint
X0Value = MaxPoint(0)
ODObj.TextPosition = BeforeTextPosion
ReDim Preserve X0ValueArr(0 To kX)
X0ValueArr(kX) = X0Value
kX = kX + 1
End Select
Next
If Func70IsEmptyArray(X0ValueArr) = True Or Func70IsEmptyArray(Y0ValueArr) = True Then
MsgBox "Dont Define (0,0)"
Exit Sub
End If

Dim Point00(0 To 2) As Double
For i = LBound(X0ValueArr) To UBound(X0ValueArr)
Point00(0) = X0ValueArr(i)
For k = LBound(Y0ValueArr) To UBound(Y0ValueArr)
Point00(1) = Y0ValueArr(k)
MinPoint = Thisdrawing.Utility.PolarPoint(Point00, 5 * pi / 4, 0.01)
MaxPoint = Thisdrawing.Utility.PolarPoint(Point00, pi / 4, 0.01)
'Select Dimension
objSelectOnScreen.Select acSelectionSetCrossing, MinPoint, MaxPoint, FT, FD
If objSelectOnScreen.count > 0 Then
For Each EachEntity In objSelectOnScreen
If EachEntity.ObjectName = "AcDbOrdinateDimension" Then
EachEntity.Visible = False
End If
Next
End If
objSelectOnScreen.Clear
Next
Next

'Check have Ordinate Dimension?
Dim WrongCount As Integer
objSelectOnScreen.Select acSelectionSetAll, , , FT, FD
For Each EachEntity In objSelectOnScreen
If EachEntity.ObjectName = "AcDbOrdinateDimension" And EachEntity.Visible = True Then
EachEntity.Color = acMagenta
WrongCount = WrongCount + 1
End If
Next
For Each EachEntity In objSelectOnScreen
EachEntity.Visible = True
Next
objSelectOnScreen.Delete
MsgBox "Wrong Ordinate Dimension: " & WrongCount

End Sub