Jump to content

Fixed the code to draw parallel lines with the input distance


quyenpv

Recommended Posts

I'm using vb.net language to write sub for autocad to draw plines with required option

1. the user enters the number of lines or plines to draw in the range from 1 to 12

2. Enter the distance between the lines above with a minimum of 3

3. The user selects the drawing position and direction on the current drawing, then the program will draw parallel plines with the entered distance.

4. When drawing the color of the lines, they will take the color list from 1 to 12 as follows 160 30 94 15 253 255 10 250 50 202 220 130 How to display the order of the first lines at the selected point of the next lines. will always be drawn parallel to the right of the first line with the input distance. Additional please create a Layer with the name SODODAUNOI, check in the current autocad file, if not, create a new one.

The code I wrote is misaligning the lines when the code runs again, equidistant from each other by the interval entered

<CommandMethod("DrawLines2")>
    Public Sub DrawPLines()
        Dim doc As Document = Application.DocumentManager.MdiActiveDocument
        Dim db As Database = doc.Database
        Dim ed As Editor = doc.Editor

        ' Lấy số lượng đường cần vẽ từ người dùng
        Dim numLines As Integer = GetNumberFromUser("Nhập số lượng đường (từ 1 đến 12): ", 1, 12)

        ' Lấy khoảng cách giữa các đường từ người dùng
        Dim distance As Double = GetNumberFromUser("Nhập khoảng cách giữa các đường (số nhỏ nhất là 3): ", 3, Double.MaxValue)

        ' Danh sách mã màu cho các đường
        Dim colors() As Integer = {160, 30, 94, 15, 253, 255, 10, 250, 50, 202, 220, 130}

        ' Kiểm tra nếu Layer "SODODAUNOI" chưa tồn tại, tạo mới
        If Not LayerExists("SODODAUNOI") Then
            CreateLayer("SODODAUNOI")
        End If

        Using trans As Transaction = db.TransactionManager.StartTransaction()
            Dim btr As BlockTableRecord = trans.GetObject(db.CurrentSpaceId, OpenMode.ForWrite)

            ' Vẽ đường thứ nhất
            Dim startPoint As New Point3d(0, 0, 0)
            Dim endPoint As New Point3d(distance, 0, 0)
            Dim pLine As New Polyline()
            pLine.AddVertexAt(0, New Point2d(startPoint.X, startPoint.Y), 0, 0, 0)
            pLine.AddVertexAt(1, New Point2d(endPoint.X, endPoint.Y), 0, 0, 0)

            pLine.ColorIndex = colors(0)
            pLine.Layer = "SODODAUNOI"
            btr.AppendEntity(pLine)
            trans.AddNewlyCreatedDBObject(pLine, True)

            ' Vẽ các đường tiếp theo
            For i As Integer = 1 To numLines - 1
                startPoint = New Point3d(startPoint.X + distance, startPoint.Y, startPoint.Z)
                endPoint = New Point3d(endPoint.X + distance, endPoint.Y, endPoint.Z)
                pLine = New Polyline()
                pLine.AddVertexAt(0, New Point2d(startPoint.X, startPoint.Y), 0, 0, 0)
                pLine.AddVertexAt(1, New Point2d(endPoint.X, endPoint.Y), 0, 0, 0)
                pLine.ColorIndex = colors(i Mod colors.Length)
                pLine.Layer = "SODODAUNOI"
                btr.AppendEntity(pLine)
                trans.AddNewlyCreatedDBObject(pLine, True)

                ' Cập nhật điểm khởi đầu cho đường tiếp theo
                startPoint = New Point3d(startPoint.X + distance, startPoint.Y, startPoint.Z)
                endPoint = New Point3d(endPoint.X + distance, endPoint.Y, endPoint.Z)
            Next



            trans.Commit()
        End Using

        ed.WriteMessage("Đã vẽ xong các đường PLINE.")
    End Sub

    Private Function GetNumberFromUser(prompt As String, minValue As Double, maxValue As Double) As Double
        Dim doc As Document = Application.DocumentManager.MdiActiveDocument
        Dim ed As Editor = doc.Editor

        While True
            Dim result As PromptDoubleResult = ed.GetDouble(New PromptDoubleOptions(prompt))
            If result.Status = PromptStatus.OK Then
                Dim value As Double = result.Value
                If value >= minValue AndAlso value <= maxValue Then
                    Return value
                End If
            End If

            ed.WriteMessage("Giá trị không hợp lệ. Vui lòng nhập lại." & vbLf)
        End While
    End Function

    Private Function LayerExists(layerName As String) As Boolean
        Dim doc As Document = Application.DocumentManager.MdiActiveDocument
        Dim db As Database = doc.Database

        Using trans As Transaction = db.TransactionManager.StartTransaction()
            Dim lt As LayerTable = trans.GetObject(db.LayerTableId, OpenMode.ForRead)
            If lt.Has(layerName) Then
                Return True
            End If
        End Using

        Return False
    End Function

    Private Sub CreateLayer(layerName As String)
        Dim doc As Document = Application.DocumentManager.MdiActiveDocument
        Dim db As Database = doc.Database

        Using trans As Transaction = db.TransactionManager.StartTransaction()
            Dim lt As LayerTable = trans.GetObject(db.LayerTableId, OpenMode.ForWrite)
            Dim newLayer As New LayerTableRecord()
            newLayer.Name = layerName
            lt.Add(newLayer)
            trans.AddNewlyCreatedDBObject(newLayer, True)
            trans.Commit()
        End Using
    End Sub

 

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...