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

[thanhduan2407 272]

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)

[ketxu 2.984]

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 :(

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

[thanhduan2407 272]

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

[thanhduan2407 272]

Có ai không? Giúp em với. Em cần lắm

[sson 11]

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

[thanhduan2407 272]

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

[sson 11]

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.

[thanhduan2407 272]

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