Imports Autodesk.AutoCAD
Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.EditorInput
Public Class AnnoControl
<CommandMethod("AddCanno")> _
Public Sub annoMod()
Dim ed As Editor = Application.DocumentManager.MdiActiveDocument.Editor
Dim db As Database = HostApplicationServices.WorkingDatabase
Dim prmptSelOp As New PromptSelectionOptions()
prmptSelOp.MessageForAdding = vbLf & "Select annotative objects"
Dim prmptSelRes As PromptSelectionResult = ed.GetSelection(prmptSelOp)
If prmptSelRes.Status <> PromptStatus.OK Then
Return
End If
Dim pKeyword As PromptKeywordOptions = New PromptKeywordOptions("")
pKeyword.Message = vbLf & "Delete non-current scales?"
pKeyword.Keywords.Add("Yes")
pKeyword.Keywords.Add("No")
pKeyword.Keywords.Default = "Yes"
pKeyword.AllowNone = False
Dim pResult As PromptResult = ed.GetKeywords(pKeyword)
Dim tr As Transaction = db.TransactionManager.StartTransaction()
Try
Dim dwgAnnoScle As ObjectContextCollection = CurAScale(True)
Dim cAnnoScle As ObjectContext = CurAScale()
'Process selceted items
For Each selObject As SelectedObject In prmptSelRes.Value
Dim selObjectID As ObjectId = selObject.ObjectId
'Check if items are blocks
If selObjectID.ObjectClass.DxfName = "INSERT" Then
Dim blkRef As BlockReference = DirectCast(tr.GetObject(selObjectID, OpenMode.ForRead), BlockReference)
Dim btr As BlockTableRecord = DirectCast(tr.GetObject(blkRef.BlockTableRecord, OpenMode.ForRead), BlockTableRecord)
'if block is not annotative check the blocks contents for annotative objects
If blkRef.Annotative = AnnotativeStates.[False] Then
For Each btrID As ObjectId In btr
Dim ent As Entity = tr.GetObject(btrID, OpenMode.ForRead)
'ignore if attribute (handles later)
If TypeOf (ent) Is AttributeDefinition Then
Continue For
'check if annotative and does not have current anno state
ElseIf ent.Annotative = AnnotativeStates.[True] AndAlso ent.HasContext(cAnnoScle) = False Then
' Now we get it for write
ent.UpgradeOpen()
ent.AddContext(cAnnoScle)
If pResult.StringResult = "Yes" Then
For Each oc As ObjectContext In dwgAnnoScle
If ent.HasContext(oc) AndAlso oc.Name <> db.Cannoscale.Name Then
' Remove it non-current scale
ent.RemoveContext(oc)
End If
Next
End If
End If
Next 'process attributes
Dim attCol As AttributeCollection = blkRef.AttributeCollection
For Each attId As ObjectId In attCol
Dim attRef As AttributeReference = DirectCast(tr.GetObject(attId, OpenMode.ForRead), AttributeReference)
'check if annotative and does not have current anno state
If attRef.Annotative = AnnotativeStates.[True] AndAlso attRef.HasContext(cAnnoScle) = False Then
attRef.UpgradeOpen()
' Add Cannoscale
attRef.AddContext(cAnnoScle)
' Remove it non-current scales
If pResult.StringResult = "Yes" Then
For Each oc As ObjectContext In dwgAnnoScle
If attRef.HasContext(oc) AndAlso oc.Name <> db.Cannoscale.Name Then
attRef.RemoveContext(oc)
End If
Next
End If
End If
Next
'process annotative blocks
'check if annotative and does not have current anno state
ElseIf blkRef.Annotative = AnnotativeStates.[True] AndAlso blkRef.HasContext(cAnnoScle) = False Then
blkRef.UpgradeOpen()
blkRef.AddContext(cAnnoScle)
If pResult.StringResult = "Yes" Then
For Each oc As ObjectContext In dwgAnnoScle
If blkRef.HasContext(oc) AndAlso oc.Name <> db.Cannoscale.Name Then
blkRef.RemoveContext(oc)
End If
Next
End If
End If
Else
'process all other annotative blocks
Dim annoObj As DBObject = tr.GetObject(selObjectID, OpenMode.ForRead)
If annoObj.Annotative = AnnotativeStates.[True] AndAlso annoObj.HasContext(cAnnoScle) = False Then
annoObj.UpgradeOpen()
annoObj.AddContext(CurAScale)
If pResult.StringResult = "Yes" Then
For Each oc As ObjectContext In dwgAnnoScle
If annoObj.HasContext(oc) AndAlso oc.Name <> db.Cannoscale.Name Then
annoObj.RemoveContext(oc)
End If
Next
End If
End If
End If
Next
tr.Commit()
Catch ex As Autodesk.AutoCAD.Runtime.Exception
ed.WriteMessage(("Exception: " + ex.Message))
Finally
tr.Dispose()
End Try
End Sub
Public Shared Function CurAScale(Optional ByVal collection As Boolean = False) 'As ObjectContext
Dim db As Database = Application.DocumentManager.MdiActiveDocument.Database
' Get the manager object and the list of scales
Dim ocm As ObjectContextManager = db.ObjectContextManager
Dim occ As ObjectContextCollection = ocm.GetContextCollection("ACDB_ANNOTATIONSCALES")
If Not occ.HasContext(db.Cannoscale.Name) Then
DialMessExcep.OKException(vbLf & "Cannot find current annotation scale.")
Return Nothing
ElseIf collection = True Then
Return occ
Else
Dim curCtxt As ObjectContext = occ.GetContext(db.Cannoscale.Name)
Return curCtxt
End If
End Function
End Class
