Chuyển đến nội dung
Diễn đàn CADViet
  • Thông báo

    • Nguyen Hoanh

      CADViet đã hoàn tất nâng cấp   14/09/2017

      Chào các bạn, CADViet đã hoàn tất việc nâng cấp lên phiên bản mới. Tất cả các chức năng đã hoạt động theo kỳ vọng của ban quản trị. Nếu có vấn đề gì cần phản hồi, các bản post ở đây nhé: Trân trọng, Nguyễn Hoành.
Đăng nhập để thực hiện theo  
ks_chang

Break at point bằng VBA

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

ks_chang    2

Mình có một loạt những Polyline giao nhau, mình muốn break các Pline này tại những chỗ giao nhau bằng đoạn code dứơi. Nếu chọn một vài Polyline thì đuợc, nhưng nếu quét hết toàn bộ thì bị lỗi xẩy ra (như nó bị gãy ko dúng nút giao...), mọi ngừơi xem hộ mình cái lỗi ở đâu với. Thanks!

 

Sub Break_Polyline_1point()
    'Chon doi tuong Polyline
Dim objEnt As AcadSelectionSet
On Error Resume Next
Set objEnt = ThisDrawing.SelectionSets("SSET")
objEnt.Delete
Set objEnt = ThisDrawing.SelectionSets.Add("SSET")
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
gpCode(0) = 0: dataValue(0) = "LWPolyline"
objEnt.SelectOnScreen gpCode, dataValue
Dim ent As AcadEntity
'Vong lap cac PL
Dim n As Long
n = objEnt.Count

For Each ent In objEnt
Dim i As Integer
Dim L As Double
L = ent.Length
   For i = 0 To n - 1
   ReDim oent1(i) As AcadEntity
    Set oent1(i) = objEnt.Item(i)
    If L <> oent1(i).Length Then
           Dim fpt As Variant
           fpt = ent.IntersectWith(oent1(i), acExtendNone)
           Dim ln As AcadLWPolyline
           Dim oent As AcadEntity
           Set oent = ent
           Set ln = oent
           Dim strh As String
            strh = ln.Handle
            strp1 = Replace(CStr(fpt(0)), ",", ".") & "," & _
            Replace(CStr(fpt(1)), ",", ".") & "," & _
            Replace(CStr(fpt(2)), ",", ".")
            ThisDrawing.SendCommand "_BREAK " & _
                            "(handent " & Chr(34) & strh & Chr(34) & ")" & _
                           vbCr & strp1 & vbCr & "@" & vbCr

 End If
     Next
Next ent
End Sub

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
phantuhuong    204
Mình có một loạt những Polyline giao nhau, mình muốn break các Pline này tại những chỗ giao nhau bằng đoạn code dứơi. Nếu chọn một vài Polyline thì đuợc, nhưng nếu quét hết toàn bộ thì bị lỗi xẩy ra (như nó bị gãy ko dúng nút giao...), mọi ngừơi xem hộ mình cái lỗi ở đâu với. Thanks!

 

Sub Break_Polyline_1point()
    'Chon doi tuong Polyline
Dim objEnt As AcadSelectionSet
On Error Resume Next
Set objEnt = ThisDrawing.SelectionSets("SSET")
objEnt.Delete
Set objEnt = ThisDrawing.SelectionSets.Add("SSET")
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
gpCode(0) = 0: dataValue(0) = "LWPolyline"
objEnt.SelectOnScreen gpCode, dataValue
Dim ent As AcadEntity
'Vong lap cac PL
Dim n As Long
n = objEnt.Count

For Each ent In objEnt
Dim i As Integer
Dim L As Double
L = ent.Length
   For i = 0 To n - 1
   ReDim oent1(i) As AcadEntity
    Set oent1(i) = objEnt.Item(i)
    If L <> oent1(i).Length Then
           Dim fpt As Variant
           fpt = ent.IntersectWith(oent1(i), acExtendNone)
           Dim ln As AcadLWPolyline
           Dim oent As AcadEntity
           Set oent = ent
           Set ln = oent
           Dim strh As String
            strh = ln.Handle
            strp1 = Replace(CStr(fpt(0)), ",", ".") & "," & _
            Replace(CStr(fpt(1)), ",", ".") & "," & _
            Replace(CStr(fpt(2)), ",", ".")
            ThisDrawing.SendCommand "_BREAK " & _
                            "(handent " & Chr(34) & strh & Chr(34) & ")" & _
                           vbCr & strp1 & vbCr & "@" & vbCr

 End If
     Next
Next ent
End Sub

 

Đoạn code này là duyệt qua toàn bộ đối tượng polyline và giao cắt giữa chúng với nhau thôi. Tuy nhiên chỉ bắt được điểm giao cắt đầu tiên, từ điểm thứ 2 là chịu. Tuy nhiên đoạn code này rất hay cho ai nghiên cứu Trim, break,... = VBA

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
anhcos    177
Mình có một loạt những Polyline giao nhau, mình muốn break các Pline này tại những chỗ giao nhau bằng đoạn code dứơi. Nếu chọn một vài Polyline thì đuợc, nhưng nếu quét hết toàn bộ thì bị lỗi xẩy ra (như nó bị gãy ko dúng nút giao...), mọi ngừơi xem hộ mình cái lỗi ở đâu với. Thanks!

 

Đầu tiên ứng với mỗi PL, tìm tất cả các điểm giao với các PL còn lại.

 

Từ n điểm giao, sẽ có n+1 PL mới được tạo ra.

Vì vậy cần xác định trong n điểm chạy dọc theo PL, điểm nào là đầu tiên và điểm nào là cuối cùng.

 

--> có n+1 đường PL mới như sau:

điểm đầu PL --> điểm giao 1

điểm giao 1 --> điểm giao 2

...

điểm giao n-1 --> điểm giao n

điểm giao n --> điểm cuối PL

 

Tạo xong các đường mới thì delete cái cũ

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
ks_chang    2
Đầu tiên ứng với mỗi PL, tìm tất cả các điểm giao với các PL còn lại.

 

Từ n điểm giao, sẽ có n+1 PL mới được tạo ra.

Vì vậy cần xác định trong n điểm chạy dọc theo PL, điểm nào là đầu tiên và điểm nào là cuối cùng.

 

--> có n+1 đường PL mới như sau:

điểm đầu PL --> điểm giao 1

điểm giao 1 --> điểm giao 2

...

điểm giao n-1 --> điểm giao n

điểm giao n --> điểm cuối PL

 

Tạo xong các đường mới thì delete cái cũ

Hi, thanks anhcos, có thể đoạn mã kia bị lỗi do khi các đối tựong PL đầu bị break, đến khi tiếp tục với PL sau thì đối tựong đầu ko còn nữa nên nó chỉ đúng với nút giao đầu tiên như phantuhuong nói. Mình dang thử cách này:

- Duyệt qua các nút giao, sau đó vẽ vòng tròn tại đó, tiếp tục select các vòng tròn tạo ra, trong mỗi vòng tròn đó lấy ra 2 điểm của hình chữ nhật bao quanh vòng tròn, sau đó select các PL thông qua 2 điểm đó, dùng đoạn code trên để break 2 PL tại nút.

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
gia_bach    1.442
Hi, thanks anhcos, có thể đoạn mã kia bị lỗi do khi các đối tựong PL đầu bị break, đến khi tiếp tục với PL sau thì đối tựong đầu ko còn nữa nên nó chỉ đúng với nút giao đầu tiên như phantuhuong nói. Mình dang thử cách này:

- Duyệt qua các nút giao, sau đó vẽ vòng tròn tại đó, tiếp tục select các vòng tròn tạo ra, trong mỗi vòng tròn đó lấy ra 2 điểm của hình chữ nhật bao quanh vòng tròn, sau đó select các PL thông qua 2 điểm đó, dùng đoạn code trên để break 2 PL tại nút.

Giải pháp này khả thi nhưng tốn rất nhiều chi phí. :cheers:

Gợi ý : bạn nghiên cứu thêm lệnh Break của CAD, tìm ra qui luật tạo đối tuợng mới của CAD (sau khi thực hiện lệnh Break thành công)

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
ks_chang    2

Cách của anhcos gợi ý là tạo ra các Pline mới, sau đó xóa cái cũ, tuy nhiên trong trường hợp PL ban đầu ở giữa 2 điểm gãy có các cung tròn và các điễm gãy khác thì rất khó ghép tọa độ PL mới theo mảng đựoc.

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
anhcos    177
Cách của anhcos gợi ý là tạo ra các Pline mới, sau đó xóa cái cũ, tuy nhiên trong trường hợp PL ban đầu ở giữa 2 điểm gãy có các cung tròn và các điễm gãy khác thì rất khó ghép tọa độ PL mới theo mảng đựoc.

 

Đây là thuật toán, còn với acad thì mình có thể nhờ nó break dùm (cái này mình chưa thử).

Như bạn nói nếu phân đoạn PL là arc thì phức tạp hơn line, nhưng không khó quá.

 

Từ độ lồi (bulge) của phân đoạn trên PL --> tính được bán kính, điểm giao chắc chắn sẽ nằm giữa điểm i và i+1 của PL --> tính lại được 2 góc đã chia ra từ góc cũ --> tính được độ lồi của 2 phân góc (bằng TAN của 1/4 góc chắn) và lập ra PL mới.

 

Bạn thử triển khai xem như thế nào, mình sẽ cố gắng bám theo.

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

Đăng nhập để thực hiện theo  

×