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.
thanhduan2407

Xin mã Code Xoá các Polyline, Line, Point (Các đối tượng trùng nhau)... trong lập trình VBA

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

Em đang nghiên cứu lập trình thêm về VBA nhưng đến phần xoá các đối tượng trùng nhau (chỉ để lại 1 đối tượng) giống như lệnh overkill trong autocad nhưng chưa làm được. Em rất mong các anh chị trong diễn đàn giúp đỡ. Có lẽ em hơi lười nhưng lúc này đầu em như nổ tung ra, không nghĩ thêm được nữa. Cảm ơn các anh chị em trong diễn đàn nhiều. (Em xin mã Code lập trình trong 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
Mình là dân ngoại đạo,thử tìm thấy đoạn này,bạn xem có khả dĩ không :cheers:

http://forums.esri.com/Thread.asp?c=93&amp...87&t=296213

Cảm ơn bạn nhiều nhưng mình vãn chưa tìm thấy cái mình cần. Thanks

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
Em đang nghiên cứu lập trình thêm về VBA nhưng đến phần xoá các đối tượng trùng nhau (chỉ để lại 1 đối tượng) giống như lệnh overkill trong autocad nhưng chưa làm được. Em rất mong các anh chị trong diễn đàn giúp đỡ. Có lẽ em hơi lười nhưng lúc này đầu em như nổ tung ra, không nghĩ thêm được nữa. Cảm ơn các anh chị em trong diễn đàn nhiều. (Em xin mã Code lập trình trong VBA)

 

Tui có đoạn code này, mục đích để phát hiện những đối tượng ở gần nhau. Từ ý tưởng khi bôi đen đối tượng bằng cách kích vào 1 điểm trên màn hình, mỗi lần kích chỉ lựa chọn tối đa là 1 đối tượng, 2 đối tượng trở lên chỉ lựa chọn được tối đa 1 đối tượng, như vậy sẽ phân biệt được 2 đối tượng gần nhau.

Public Sub dspobj()
   Dim entry As AcadEntity
   Dim sset As AcadSelectionSet
   Dim sset1 As AcadSelectionSet
   Dim la As AcadLayer
   Set la = ThisDrawing.Layers.Add("Sf")
   la.Lock = False
   On Error GoTo kt:
   Set sset = ThisDrawing.SelectionSets.Add("SS18")

   sset.SelectOnScreen
   For Each entry In sset
       'MsgBox entry.ObjectName
       Select Case entry.ObjectName
           Case "AcDbBlockReference":
               SdobjAcDbBlockReference entry
           Case "AcDbSpline"
               SdobjAcDbSpline entry
               'MsgBox "ss"
           Case "AcDbCircle"
               SdobjAcDbCircle entry
               'MsgBox "ss"
           Case "AcDbArc"
               SdobjAcDbArc entry
           Case "AcDbRotatedDimension"
               SdobjAcDbRotatedDimension entry
           Case "AcDbAligedDimension"
               SdobjAcDbAligedDimension entry
           'Case "AcDbPolyline"
            '   SdobjAcDbPolyline entry
       End Select
   Next entry
sset.Delete
la.Lock = True
Exit Sub
kt:
sset.Delete
MsgBox "Loi roi"
End Sub
Public Sub SdobjAcDbPolyline(a As AcadPolyline)
   MsgBox "AA"
   Dim sset1 As AcadSelectionSet
   Dim minExt As Variant
   Dim maxExt As Variant
       Dim entry As AcadEntity
   Set sset1 = ThisDrawing.SelectionSets.Add("SS14")
   On Error GoTo kt
   a.GetBoundingBox minExt, maxExt
   ThisDrawing.ModelSpace.AddLine minExt, maxExt
   sset1.SelectAtPoint minExt
   For Each entry In sset1
       entry.Layer = "Sf"
   Next entry
kt:
   sset1.Delete
End Sub
Public Sub SdobjAcDbAligedDimension(a As AcadDimAligned)
   Dim sset1 As AcadSelectionSet
   Set sset1 = ThisDrawing.SelectionSets.Add("SS10")
   sset1.SelectAtPoint a.TextPosition
   Dim entry As AcadEntity
   For Each entry In sset1
       entry.Layer = "Sf"
   Next entry
   sset1.Delete
End Sub
Public Sub SdobjAcDbRotatedDimension(a As AcadDimRotated)
   Dim sset1 As AcadSelectionSet
   Set sset1 = ThisDrawing.SelectionSets.Add("SS10")
   sset1.SelectAtPoint a.TextPosition
   Dim entry As AcadEntity
   For Each entry In sset1
       entry.Layer = "Sf"
   Next entry
   sset1.Delete
End Sub
Public Sub SdobjAcDbBlockReference(a As AcadBlockReference)
   Dim sset1 As AcadSelectionSet
   Set sset1 = ThisDrawing.SelectionSets.Add("SS10")
   sset1.SelectAtPoint a.InsertionPoint
   Dim entry As AcadEntity
   For Each entry In sset1
       entry.Layer = "Sf"
   Next entry
   sset1.Delete
End Sub
Public Sub SdobjAcDbSpline(a As AcadSpline)
   Dim sset1 As AcadSelectionSet
   Set sset1 = ThisDrawing.SelectionSets.Add("SS14")
   On Error GoTo kt
   Dim lp(0 To 2) As Double
   lp(0) = a.ControlPoints(0): lp(1) = a.ControlPoints(1): lp(2) = a.ControlPoints(2):
   Dim entry As AcadEntity
   sset1.SelectAtPoint lp
   For Each entry In sset1
       entry.Layer = "Sf"
   Next entry
kt:
   sset1.Delete
End Sub
Public Sub SdobjAcDbCircle(a As AcadCircle)
   Dim sset1 As AcadSelectionSet
   Set sset1 = ThisDrawing.SelectionSets.Add("SS10")
   sset1.SelectAtPoint a.Center
   Dim entry As AcadEntity
   For Each entry In sset1
       entry.Layer = "Sf"
   Next entry
   sset1.Delete
End Sub
Public Sub SdobjAcDbArc(a As AcadArc)
   Dim sset1 As AcadSelectionSet
   Set sset1 = ThisDrawing.SelectionSets.Add("SS10")
   sset1.SelectAtPoint a.Center
   Dim entry As AcadEntity
   For Each entry In sset1
       entry.Layer = "Sf"
   Next entry
   sset1.Delete
End Sub

Muốn thử lệnh tạo nhiều nhiều đối tượng block circle spline gần nhau. Sau đó cho xin ý kiến nhé.

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

Cảm ơn bạn. Bạn có thể gửi kèm theo ví dụ hoặc file cad để mình thử được không? Mình chưa hiểu ứng dụng của bạn. Rất cảm ơn bạn nhiều

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
Cảm ơn bạn. Bạn có thể gửi kèm theo ví dụ hoặc file cad để mình thử được không? Mình chưa hiểu ứng dụng của bạn. Rất cảm ơn bạn nhiều

Bạn thử file này nhé http://www.box.net/shared/xc2ylpla7h , bản vẽ toàn là các đường tròn layer2 màu xanh. Chạy macro trên, quét các đường tròn đó, nếu có nhiều đường tròn đứng gần nhau thì sẽ chỉ có 1 đường tròn chuyển sang màu trắng (Do bị chuyển sang layer Sf), muốn phân biệt các đường tròn ở khoảng cách nhỏ hơn thì zoom lớn hơn. Nếu có 2 đường tròn trùng nhau, chí có tối đa một đường tròn chuyển sang màu trắ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
Bạn thử file này nhé http://www.box.net/shared/xc2ylpla7h , bản vẽ toàn là các đường tròn layer2 màu xanh. Chạy macro trên, quét các đường tròn đó, nếu có nhiều đường tròn đứng gần nhau thì sẽ chỉ có 1 đường tròn chuyển sang màu trắng (Do bị chuyển sang layer Sf), muốn phân biệt các đường tròn ở khoảng cách nhỏ hơn thì zoom lớn hơn. Nếu có 2 đường tròn trùng nhau, chí có tối đa một đường tròn chuyển sang màu trắng.

Rất cảm ơn bạn nhiều. Mình đã làm và thực hành được nhưng mục đích của mình khác bạn một chút. Giả sử mình có hai hoặc 3 đoạn thẳng nằm trùng nhau thì sau khi kích chọn 1 lần thì mình sẽ xóa được các đối tượng trùng đè đó. Có thể xóa hết mà không phải quét chọn hết. Thứ hai, mình rất muốn có thể biết được phương thức chọn các đối tượng trên tòan bộ bản vẽ (lập hàm chọn). Cảm ơn bạn đã quan tâm. cảm ơn bạn rất nhiều

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


×