Đến nội dung


Hình ảnh
- - - - -

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


  • Please log in to reply
7 replies to this topic

#1 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 992 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 29 September 2010 - 10:53 AM

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)
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#2 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 29 September 2010 - 06:25 PM

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.c...p...87&t=296213
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#3 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 992 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 02 October 2010 - 10:12 AM

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.c...p...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
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#4 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 992 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 02 October 2010 - 11:19 AM

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



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#5 sson

sson

    biết zoom

  • Members
  • Pip
  • 18 Bài viết
Điểm đánh giá: 11 (tàm tạm)

Đã gửi 12 October 2010 - 11:17 PM

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

#6 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 992 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 13 October 2010 - 07:20 AM

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
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#7 sson

sson

    biết zoom

  • Members
  • Pip
  • 18 Bài viết
Điểm đánh giá: 11 (tàm tạm)

Đã gửi 13 October 2010 - 10:55 PM

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.
  • 0

#8 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 992 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 13 October 2010 - 11:06 PM

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
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn