Ok, I've run into a small problem. If I have the TraceBoundary function set to detect islands, I get an error that says eInvalidInput. The crash only happens if it does detect an island. I'm wondering if maybe it is because there would be two polylines returned by the TraceBoundary function instead of one? I add all entities returned into the objectID collection and pass that on to the AppendLoop method. I'm not sure why that would crash the hatch creation, tho. I looked everywhere and couldn't find a code example that specifically handled islands. I can't step through the code to debug because I'm using VB2010 Express and none of the debugging workarounds work for me.
Thanks
Public Shared Sub Pick()
Dim doc As Document = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument
Dim db As Database = doc.Database
Dim ed As Editor = doc.Editor
Dim _index As Integer = 3
Dim acDoc As Document = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument
Dim acCurDb As Database = acDoc.Database
Dim acEditor As Editor = acDoc.Editor
Dim acBlkTbl As BlockTable
Dim tr As Transaction = doc.TransactionManager.StartTransaction()
Using tr
' add the objects to the model space
Dim bt As BlockTable = DirectCast(tr.GetObject(doc.Database.BlockTableId, OpenMode.ForRead), BlockTable)
Dim btr As BlockTableRecord = DirectCast(tr.GetObject(bt(BlockTableRecord.ModelSpace), OpenMode.ForWrite), BlockTableRecord)
Dim acSSPrompt As PromptSelectionResult
Dim acSSet As SelectionSet
Dim acPoly As Polyline = Nothing
Dim acMText As MText = Nothing
Dim acDBText As DBText = Nothing
Dim TxtLoc As Autodesk.AutoCAD.Geometry.Point3d
Dim strRoomNum As String = String.Empty
Dim acHatch As Hatch = New Hatch()
Dim frmHatch As frmHatchDetails
Dim acLyrTbl As LayerTable
Dim acLyrTblRec As LayerTableRecord
Dim acBlkTblRec As BlockTableRecord
Dim acColorNum As Integer
Dim result As DialogResult
Try
Do
acSSPrompt = acDoc.Editor.GetSelection()
If acSSPrompt.Status = PromptStatus.OK Then
acSSet = acSSPrompt.Value
Else
Return
End If
If acSSet.Count <> 1 Then
acEditor.WriteMessage("You must select only the Room Number text object to add a hatch.")
End If
Loop While acSSet.Count <> 1
For Each acSSObj As SelectedObject In acSSet
If Not IsDBNull(acSSObj) Then
Dim acObj As DBObject = tr.GetObject(acSSObj.ObjectId, OpenMode.ForRead)
If TypeOf (acObj) Is Polyline Then
acPoly = CType(acObj, Polyline)
ElseIf TypeOf (acObj) Is MText Then
acMText = CType(acObj, MText)
TxtLoc = acMText.Location
strRoomNum = acMText.Text
ElseIf TypeOf (acObj) Is DBText Then
acDBText = CType(acObj, DBText)
TxtLoc = acDBText.Position
strRoomNum = acDBText.TextString
End If
End If
Next
'create/retrieve layer
acLyrTbl = tr.GetObject(acCurDb.LayerTableId, OpenMode.ForRead)
If acLyrTbl.Has("A-ROOM") = False Then
acLyrTblRec = New LayerTableRecord()
'' Assign the layer a name
acLyrTblRec.Name = "A-ROOM"
'' Upgrade the Layer table for write
acLyrTbl.UpgradeOpen()
'' Append the new layer to the Layer table and the transaction
acLyrTbl.Add(acLyrTblRec)
tr.AddNewlyCreatedDBObject(acLyrTblRec, True)
acLyrTblRec.IsOff = True
End If
' Get the objects making up the boundary
Dim objs As DBObjectCollection = ed.TraceBoundary(TxtLoc, True)
' Add boundary objects to the drawing and
' collect their ObjectObjIDCol for later use
Dim ObjIDCol As New ObjectIdCollection()
For Each acobj As DBObject In objs
Dim ent As Entity = TryCast(acobj, Entity)
If ent IsNot Nothing Then
If Not acLyrTbl.Has("RM") Then
If TypeOf (acobj) Is Polyline Then
acLyrTblRec = New LayerTableRecord()
'' Assign the layer a name
acLyrTblRec.Name = "RM"
'' Upgrade the Layer table for write
acLyrTbl.UpgradeOpen()
'' Append the new layer to the Layer table and the transaction
acLyrTbl.Add(acLyrTblRec)
tr.AddNewlyCreatedDBObject(acLyrTblRec, True)
acPoly = CType(acobj, Polyline)
acPoly.Layer = "RM"
End If
Else
acLyrTblRec = tr.GetObject(acLyrTbl("RM"), OpenMode.ForWrite)
acLyrTblRec.IsOff = False
End If
' Add each boundary object to the modelspace
' and add its ID to a collection
ObjIDCol.Add(btr.AppendEntity(ent))
tr.AddNewlyCreatedDBObject(ent, True)
End If
Next
acHatch.SetHatchPattern(HatchPatternType.PreDefined, "SOLID")
acHatch.ColorIndex = System.Math.Max(System.Threading.Interlocked.Increment(_index), _index - 1)
Dim acHatchId As ObjectId = btr.AppendEntity(acHatch)
tr.AddNewlyCreatedDBObject(acHatch, True)
If Not acLyrTbl.Has("DC-" & strRoomNum) Then
acLyrTblRec = New LayerTableRecord()
'' Assign the layer a name
acLyrTblRec.Name = "DC-" & strRoomNum
'' Upgrade the Layer table for write
acLyrTbl.UpgradeOpen()
'' Append the new layer to the Layer table and the transaction
acLyrTbl.Add(acLyrTblRec)
tr.AddNewlyCreatedDBObject(acLyrTblRec, True)
Else
acLyrTblRec = tr.GetObject(acLyrTbl("DC-" & strRoomNum), OpenMode.ForRead)
End If
'set associative properties of new hatch object
acHatch.SetDatabaseDefaults()
'acHatch.HatchObjectType =
acHatch.SetHatchPattern(HatchPatternType.PreDefined, "SOLID")
acHatch.Layer = "DC-" & strRoomNum
acHatch.Associative = True
acHatch.AppendLoop(HatchLoopTypes.[Default], ObjIDCol)
acHatch.EvaluateHatch(True)
btr.DowngradeOpen()
ObjIDCol.Add(acHatchId)
'this is used to send the hatch to the back so it isn't overtop of the text
Dim dot As Autodesk.AutoCAD.DatabaseServices.DrawOrderTable = tr.GetObject(btr.DrawOrderTableId, OpenMode.ForWrite)
dot.MoveToBottom(ObjIDCol)
' Commit the transaction
tr.Commit()
Catch ex As Exception
Autodesk.AutoCAD.ApplicationServices.Application.
ShowAlertDialog("An error was encountered trying to add a hatch object. Error: " & ex.Message)
End Try
End Using
End Sub
