TheSwamp
Code Red => .NET => Topic started by: ReneRam on January 10, 2008, 08:37:45 AM
-
Hello everybody,
I'm upgrading some VBA macros for AutoCAD 2004 to .Net in AutoCAD 2008, but I'm having some problems with the Hatch Object.
I've noticed that AutoCAD in the managed environment of Visual Studio 2005 builds the Hatch but some properties are not working.
The PatternScale and The PatternAngle are created with my values, but the display of those objects is not correct. If I check them
through the properties tool or even with a simple "LIST" command, the values are correct but they don't reflect the display.
If I change those values in the editor and reset them as to my values then I get the correct display.
Another thing that's not working correctly is the Area property, that returns always "eInvalidInput" when reading it in the development
environment.
I'm wondering if ti's a bug or if my code is wrong, any help, corrections or hints is appreciated.
Following I'm posting the body of a sample application that recreates the problems.
I'm also attaching the project made for this post, just in case any wants to test it.
Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.EditorInput
Public Class reneramClass
' Define command HatchTestA - Square Inside Square with Area = 300
<CommandMethod("HatchTestA")> _
Public Sub HatchTestA()
Dim myPoints As New Geometry.Point3dCollection
' Set the points of a 20,20 square
myPoints.Add(New Geometry.Point3d(0, 0, 0))
myPoints.Add(New Geometry.Point3d(20, 0, 0))
myPoints.Add(New Geometry.Point3d(20, 20, 0))
myPoints.Add(New Geometry.Point3d(0, 20, 0))
' Add the 1st square to the drawing
AddPolyline(myPoints)
myPoints.Clear()
' Set the points for an internal 10,10 square
myPoints.Add(New Geometry.Point3d(5, 5, 0))
myPoints.Add(New Geometry.Point3d(15, 5, 0))
myPoints.Add(New Geometry.Point3d(15, 15, 0))
myPoints.Add(New Geometry.Point3d(5, 15, 0))
' Add the 2nd square to the drawing
AddPolyline(myPoints)
' Create the Hatch
Dim mySS As Autodesk.AutoCAD.EditorInput.SelectionSet
mySS = SSLayer("0")
' Start debug here:
' Hatch(Area Is 300)
' Hatch Representation is not correct:
' Pattern Scale is "1" but looking in the properties through the editor
' it's reported as "0.5"
' Patern Angle is "0" but looking n the properties through the editor
' it's reported as "58"
AddHatch(mySS, , 0.5, 45.0, , True)
End Sub
' Define command HatchTestB - Square Intersecting Square with Area = 400
<CommandMethod("HatchTestB")> _
Public Sub HatchTestB()
Dim myPoints As New Geometry.Point3dCollection
' Set the points of a 20,20 square
myPoints.Add(New Geometry.Point3d(0, 0, 0))
myPoints.Add(New Geometry.Point3d(20, 0, 0))
myPoints.Add(New Geometry.Point3d(20, 20, 0))
myPoints.Add(New Geometry.Point3d(0, 20, 0))
' Add the 1st square to the drawing
AddPolyline(myPoints)
myPoints.Clear()
' Set the points for an intersecting 10,10 square
myPoints.Add(New Geometry.Point3d(15, 5, 0))
myPoints.Add(New Geometry.Point3d(25, 5, 0))
myPoints.Add(New Geometry.Point3d(25, 15, 0))
myPoints.Add(New Geometry.Point3d(15, 15, 0))
' Add the 2nd square to the drawing
AddPolyline(myPoints)
' Create the Hatch
Dim mySS As Autodesk.AutoCAD.EditorInput.SelectionSet
mySS = SSLayer("0")
' Start debug here:
' Hatch(Area Is 400)
' Hatch Representation is not correct:
' Pattern Scale is "1" but looking in the properties through the editor
' it's reported as "0.5"
' Patern Angle is "0" but looking n the properties through the editor
' it's reported as "58"
AddHatch(mySS, , 0.5, 45.0, , True)
End Sub
' Define command HatchTestC - Two separate Squares with total Area = 500
<CommandMethod("HatchTestC")> _
Public Sub HatchTestC()
Dim myPoints As New Geometry.Point3dCollection
' Set the points of a 20,20 square
myPoints.Add(New Geometry.Point3d(0, 0, 0))
myPoints.Add(New Geometry.Point3d(20, 0, 0))
myPoints.Add(New Geometry.Point3d(20, 20, 0))
myPoints.Add(New Geometry.Point3d(0, 20, 0))
' Add the 1st square to the drawing
AddPolyline(myPoints)
myPoints.Clear()
' Set the points for an external 10,10 square
myPoints.Add(New Geometry.Point3d(35, 5, 0))
myPoints.Add(New Geometry.Point3d(45, 5, 0))
myPoints.Add(New Geometry.Point3d(45, 15, 0))
myPoints.Add(New Geometry.Point3d(35, 15, 0))
' Add the 2nd square to the drawing
AddPolyline(myPoints)
' Create the Hatch
Dim mySS As Autodesk.AutoCAD.EditorInput.SelectionSet
mySS = SSLayer("0")
' Start debug here:
' Hatch(Area Is 500)
' Hatch Representation is not correct:
' Pattern Scale is "1" but looking in the properties through the editor
' it's reported as "0.5"
' Patern Angle is "0" but looking n the properties through the editor
' it's reported as "58"
AddHatch(mySS, , 0.5, 45.0, , True)
End Sub
' Add a Polyline
Sub AddPolyline(ByVal PlinePoints As Geometry.Point3dCollection)
Dim myTransMan As DatabaseServices.TransactionManager
Dim myTrans As DatabaseServices.Transaction
Dim myDWG As ApplicationServices.Document
Dim myBT As DatabaseServices.BlockTable
Dim myBTR As DatabaseServices.BlockTableRecord
'Get the active document and begin a Transaction
myDWG = ApplicationServices.Application.DocumentManager.MdiActiveDocument
myTransMan = myDWG.TransactionManager
myTrans = myTransMan.StartTransaction
'Open the BlockTable for Read
myBT = myDWG.Database.BlockTableId.GetObject( _
DatabaseServices.OpenMode.ForRead)
myBTR = myBT(DatabaseServices.BlockTableRecord.ModelSpace).GetObject( _
DatabaseServices.OpenMode.ForWrite)
' Draw the Polyline
Dim myPLine As New DatabaseServices.Polyline2d(Poly2dType.SimplePoly, _
PlinePoints, 0, True, 0, 0, Nothing)
myBTR.AppendEntity(myPLine)
myTrans.AddNewlyCreatedDBObject(myPLine, True)
'Commit the Transaction
myTrans.Commit()
myTrans.Dispose()
myTransMan.Dispose()
End Sub
' Add a Hatch
Sub AddHatch(ByVal HatchLoops As Autodesk.AutoCAD.EditorInput.SelectionSet, _
Optional ByVal HatchPattern As String = "ANSI31", _
Optional ByVal HatchScale As Double = 1, _
Optional ByVal HatchAngle As Double = 0, _
Optional ByVal ACIColor As Short = 256, _
Optional ByVal HatchIsAssociative As Boolean = True)
Dim myDB As DatabaseServices.Database
Dim myDWG As ApplicationServices.Document
Dim myTrans As Transaction
Dim myTransMan As DatabaseServices.TransactionManager
Dim myEd As EditorInput.Editor
Dim myObjIds As DatabaseServices.ObjectIdCollection
Dim myObjId As DatabaseServices.ObjectId
Dim myBT As DatabaseServices.BlockTable
Dim myBTR As DatabaseServices.BlockTableRecord
Dim myHatch As Hatch 'the hatch object
Dim myHatchLoops As ObjectIdCollection ' collection of IDs of the hatch loops
Dim HatchArea As Double 'place holder for messagebox
myDWG = ApplicationServices.Application.DocumentManager.MdiActiveDocument
myTransMan = myDWG.TransactionManager
myTrans = myTransMan.StartTransaction
myDB = myDWG.Database
myEd = myDWG.Editor
' Get the IDs of the hatch loops
myObjIds = New ObjectIdCollection(HatchLoops.GetObjectIds)
' build the hatch
Try
' open the block table for read
myBT = myTrans.GetObject(myDB.BlockTableId, OpenMode.ForRead)
' create block table record for write
myBTR = myTrans.GetObject(myBT(BlockTableRecord.ModelSpace), OpenMode.ForWrite)
' create the hatch
myHatch = New Autodesk.AutoCAD.DatabaseServices.Hatch
' add newly created hatch to block table record
myBTR.AppendEntity(myHatch)
' add the hatch BTR to the BT
myTrans.AddNewlyCreatedDBObject(myHatch, True)
' set hatch properties
' Pattern
myHatch.SetHatchPattern(HatchPatternType.PreDefined, HatchPattern)
' Hatch Pattern Scale
myHatch.PatternScale = HatchScale
' Hatch Pattern Angle
myHatch.PatternAngle = HatchAngle
' Color
myHatch.ColorIndex = CInt(ACIColor)
myHatch.Normal = New Geometry.Vector3d(0, 0, 1)
myHatch.Elevation = 0.0
' Hatch is Associative
If HatchIsAssociative Then
myHatch.Associative = True ' hatch is associative
End If
' append hatch loops
For Each myObjId In myObjIds
myHatchLoops = New ObjectIdCollection
myHatchLoops.Add(myObjId)
myHatch.AppendLoop(HatchLoopTypes.Default, myHatchLoops)
Next
' Update the newly created hatch
myHatch.EvaluateHatch(False)
'Get the Hatch Area
' Comment the following line when testing Hatch Scale
HatchArea = myHatch.Area '<= eInvalidInput error
myTrans.Commit()
myBT.Dispose()
myBTR.Dispose()
Catch ex As System.Exception
MsgBox(ex.Message) '<= eInvalidInput Message
' Add the hatch in any case
myTrans.Commit()
Finally
myEd.Regen()
myTrans.Dispose()
myTransMan.Dispose()
End Try
' Display Hatch Area
MsgBox(HatchArea, MsgBoxStyle.Information, "Hatch Area")
End Sub
' Get SelectionSet of a Layer
Function SSLayer(ByVal LayerName As String) As EditorInput.SelectionSet
Dim myDB As DatabaseServices.Database
Dim myDWG As ApplicationServices.Document
Dim myTrans As Transaction
Dim myTransMan As DatabaseServices.TransactionManager
Dim myEd As EditorInput.Editor
Dim myPSR As EditorInput.PromptSelectionResult
Dim myFilter(0) As DatabaseServices.TypedValue
myFilter(0) = New DatabaseServices.TypedValue( _
DatabaseServices.DxfCode.LayerName, LayerName)
Dim mySF As New EditorInput.SelectionFilter(myFilter)
myDWG = ApplicationServices.Application.DocumentManager.MdiActiveDocument
myTransMan = myDWG.TransactionManager
myTrans = myTransMan.StartTransaction
myDB = myDWG.Database
myEd = myDWG.Editor
myPSR = myEd.SelectAll(mySF)
SSLayer = myPSR.Value
myTrans.Commit()
myTrans.Dispose()
myTransMan.Dispose()
Return SSLayer
End Function
End Class
Thanks in advance for any help!
René
-
Welcome to theswamp Rene. I haven't learned the hatch object in .Net yet, but Im sure someone who has will be along soon
-
Just an update, I still haven't solved the issue, but i found this:
http://usa.autodesk.com/adsk/servlet/ps/item?siteID=123112&id=2895532&linkID=9240617 (http://usa.autodesk.com/adsk/servlet/ps/item?siteID=123112&id=2895532&linkID=9240617)
in the Autocad Service and Support site. It states that it afects only AutoCAD 2000-2002, but in my Auocad 2008 and in the beta of 2009, I still have the same result.
René
-
I wrote a little workaround to part of the problem:
it concerns only the Pattern display problems, it's what I call a dirty solution, but at the moment it fits.
I'm calling a small external LISP function:
(defun updHtch ()
(setq SS (ssget "x" '((0 . "HATCH"))))
(setq cnt (sslength SS))
(setq cnt1 0)
(while (< cnt1 cnt)
(setq ent (ssname SS cnt1))
(setq Vlent (vlax-ename->vla-object ent))
(if (vlax-property-available-p Vlent 'PatternScale)
(progn
(setq pscale (vla-get-PatternScale Vlent))
(vlax-put-property Vlent 'PatternScale pscale)
(vlax-invoke Vlent 'Evaluate)
)
)
(setq cnt1 (+ 1 cnt1))
)
(command "_regen")
(princ)
)
Sorry I didn't add comments but if anyone needs I'll put down some.
I'm also posting an updated version of the Visual Studio Project.
-
Hi René, Welcome to TheSwamp. :-)
Sorry I couldn’t be of help, I read VB about as well I read tea leaves. :oops:
Thanks for sharing your solution
-
Does the problem happen with polylines (I notice you use 2dpolies)
Does the area work after the hatch has been committed.
(Sorry i dont have a vb editor)
-
Yes, the problem happens in any case, that's why I thought it could be my error, Maybe there's a better way to create the hatch, but in the program that I'm developing I can select a hatch object created with AutoCAD environment normally, not programming, and when modifying it or trying to retrieve the area I get the same kind of problem: "eInvalidInput" when reading the area and pattern display not updated when changed.
I'm wondering if it's a wrong approach to the problem or if it's just that "acmgd.dll" simply doesn't support completely the object.
Maybe there are developers that use ObjectArx in C++ that interact directly with the API that don't have this kind of problem, but I don't have that knowledge. I've posted the question of the "Area" in the ".Net" discussion group of Autodesk, but with no replies. I guess the problem is only mine or nobody has found a solution 'till now.
In any case I'm still trying to figure out a solution and as soon I get one I'll post it here as a memory to others.
Does the problem happen with polylines (I notice you use 2dpolies)
Does the area work after the hatch has been committed.
(Sorry i dont have a vb editor)
In any case, after the hatch has been created with my sample, as I said in my first post, you can simply "list" it to read the area.
Here's the code.
Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.EditorInput
Public Class reneramClass
' Define command HatchTestA - Square Inside Square with Area = 300
<CommandMethod("HatchTestA")> _
Public Sub HatchTestA()
Dim myPoints As New Geometry.Point3dCollection
' Set the points of a 20,20 square
myPoints.Add(New Geometry.Point3d(0, 0, 0))
myPoints.Add(New Geometry.Point3d(20, 0, 0))
myPoints.Add(New Geometry.Point3d(20, 20, 0))
myPoints.Add(New Geometry.Point3d(0, 20, 0))
' Add the 1st square to the drawing
AddPolyline(myPoints)
myPoints.Clear()
' Set the points for an internal 10,10 square
myPoints.Add(New Geometry.Point3d(5, 5, 0))
myPoints.Add(New Geometry.Point3d(15, 5, 0))
myPoints.Add(New Geometry.Point3d(15, 15, 0))
myPoints.Add(New Geometry.Point3d(5, 15, 0))
' Add the 2nd square to the drawing
AddPolyline(myPoints)
' Create the Hatch
Dim mySS As Autodesk.AutoCAD.EditorInput.SelectionSet
mySS = SSLayer("0")
' Start debug here:
' Hatch(Area Is 300)
' Hatch Representation is not correct:
' Pattern Scale is "1" but looking in the properties through the editor
' it's reported as "0.5"
' Patern Angle is "0" but looking n the properties through the editor
' it's reported as "58"
AddHatch(mySS, , 0.5, 45.0, , True)
' LISP WorkAround
UpdHatchDisplay()
End Sub
' Define command HatchTestB - Square Intersecting Square with Area = 400
<CommandMethod("HatchTestB")> _
Public Sub HatchTestB()
Dim myPoints As New Geometry.Point3dCollection
' Set the points of a 20,20 square
myPoints.Add(New Geometry.Point3d(0, 0, 0))
myPoints.Add(New Geometry.Point3d(20, 0, 0))
myPoints.Add(New Geometry.Point3d(20, 20, 0))
myPoints.Add(New Geometry.Point3d(0, 20, 0))
' Add the 1st square to the drawing
AddPolyline(myPoints)
myPoints.Clear()
' Set the points for an intersecting 10,10 square
myPoints.Add(New Geometry.Point3d(15, 5, 0))
myPoints.Add(New Geometry.Point3d(25, 5, 0))
myPoints.Add(New Geometry.Point3d(25, 15, 0))
myPoints.Add(New Geometry.Point3d(15, 15, 0))
' Add the 2nd square to the drawing
AddPolyline(myPoints)
' Create the Hatch
Dim mySS As Autodesk.AutoCAD.EditorInput.SelectionSet
mySS = SSLayer("0")
' Start debug here:
' Hatch(Area Is 400)
' Hatch Representation is not correct:
' Pattern Scale is "1" but looking in the properties through the editor
' it's reported as "0.5"
' Patern Angle is "0" but looking n the properties through the editor
' it's reported as "58"
AddHatch(mySS, , 0.5, 45.0, , True)
' LISP WorkAround
UpdHatchDisplay()
End Sub
' Define command HatchTestC - Two separate Squares with total Area = 500
<CommandMethod("HatchTestC")> _
Public Sub HatchTestC()
Dim myPoints As New Geometry.Point3dCollection
' Set the points of a 20,20 square
myPoints.Add(New Geometry.Point3d(0, 0, 0))
myPoints.Add(New Geometry.Point3d(20, 0, 0))
myPoints.Add(New Geometry.Point3d(20, 20, 0))
myPoints.Add(New Geometry.Point3d(0, 20, 0))
' Add the 1st square to the drawing
AddPolyline(myPoints)
myPoints.Clear()
' Set the points for an external 10,10 square
myPoints.Add(New Geometry.Point3d(35, 5, 0))
myPoints.Add(New Geometry.Point3d(45, 5, 0))
myPoints.Add(New Geometry.Point3d(45, 15, 0))
myPoints.Add(New Geometry.Point3d(35, 15, 0))
' Add the 2nd square to the drawing
AddPolyline(myPoints)
' Create the Hatch
Dim mySS As Autodesk.AutoCAD.EditorInput.SelectionSet
mySS = SSLayer("0")
' Start debug here:
' Hatch(Area Is 500)
' Hatch Representation is not correct:
' Pattern Scale is "1" but looking in the properties through the editor
' it's reported as "0.5"
' Patern Angle is "0" but looking n the properties through the editor
' it's reported as "58"
AddHatch(mySS, , 0.5, 45.0, , True)
' LISP WorkAround
UpdHatchDisplay()
End Sub
' Add a Polyline
Sub AddPolyline(ByVal PlinePoints As Geometry.Point3dCollection)
Dim myTransMan As DatabaseServices.TransactionManager
Dim myTrans As DatabaseServices.Transaction
Dim myDWG As ApplicationServices.Document
Dim myBT As DatabaseServices.BlockTable
Dim myBTR As DatabaseServices.BlockTableRecord
'Get the active document and begin a Transaction
myDWG = ApplicationServices.Application.DocumentManager.MdiActiveDocument
myTransMan = myDWG.TransactionManager
myTrans = myTransMan.StartTransaction
'Open the BlockTable for Read
myBT = myDWG.Database.BlockTableId.GetObject( _
DatabaseServices.OpenMode.ForRead)
myBTR = myBT(DatabaseServices.BlockTableRecord.ModelSpace).GetObject( _
DatabaseServices.OpenMode.ForWrite)
' Draw the Polyline
Dim myPLine As New DatabaseServices.Polyline2d(Poly2dType.SimplePoly, _
PlinePoints, 0, True, 0, 0, Nothing)
myBTR.AppendEntity(myPLine)
myTrans.AddNewlyCreatedDBObject(myPLine, True)
'Commit the Transaction
myTrans.Commit()
myTrans.Dispose()
myTransMan.Dispose()
End Sub
' Add a Hatch
Sub AddHatch(ByVal HatchLoops As Autodesk.AutoCAD.EditorInput.SelectionSet, _
Optional ByVal HatchPattern As String = "ANSI31", _
Optional ByVal HatchScale As Double = 1, _
Optional ByVal HatchAngle As Double = 0, _
Optional ByVal ACIColor As Short = 256, _
Optional ByVal HatchIsAssociative As Boolean = True)
Dim myDB As DatabaseServices.Database
Dim myDWG As ApplicationServices.Document
Dim myTrans As Transaction
Dim myTransMan As DatabaseServices.TransactionManager
Dim myEd As EditorInput.Editor
Dim myObjIds As DatabaseServices.ObjectIdCollection
Dim myObjId As DatabaseServices.ObjectId
Dim myBT As DatabaseServices.BlockTable
Dim myBTR As DatabaseServices.BlockTableRecord
Dim myHatch As Hatch 'the hatch object
Dim myHatchLoops As ObjectIdCollection ' collection of IDs of the hatch loops
Dim HatchArea As Double 'place holder for messagebox
' Angle must be Updated to current units
Dim strHtcAngle As String = CStr(HatchAngle)
HatchAngle = Converter.StringToAngle(strHtcAngle, AngularUnitFormat.Current)
myDWG = ApplicationServices.Application.DocumentManager.MdiActiveDocument
myTransMan = myDWG.TransactionManager
myTrans = myTransMan.StartTransaction
myDB = myDWG.Database
myEd = myDWG.Editor
' Get the IDs of the hatch loops
myObjIds = New ObjectIdCollection(HatchLoops.GetObjectIds)
' build the hatch
Try
' open the block table for read
myBT = myTrans.GetObject(myDB.BlockTableId, OpenMode.ForRead)
' create block table record for write
myBTR = myTrans.GetObject(myBT(BlockTableRecord.ModelSpace), OpenMode.ForWrite)
' create the hatch
myHatch = New Autodesk.AutoCAD.DatabaseServices.Hatch
' add newly created hatch to block table record
myBTR.AppendEntity(myHatch)
' add the hatch BTR to the BT
myTrans.AddNewlyCreatedDBObject(myHatch, True)
' set hatch properties
' Pattern
myHatch.SetHatchPattern(HatchPatternType.PreDefined, HatchPattern)
' Hatch Pattern Scale
myHatch.PatternScale = HatchScale
' Hatch Pattern Angle
myHatch.PatternAngle = HatchAngle
' Color
myHatch.ColorIndex = CInt(ACIColor)
myHatch.Normal = New Geometry.Vector3d(0, 0, 1)
myHatch.Elevation = 0.0
' Hatch is Associative
If HatchIsAssociative Then
myHatch.Associative = True ' hatch is associative
End If
' append hatch loops
For Each myObjId In myObjIds
myHatchLoops = New ObjectIdCollection
myHatchLoops.Add(myObjId)
myHatch.AppendLoop(HatchLoopTypes.Default, myHatchLoops)
Next
' Update the newly created hatch
myHatch.EvaluateHatch(False)
'Get the Hatch Area
' Comment the following line when testing Hatch Scale
HatchArea = myHatch.Area '<= eInvalidInput error
myTrans.Commit()
myBT.Dispose()
myBTR.Dispose()
Catch ex As System.Exception
MsgBox(ex.Message) '<= eInvalidInput Message
' Add the hatch in any case
myTrans.Commit()
Finally
myEd.Regen()
myTrans.Dispose()
myTransMan.Dispose()
End Try
' Display Hatch Area
MsgBox(HatchArea, MsgBoxStyle.Information, "Hatch Area")
End Sub
' Get SelectionSet of a Layer
Function SSLayer(ByVal LayerName As String) As EditorInput.SelectionSet
Dim myDB As DatabaseServices.Database
Dim myDWG As ApplicationServices.Document
Dim myTrans As Transaction
Dim myTransMan As DatabaseServices.TransactionManager
Dim myEd As EditorInput.Editor
Dim myPSR As EditorInput.PromptSelectionResult
Dim myFilter(0) As DatabaseServices.TypedValue
myFilter(0) = New DatabaseServices.TypedValue( _
DatabaseServices.DxfCode.LayerName, LayerName)
Dim mySF As New EditorInput.SelectionFilter(myFilter)
myDWG = ApplicationServices.Application.DocumentManager.MdiActiveDocument
myTransMan = myDWG.TransactionManager
myTrans = myTransMan.StartTransaction
myDB = myDWG.Database
myEd = myDWG.Editor
myPSR = myEd.SelectAll(mySF)
SSLayer = myPSR.Value
myTrans.Commit()
myTrans.Dispose()
myTransMan.Dispose()
Return SSLayer
End Function
' Update Hatch Display - Workaround in LISP
Sub UpdHatchDisplay()
Dim myDWG As ApplicationServices.Document
Dim myTrans As Transaction
Dim myTransMan As DatabaseServices.TransactionManager
Dim myEd As EditorInput.Editor
myDWG = ApplicationServices.Application.DocumentManager.MdiActiveDocument
myTransMan = myDWG.TransactionManager
myTrans = myTransMan.StartTransaction
myEd = myDWG.Editor
Dim cmdString As String
cmdString = "(load " & Chr(34) & _
"C:/Temp/UpdHatch.lsp" & _
Chr(34) & ") (updHtch) "
' Run Lisp patch
myDWG.SendStringToExecute(cmdString, True, False, False)
myTrans.Commit()
myTrans.Dispose()
myTransMan.Dispose()
End Sub
End Class
René
-
Try this quick example, tested on A2008eng only
Public Sub MakeHatch()
Dim db As Database = HostApplicationServices.WorkingDatabase
Dim adoc As Document = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument
Dim doclock As DocumentLock = adoc.LockDocument
adoc.LockDocument(DocumentLockMode.Write, Nothing, Nothing, True)
Using tr As Transaction = db.TransactionManager.StartTransaction
Dim ed As Editor = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument.Editor
Try
Dim res As PromptEntityResult = ed.GetEntity(ControlChars.Lf & "Select entity to be hatch:")
If res.Status <> PromptStatus.OK Then
Return
End If
Dim ent As Entity = tr.GetObject(res.ObjectId, OpenMode.ForRead, False)
Dim ids As ObjectIdCollection = New ObjectIdCollection
ids.Add(res.ObjectId)
Dim hatchType As HatchPatternType = New Autodesk.AutoCAD.DatabaseServices.HatchPatternType
Dim patName As String = "ANSI32"
hatchType = CType(Autodesk.AutoCAD.DatabaseServices.HatchPatternType.PreDefined, Integer)
Dim btr As BlockTableRecord = CType(tr.GetObject(db.CurrentSpaceId, OpenMode.ForWrite), BlockTableRecord)
Dim hatchObj As New Hatch
btr.AppendEntity(hatchObj)
tr.AddNewlyCreatedDBObject(hatchObj, True)
With hatchObj
.UpgradeOpen()
.HatchStyle = Autodesk.AutoCAD.DatabaseServices.HatchStyle.Outer
.Associative = True
.Layer = "0"
.ColorIndex = 34
.PatternAngle = Math.PI / 2
.PatternScale = 250.0
.PatternSpace = 250.0
' keep this order to set pattern at the end!
.SetHatchPattern(hatchType, patName)
.DowngradeOpen()
End With
hatchObj.AppendLoop(HatchLoopTypes.External, ids)
hatchObj.EvaluateHatch(True)
ed.Regen()
tr.Commit()
Catch ex As Autodesk.AutoCAD.Runtime.Exception
ed.WriteMessage(ex.StackTrace)
Finally
tr.Dispose()
End Try
End Using
doclock.Dispose()
End Sub
-
Very Clever,
thanks a lot your code works perfectly. I see that my error was in the order of assigning and evaluating the properties and the loops to the hatch object.
I noticed that you specified that the loops are External. A further question, just to clarify a doubt. Reading the ObjectArx documentation I found that the loops specified as Default are:
The loop type hasn't been specified yet. It turns to a "real" value as soon as some real loops get created
and coming from VBA development I thought the value simply updated by it self, a I wrong?
René
-
Hi René,
here is this example from ObjectARX documentation
you had talking about
It will works with newly created objects both external
contour and inner islands
As you could see it will work without SetDefaults:
Sub addhatch()
Dim doc As Document = AcApp.DocumentManager.MdiActiveDocument
Dim docklock As DocumentLock = doc.LockDocument()
Dim db As Database = HostApplicationServices.WorkingDatabase()
Dim ed As Editor = Application.DocumentManager.MdiActiveDocument.Editor()
Dim tr As Transaction = db.TransactionManager.StartTransaction
Dim btr As BlockTableRecord = CType(tr.GetObject(db.CurrentSpaceId, OpenMode.ForWrite), BlockTableRecord)
Dim pHatch As New Hatch
btr.AppendEntity(pHatch)
tr.AddNewlyCreatedDBObject(pHatch, True)
'Set hatch plane, normal, elevation
Dim norm As Vector3d = New Vector3d(0.0, 0.0, 1.0)
pHatch.Normal = norm
pHatch.Elevation = 0.0
'Set hatch pattern to ANSI31 predefined type
pHatch.SetHatchPattern(HatchPatternType.PreDefined, "ANSI31")
'Set Associativity
pHatch.Associative = True
'Construct database AcDbLines
Dim vertexPts(3) As Point3d
'Dim lineId As ObjectId, cirId As ObjectId, hatchId As ObjectId
Dim dbObjIds As ObjectIdCollection = New ObjectIdCollection
Dim line As Line
vertexPts(0) = New Point3d(2.0, 2.0, 0.0)
vertexPts(1) = New Point3d(8.0, 2.0, 0.0)
vertexPts(2) = New Point3d(8.0, 8.0, 0.0)
vertexPts(3) = New Point3d(2.0, 8.0, 0.0)
For i As Integer = 0 To 3
line = New Line
line.StartPoint = vertexPts(i)
If i = 3 Then
line.EndPoint = vertexPts(0)
Else
line.EndPoint = vertexPts(i + 1)
End If
btr.AppendEntity(line)
tr.AddNewlyCreatedDBObject(line, True)
dbObjIds.Add(line.ObjectId)
Next
'Append an external rectangular loop to hatch boundary
pHatch.AppendLoop(HatchLoopTypes.External, dbObjIds)
'Create a AcDbCircle and post it to database
Dim cenPt As Point3d = New Point3d(5.0, 5.0, 0.0)
Dim cnorm As Vector3d = New Vector3d(0.0, 0.0, 1.0)
Dim circle As Circle = New Circle()
circle.Normal = cnorm
circle.Center = cenPt
circle.Radius = 1.0
btr.AppendEntity(circle)
tr.AddNewlyCreatedDBObject(circle, True)
dbObjIds.Clear()
dbObjIds.Add(circle.ObjectId)
'Append an internal loop (circle) to hatch boundary
pHatch.AppendLoop(HatchLoopTypes.Default, dbObjIds)
'Elaborate hatch lines
pHatch.EvaluateHatch(True)
'// here was omitted the part of code about [b]setPersistenRactor[/b] method
'// I don't know how to use this method in pure VB.NET
tr.Commit()
End Sub
Another one will works with already created objects
just select at the first the contour object and then
all the inner islands inside:
Public Shared Sub MakeHatch()
Dim db As Database = HostApplicationServices.WorkingDatabase
Dim adoc As Document = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument
Dim doclock As DocumentLock = adoc.LockDocument
adoc.LockDocument(DocumentLockMode.Write, Nothing, Nothing, True)
Using tr As Transaction = db.TransactionManager.StartTransaction
Dim ed As Editor = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument.Editor
Dim res As PromptEntityResult = ed.GetEntity(ControlChars.CrLf & "Select entity to be hatch:")
If res.Status <> PromptStatus.OK Then
Return
End If
Dim eds As ObjectIdCollection = SelectOnscreenEx()
MsgBox(eds.Count.ToString)
Dim ent As Entity = tr.GetObject(res.ObjectId, OpenMode.ForRead, False)
Dim ids As ObjectIdCollection = New ObjectIdCollection
ids.Add(res.ObjectId)
Dim hatchType As HatchPatternType = New Autodesk.AutoCAD.DatabaseServices.HatchPatternType
Dim patName As String = "BRICK"
hatchType = CType(Autodesk.AutoCAD.DatabaseServices.HatchPatternType.PreDefined, Integer)
Dim btr As BlockTableRecord = CType(tr.GetObject(db.CurrentSpaceId, OpenMode.ForWrite), BlockTableRecord)
Dim hatchObj As New Hatch
btr.AppendEntity(hatchObj)
tr.AddNewlyCreatedDBObject(hatchObj, True)
Dim norm As Vector3d = New Vector3d(0.0, 0.0, 1.0)
hatchObj.Normal = norm
hatchObj.Elevation = 0.0
With hatchObj
.UpgradeOpen()
.HatchStyle = Autodesk.AutoCAD.DatabaseServices.HatchStyle.Normal
.Associative = True
.Layer = "0"
.ColorIndex = 12
.PatternAngle = 0.0 'Math.PI / 2
.PatternScale = 4.0
.PatternSpace = 4.0
' keep this order to set pattern at the end!
.SetHatchPattern(hatchType, patName)
End With
hatchObj.AppendLoop(HatchLoopTypes.External, ids)
For Each id As ObjectId In eds
ids.Clear()
ids.Add(id)
hatchObj.AppendLoop(HatchLoopTypes.Default, ids)
Next
hatchObj.EvaluateHatch(True)
ed.Regen()
tr.Commit()
End Using
doclock.Dispose()
End Sub
Public Shared Function SelectOnscreenEx() As ObjectIdCollection
Dim ed As Editor = Application.DocumentManager.MdiActiveDocument.Editor
Dim dxf() As TypedValue = {New TypedValue(DxfCode.Start, "*")}
Dim filt As New SelectionFilter(dxf)
Dim opts As PromptSelectionOptions = New PromptSelectionOptions
opts.MessageForAdding = ControlChars.CrLf & "Select the inner islands:"
opts.AllowDuplicates = False
opts.SingleOnly = False
Dim res As PromptSelectionResult = ed.GetSelection(opts, filt)
If res.Status <> PromptStatus.OK Then
Return Nothing
End If
Dim sset As SelectionSet = res.Value
Dim IDs() As ObjectId = sset.GetObjectIds
Dim idcol = New ObjectIdCollection
For Each id As ObjectId In IDs
idcol.Add(id)
Next
Return idcol
End Function
Sorry I can't explain you more, that's
out of my C++ skills, but I hope it will helps
Of course this was written too quickly as the
my prior code above, by this reason test it by yourself
extensively
Happy computing :)
~'J'~