.NET

Reply
Valued Contributor
mindofcat
Posts: 55
Registered: ‎05-14-2012
Message 1 of 4 (665 Views)
Accepted Solution

How to add a hatch pattern within rectangular boundaries in a block

665 Views, 3 Replies
02-28-2013 09:55 AM

Hi folks,

 

I am in the process of translating existing VBA code into its equivalent in VB.NET (developing VS Professional 2010 and testing in AutoCAD 2010)

 

My problem is that I have never done hatching in VB.NET before, and now I am required to hatch a rectangular area (defined by lines) within an AutoCAD block. I have absolutely no idea how to go about accomplishing this task.

 

To create my block, I am using a DBObjectCollection to store my lines, and then append them to the block definition, creating a reference to see what I just created.

 

If I were to define a rectangular outline within this block, how can I possibly hatch it?

 

Any pointers? Suggestions? Thanks in advance...

 

*Expert Elite*
Hallex
Posts: 1,569
Registered: ‎10-08-2008
Message 2 of 4 (650 Views)

Re: How to add a hatch pattern within rectangular boundaries in a block

02-28-2013 12:28 PM in reply to: mindofcat

Here is a code to crate hatch with lines

you have to select two opposite lines and create

polyline to bund the area then apply hatch

Public Sub HatchLines()

        Dim doc As Document = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument

        Dim docloc As DocumentLock = doc.LockDocument()

        Dim ed As Editor = doc.Editor

        Dim db As Database = doc.Database

        Dim tr As Transaction = db.TransactionManager.StartTransaction()

        Using docloc

            Using tr

                'ed.StartUserInteraction(Me)'<-- just in case you using this code from form button

                Dim peo As PromptEntityOptions = New PromptEntityOptions(vbCr & "Select first line: ")

                peo.SetRejectMessage(vbCr & "Select line only: ")

                peo.AddAllowedClass(GetType(Line), True)

                Dim pres As PromptEntityResult = ed.GetEntity(peo)

                If (pres.Status <> PromptStatus.OK) Then

                    Return

                End If

                Dim ent As Entity = CType(tr.GetObject(pres.ObjectId, OpenMode.ForRead), Entity)

                Dim line1 As Line = DirectCast(ent, Line)

                If line1 Is Nothing Then

                    Return

                End If

                peo.Message = vbCr & "Select second line: "

                pres = ed.GetEntity(peo)

                If (pres.Status <> PromptStatus.OK) Then

                    Return

                End If

                ent = CType(tr.GetObject(pres.ObjectId, OpenMode.ForRead), Entity)

                Dim line2 As Line = DirectCast(ent, Line)

                If line2 Is Nothing Then

                    Return

                End If

                Dim sp1 As Point3d = line1.StartPoint

                Dim ep1 As Point3d = line1.EndPoint

                Dim sp2 As Point3d = line2.StartPoint

                Dim ep2 As Point3d = line2.EndPoint

                'check for line directions
                If Math.Abs(line1.Angle - line2.Angle) >= Math.PI Then
                    'swap points if the second line has an opposite direction
                    Dim tmp As Point3d = sp1

                    sp1 = ep1

                    ep1 = tmp

                End If

                Dim btr As BlockTableRecord = CType(tr.GetObject(db.CurrentSpaceId, OpenMode.ForWrite), BlockTableRecord)

                Dim pl As Polyline = New Polyline()

                pl.AddVertexAt(0, New Point2d(sp1.X, sp1.Y), 0, 0, 0)

                pl.AddVertexAt(1, New Point2d(ep1.X, ep1.Y), 0, 0, 0)

                pl.AddVertexAt(2, New Point2d(ep2.X, ep2.Y), 0, 0, 0)

                pl.AddVertexAt(3, New Point2d(sp2.X, sp2.Y), 0, 0, 0)

                pl.Closed = True

                btr.AppendEntity(pl)

                tr.AddNewlyCreatedDBObject(pl, True)

                Dim ids As ObjectIdCollection = New ObjectIdCollection

                ids.Add(pl.ObjectId)

                db.TransactionManager.QueueForGraphicsFlush()

                Dim hatch As Hatch = New Hatch()

                hatch.HatchStyle = HatchStyle.Normal

                hatch.PatternScale = 60.0 '<--change hatch scale to suit

                hatch.PatternAngle = 0.0

                hatch.SetHatchPattern(HatchPatternType.PreDefined, "ANSI37") '<--change pattern name to suit

                hatch.AppendLoop(HatchLoopTypes.Outermost, ids)

                hatch.Associative = False

                hatch.EvaluateHatch(False)

                btr.SetObjectIdsInFlux()

                btr.AppendEntity(hatch)

                tr.AddNewlyCreatedDBObject(hatch, True)

                pl.Erase()

                pl.Dispose()

                ed.Regen()

                tr.Commit()

            End Using

        End Using

    End Sub

 You then go expand this code to your needs

_____________________________________
C6309D9E0751D165D0934D0621DFF27919
Valued Contributor
mindofcat
Posts: 55
Registered: ‎05-14-2012
Message 3 of 4 (645 Views)

Re: How to add a hatch pattern within rectangular boundaries in a block

02-28-2013 12:32 PM in reply to: Hallex

This is very good... Thanks so much, Hallex, much appreciated.

*Expert Elite*
Hallex
Posts: 1,569
Registered: ‎10-08-2008
Message 4 of 4 (637 Views)

Re: How to add a hatch pattern within rectangular boundaries in a block

02-28-2013 12:59 PM in reply to: mindofcat

Glad to help

Happy vbneting,

Cheers :smileyhappy:

_____________________________________
C6309D9E0751D165D0934D0621DFF27919

You are not logged in.

Log into access your profile, ask and answer questions, share ideas and more. Haven't signed up yet? Register

Announcements
Are you familiar with the Autodesk Expert Elites? The Expert Elite program is made up of customers that help other customers by sharing knowledge and exemplifying an engaging style of collaboration. To learn more, please visit our Expert Elite website.

Need installation help?

Start with some of our most frequented solutions to get help installing your software.

Ask the Community