A better way to update all blocks in a drawing?

I have cobbled together a routine that works but it SLOW. It works, but it
grinds for too long to be feasible. My code is below. Is there anyway to
speed this up? Can I limit the selection set in any way to speed things up?

The Goal
We have a lot of r14 drawings we convert to 2004. In 2004 we use named plot
styles. Many of the blocks in these converted drawings are not set up to
work with our new layer and plot style standards. We need to be able to
update all the block definitions in a drawing just to be able to plot. We
want all objects in blocks except for wipeouts and attributes to be set to
ByBlock for all properties. For wipeouts we want them set to ByLayer and
set to a specific layer. For attributes, we want all properties set to
ByBlock except for the lineweight which we want to set to 0.30mm.

Is my approach below crazy?

-------------------------------------------------------------------

Public Sub ResetAllBlockProperties()
Dim entity As AcadEntity
Dim BlockEntity As AcadEntity
Dim BlockDefinition As acadBlock
Dim BlockRef As AcadBlockReference
Dim SelectionSet As AcadSelectionSet
Dim strLayerName As String
Dim wptLayer As AcadLayer
Dim acadplot As AcadPlotConfiguration
Dim sysVar As String
Dim sysData As Integer

'check for named plot styles
sysVar = "PSTYLEMODE"
sysData = ThisDrawing.GetVariable(sysVar)

If sysData = 1 Then
MsgBox "This drawing is not set to Named Plot Styles. Use
CONVERTPSTYLES command first."
End
End If

'set plotstyle to office standard
Set acadplot = ThisDrawing.ActiveLayout
ThisDrawing.ActiveLayout.RefreshPlotDeviceInfo
strLayerName = "A-ANNO-MASK"

If ThisDrawing.ActiveSpace = acPaperSpace Then
ThisDrawing.ActiveSpace = acModelSpace
acadplot.StyleSheet = "Standard Plot Style.stb"
ThisDrawing.ActiveSpace = acPaperSpace
Else
acadplot.StyleSheet = "Standard Plot Style.stb"
End If

'set or create masking layer
On Error Resume Next
Set wptLayer = ThisDrawing.Layers(strLayerName)

If wptLayer Is Nothing Then
Set wptLayer = ThisDrawing.Layers.Add(strLayerName)
End If

ThisDrawing.SendCommand "-layer" & vbCr & "PStyle" & vbCr & "0% Screen"
& vbCr & "A-ANNO-MASK" & vbCr & vbCr

ThisDrawing.ActiveLayout.GetPlotStyleTableNames
ThisDrawing.SelectionSets.Item("BlockToUpdate").Delete

Set acadplot = ThisDrawing.ActiveLayout
ThisDrawing.ActiveLayout.RefreshPlotDeviceInfo

If ThisDrawing.ActiveSpace = acPaperSpace Then
ThisDrawing.ActiveSpace = acModelSpace
acadplot.StyleSheet = "Standard Plot Style.stb"
ThisDrawing.ActiveSpace = acPaperSpace
Else
acadplot.StyleSheet = "Standard Plot Style.stb"
End If

'select everything
On Error Resume Next
ThisDrawing.SelectionSets.Item("BlockToUpdate").Delete

Set SelectionSet = ThisDrawing.SelectionSets.Add("BlockToUpdate")
SelectionSet.Select acSelectionSetAll

'modify blocks
For Each entity In SelectionSet
For Each BlockDefinition In ThisDrawing.Blocks
If Not (BlockDefinition.IsLayout) And Not (BlockDefinition.IsXRef)
Then
For Each BlockEntity In BlockDefinition
If TypeOf BlockEntity Is IAcadRasterImage Then
On Error Resume Next
BlockEntity.Layer = strLayerName
BlockEntity.Update
BlockEntity.PlotStyleName = "ByLayer"
ElseIf TypeOf BlockEntity Is AcadAttribute Then
BlockEntity.color = acByBlock
BlockEntity.PlotStyleName = "ByBlock"
BlockEntity.Linetype = "ByBlock"
BlockEntity.Lineweight = acLnWt030
BlockEntity.Update
Else
BlockEntity.color = acByBlock
BlockEntity.PlotStyleName = "ByBlock"
BlockEntity.Linetype = "ByBlock"
BlockEntity.Lineweight = acLnWtByBlock
BlockEntity.Update
End If
Next BlockEntity
End If
Next BlockDefinition
Next entity

ThisDrawing.SendCommand "attsync" & vbCr & "name" & vbCr & "*" & vbCr &
"regen" & vbCr

'purge masking layer if not used
wptLayer.Delete

End Sub

 

Herein lies your biggest slowdown:
For Each entity In SelectionSet
For Each BlockDefinition In ThisDrawing.Blocks
This means that for every entity in your drawing you are cycling through
the blocks and modifying them.......
If you have 20 objects in the drawing then you will edit each and every
block definition 20 times! If you have 20,000 objects.......you get the
idea.

I don't think you need to use a selection set at all. Once the block
definitions are all complete, issue a regenall and the inserts will update.
Also, why use the SendCommand to set layer properties when you've already
got the layer object saved????

HTH,
Jeff

 

Thanks. Killing the selectionset fixes things. I forget why I did that to
begin with.
There was a reason, and at the time, I got inconsistent results without it.
Now I
can't break it. Looking back now, my question looks pretty dumb. Guess I
have
been tweaking it too much lately and can't see what is still in there.
Thanks.

As for the send command for the layer object, I did that to set the
plotstyle. For
some reason, nothing I would do to set the plotstyle by the layer object
would work.

ie. wptlayer.PlotStyleName = strPlotStyleName

In most cases, this would do nothing, especially if nothing in the current
drawing had
been assigned to that plot style name previously. The send command was the
only
method I found that was consistent.

 

This has been a bug since PlotStyles were implemented. It only works if
a user has manually clicked on the PlotStyle in the layer dialog prior
to your code running (as you noticed). Unfortunately, it's not a
workaround.

HTH,
Danny Polkinhorn
WATG
Honolulu