Chuyển đến nội dung
Diễn đàn CADViet
Thành Công WRU

[Xin lisp] Bo vỉa hè

Các bài được khuyến nghị

 

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

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
7 giờ trước, quocmanh04tt đã nói:

Thử cái này xem (lệnh : BVS):

 

bvs.rar

không được anh ạ

Command: (LOAD "C:/Users/Administrator/Desktop/bvs.vlx")
Dung lenh: BVS. @quocmanh04tt-catviet.comnil

Command:
Command:
Command: _propertiesclose
Command: BVS ; error: bad argument type: stringp nil

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

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

 

 

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Tạo một tài khoản hoặc đăng nhập để nhận xét

Bạn cần phải là một thành viên để lại một bình luận

Tạo tài khoản

Đăng ký một tài khoản mới trong cộng đồng của chúng tôi. Điều đó dễ mà.

Đăng ký tài khoản mới

Đăng nhập

Bạn có sẵn sàng để tạo một tài khoản ? Đăng nhập tại đây.

Đăng nhập ngay

×