Chuyển đến nội dung
Diễn đàn CADViet

Thành Công WRU

Thành viên
  • Số lượng nội dung

    22
  • Đã tham gia

  • Lần ghé thăm cuối

  • Ngày trúng

    2

Bài đăng được đăng bởi Thành Công WRU


  1. Lệnh SBT chỉ chọn text trong vùng chọn

    SB Chỉ chọn Block trong vùng chọn

    SHA chỉ chọn hatch trong vùng chọn

    SD chỉ chọn Dim trong vùng chọn

    SBL chỉ chọn đối tượng mang layer theo đối tượng mẫu

    SBO chỉ chọn đối tượng giống đối tượng mẫu

    SBN chỉ chọn block có tên giống với block mẫu

    SGN chỉ chọn các text có nội dung giống với text mẫu

    SBC chỉ chọn đối tượng có color giống đối tượng mẫu

    Code theo anh Ketxu trên diễn đàn.

    QuickSelect.lsp


  2. thôi thì em tự mò cop nhặt trên mạng và tự chế thêm chút ít cũng phần nào giải quyết được bài toán rồi ạ

    code em đây

     

    Quote

    Option Explicit
    Public radQ As Double
    Public lengthL As Double


    Sub GetBulgeRadius()

    Dim lastA As String
    lastA = radQ
    Dim radA As String
    On Error GoTo check
       radA = ThisDrawing.Utility.GetString(0, vbCrLf & "Nhap ban kinh toi da: " & "< " & radQ & " > __")
    check:
    On Error Resume Next
      If radA <> "" Then radQ = radA
     

    ' lengthL = ThisDrawing.Utility.GetString(1, vbCrLf & "Nhap chieu dai toi da: " & "< " & lengthL & " > __")
    On Error GoTo 0
    Dim plineObj As AcadPolyline
    Dim points(0 To 5) As Double
    Dim oent As AcadEntity
    Dim varpt
    Dim opoly As AcadLWPolyline
    Dim rad As Double, ang As Double, b As Double, d As Double
    Dim c As Double, i As Long, j As Long, bulge As Double, pi As Double
    Dim coors As Variant, p1 As Variant, p2 As Variant, cpt(2) As Double
    Dim Pt1(2) As Double, Pt2(2) As Double, s As String
    pi = 3.14159265358979: s = ""
    On Error Resume Next

    Dim newVertex(0 To 1) As Double
       
    Dim tapXuLy As AcadSelectionSet
    Dim FilterType(0) As Integer
    Dim FilterData(0) As Variant
    Dim doiTuong As Variant
    FilterType(0) = 0
    FilterData(0) = "LWPOLYLINE"
    Set tapXuLy = ThisDrawing.SelectionSets("MySS")
    If Err Then
    Err.Clear
    Set tapXuLy = ThisDrawing.SelectionSets.Add("MySS")
    Else
    tapXuLy.Clear
    End If
    tapXuLy.SelectOnScreen FilterType, FilterData
    For Each doiTuong In tapXuLy
     

    'ThisDrawing.Utility.GetEntity oent, varpt, "Chon doi tuong"
    Set opoly = doiTuong

    coors = doiTuong.Coordinates

     newVertex(0) = coors(0)
     newVertex(1) = coors(1)
       doiTuong.AddVertex (UBound(coors) + 1) / 2, newVertex
       doiTuong.AddVertex (UBound(coors) + 3) / 2, newVertex
        doiTuong.Update
        Set opoly = doiTuong
        coors = opoly.Coordinates
        'MsgBox UBound(coors)
        
    j = 0
    For i = 0 To (UBound(coors) / 2 - 1) - 1

    'bulge : do phinh ra ARC
    bulge = opoly.GetBulge(j)
    If bulge <> 0 Then
    p1 = opoly.Coordinate(i)
    p2 = opoly.Coordinate(i + 1)

    Pt1(0) = p1(0): Pt1(1) = p1(1): Pt1(2) = opoly.Elevation
    Pt2(0) = p2(0): Pt2(1) = p2(1): Pt2(2) = opoly.Elevation


    'ang : goc giua 2 diem pt1 va pt2
    ang = ThisDrawing.Utility.AngleFromXAxis(Pt1, Pt2)


    'b ArcTan cua goc Bulge
    b = Atn(bulge) * 2

    'd Tinh khoang cach giua 2 dau mut cua ARC
    d = Get_Distance(p1, p2) / 2


    If bulge > 0 Then
    c = ang + pi / 2 - b
    Else
    c = ang - pi / 2 - b
    End If

    'Ban kinh
    rad = Abs(d / Sin(b))

    'tam cung tron
    cpt(0) = p1(0) + Cos(c) * rad
    cpt(1) = p1(1) + Sin(c) * rad
    cpt(2) = 0

     If rad <= radQ Then
        
     
     'them cung tron
     
    points(0) = Pt1(0)
    points(1) = Pt1(1)
    points(2) = Pt1(2)
    points(3) = Pt2(0)
    points(4) = Pt2(1)
    points(5) = Pt2(2)
     
     
     
         Set plineObj = ThisDrawing.ModelSpace.AddPolyline(points)
    plineObj.SetBulge 0, bulge
     
     opoly.SetBulge j, 0
     
     End If
     

     
     

    End If

    j = j + 1
    Next i


    Next doiTuong

    kt:
    Exit Sub
    End Sub
    Public Function Get_Distance(fPoint As Variant, sPoint As Variant) As Double

    Dim x1 As Double, x2 As Double
    Dim y1 As Double, y2 As Double
    Dim z1 As Double, z2 As Double
    Dim cDist As Double

    x1 = fPoint(0): y1 = fPoint(1)
    If UBound(fPoint) = 2 Then z1 = fPoint(2) Else z1 = 0#
    x2 = sPoint(0): y2 = sPoint(1)
    If UBound(sPoint) = 2 Then z2 = sPoint(2) Else z2 = 0#

    cDist = Sqr(((x2 - x1) ^ 2) + ((y2 - y1) ^ 2) + ((z2 - z1) ^ 2))
    Get_Distance = cDist

    End Function

     

     


  3.  

    Chào mọi người, em đang có một bài toán lặp đi lặp lại như sau và mong có được giải pháp bằng lisp (*.lsp để có thể tùy chỉnh bán kính được ) :

    - Ban đầu có layer 1 và 2 như ở hình bên trái, biết rằng chúng đều là các polyline tạo bởi line + arc

    - Sau đó tại 2 đầu của ARC có R<=[40] thì nối 2 điểm đó lại , break đối tượng layer 2 cũ tại 2 điểm đó và tạo được polyline mới như hình bên phải, đoạn ARC sẽ là layer 0

    Xin cảm ơn mọi người đã giành thời gian đọc post này, rất mong nhận được sự góp ý phản hồi từ mọi người. Chúc mọi người sức khỏe !

     

    image.thumb.png.21c566bdb07dffe0da36f6d3b62c1a9b.png

    hoiCad.dwg


  4. Chào các anh chị, em đang làm việc về thiết kế cải tạo nền cho các công trình, hiện tại em gặp bài toán lặp đi lặp lại với yêu cầu như sau :

    1. Đã có các line là đường trung trực thể hiện bằng màu đỏ ở file đính kèm

    2. Cần Fillet các đường trung trực trong 1 ô , sao cho không bị trùng chéo lên nhau

    3. Nối các giao điểm lại bằng line để tạo ra kết quả như file đính kèm

    Vậy em xin nhờ các anh chị nếu có thể hãy giúp đỡ em ạ. Em xin cảm ơn anh chị, chúc anh chị thành công trong cuộc sống !

     

    Fillet_red.dwg


  5. xin chào các bác, em có tải về dùng thử thì bị tình trạng như sau :

    + Nếu vẽ vu vơ các đường LINE thì lisp rất ngon lành

    + Nếu vẽ bắt điểm vào đâu đó thì không còn dùng được lisp nữa

    + chỉ dùng được với LINE, PLINE thì không ?

    Mong các bác sửa lại cho ứng dụng được nhiều hơn ạ.

     

×