Đến nội dung


Hình ảnh
- - - - -

Text cắt nhau


  • Please log in to reply
9 replies to this topic

#1 mua_buon12

mua_buon12

    biết vẽ circle

  • Members
  • PipPip
  • 34 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 16 November 2009 - 11:21 AM

Các bác ơi !
Trên bản vẽ có rất nhiều text vậy làm sao để tìm được 2 text cắt nhau.Ví dụ:http://www.cadviet.com/upfiles/2/vidu.jpg
  • 0
Khi Lập Trình Kiến Thức Là Một Phần, Nghệ Thuật Mới Là Tất Cả.

#2 anhcos

anhcos

    biết lệnh hatchedit

  • Advance Member
  • PipPipPipPip
  • 260 Bài viết
Điểm đánh giá: 170 (tàm tạm)

Đã gửi 17 November 2009 - 09:08 AM

Các bác ơi !
Trên bản vẽ có rất nhiều text vậy làm sao để tìm được 2 text cắt nhau.Ví dụ:http://www.cadviet.com/upfiles/2/vidu.jpg


Tìm giao điểm của TEXT như trên thì không thể được. Vì Text không phải là polyline.

Hàm IntersectWith của Text sẽ cho ra giao điểm với hình chữ nhật bao quanh Text.

Xem hình vẽ minh họa:
4 vòng tròn nhỏ chỉ vị trí điểm giao tìm thấy.
Hình đã gửi
  • 0
Clear sky!

MF Rock collection.

#3 mua_buon12

mua_buon12

    biết vẽ circle

  • Members
  • PipPip
  • 34 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 18 November 2009 - 08:39 AM

Dear all!
Tôi cũng biết hàm này tìm được như vậy nhưng tôi chưa biết sử dụng nó như thế nào khi text cùng nằm trong 1 layer xin anhcos và các cao thủ chỉ giúp. Thank's


Tìm giao điểm của TEXT như trên thì không thể được. Vì Text không phải là polyline.

Hàm IntersectWith của Text sẽ cho ra giao điểm với hình chữ nhật bao quanh Text.

Xem hình vẽ minh họa:
4 vòng tròn nhỏ chỉ vị trí điểm giao tìm thấy.
Hình đã gửi


  • 0
Khi Lập Trình Kiến Thức Là Một Phần, Nghệ Thuật Mới Là Tất Cả.

#4 gia_bach

gia_bach

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1436 Bài viết
Điểm đánh giá: 1426 (rất tốt)

Đã gửi 18 November 2009 - 11:00 AM

Dear all!
Tôi cũng biết hàm này tìm được như vậy nhưng tôi chưa biết sử dụng nó như thế nào khi text cùng nằm trong 1 layer xin anhcos và các cao thủ chỉ giúp. Thank's

Đây là 1 VD đơn giản tìm giao của 2 TEXT viết bằng LIST.
Kết quả trả về là các POINT (nếu có)
Bạn có thể tham khảo và convert qua VBA.
(defun TxtIntersectWithTxt(txt1 txt2 /  pl1 pl2)
(setq pl1 (TxtBoundary txt1)
pl2 (TxtBoundary txt2) )
(setq iPts (vlax-Invoke (vlax-ename->vla-Object pl1) "IntersectWith" (vlax-ename->vla-Object pl2) acExtendNone))
(entdel pl1)(entdel pl2)
iPts
)

(defun TxtBoundary(ent / ll pt1 pt2 pt3 pt4 tb ur)
(command "ucs" "Entity" ent)
(setq tb (textbox (list (cons -1 ent)))
ll (car tb)
ur (cadr tb)
pt1 (list (car ll) (cadr ll))
pt3 (list (car ur) (cadr ur))
pt2 (list (car pt3) (cadr pt1))
pt4 (list (car pt1) (cadr pt3))
)
(command "pline" pt1 pt2 pt3 pt4 "c")
(command "ucs" "p")
(entlast)
)

(defun C:test(/ vl ov ent1 ent2 ipts)
(if (and (setq ent1 (car (entsel "\nChon Text1 :")))
(wcmatch (cdr (assoc 0 (entget ent1))) "TEXT")
(setq ent2 (car (entsel "\nChon Text2 :")))
(wcmatch (cdr (assoc 0 (entget ent2))) "TEXT")
)
(progn
(command "undo" "be")
(setq vl '("osmode" "orthomode" "cmdecho") ; Sys Var list
ov (mapcar 'getvar vl)) ; Get Old values
(mapcar 'setvar vl '(0 0 0))
(if (setq iPts (TxtIntersectWithTxt ent1 ent2))
(while iPts
(entmake (list (cons 0 "POINT") (cons 10 (list (car iPts) (cadr iPts) (caddr iPts)))))
(setq iPts (cdddr iPts)))
(princ "\nKhong co giao diem." )
)
(mapcar 'setvar vl ov) ; reset Sys Vars
(command "undo" "e")
)
)
(princ)
)

  • 0

#5 anhcos

anhcos

    biết lệnh hatchedit

  • Advance Member
  • PipPipPipPip
  • 260 Bài viết
Điểm đánh giá: 170 (tàm tạm)

Đã gửi 18 November 2009 - 12:49 PM

Giả sử text_sel_set là tập chọn đối tượng chứa toàn text, các text này có thể nằm ở bất kỳ layer nào

Dim count as integer
count = text_sel_set.Count

Dim pts as object 'Lưu các giao điểm tìm thấy
Dim i, j as integer

if count > 1 then 'nếu có hơn 2 đối tượng

For i = 0 to count - 2 'duyệt qua từng text

for j = i + 1 to count - 1 'và các text nằm sau nó trong tập chọn

pts = text_sel_set.Item(i).IntersectWith(text_sel_set.Item(j)) 'Tìm giao

On Error Resume Next
if pts.Length > 0 'nếu có giao điểm (chỉ có 2 or 4 giao điểm)

'làm cái gì đó ở đây

end if

next j

next i

endif
  • 0
Clear sky!

MF Rock collection.

#6 mua_buon12

mua_buon12

    biết vẽ circle

  • Members
  • PipPip
  • 34 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 19 November 2009 - 11:48 AM

Em lắp ghép vẫn chưa được. em upload lên các bác sửa giúp em với

Sub TEST()
Dim Doituong As AcadEntity
Dim asset As AcadSelectionSet
Dim ab As AcadText
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
gpCode(0) = 0: dataValue(0) = "Text"

On Error Resume Next
ActiveDocument.SelectionSets.Item("temp").Delete
Set asset = ActiveDocument.SelectionSets.Add("temp")
asset.Select acSelectionSetAll, gpCode, dataValue


For Each Doituong In asset
Set ab = Doituong
Dim count As Integer
count = ab.count

Dim pts As Object 'Luu cac giao diem tim thay
Dim i, j As Integer

If count > 1 Then 'neu co hon 2 doi tuong

For i = 0 To count - 2 'duyet qua tung text

For j = i + 1 To count - 1 'va ca cac text nam sau no trong tap chon

pts = ab.Item(i).IntersectWith(ab.Item(j), acExtendNone) 'tim giao

On Error Resume Next
If pts.Length > 0 Then 'neu co giao diem(co 2 hoc 4 giao diem)

ab.Highlight True
'hoac su ly cho em bao point tai diem intersert cua text
End If

Next j

Next i

End If



Next
End Sub



Giả sử text_sel_set là tập chọn đối tượng chứa toàn text, các text này có thể nằm ở bất kỳ layer nào

Dim count as integer
count = text_sel_set.Count

Dim pts as object 'Lưu các giao điểm tìm thấy
Dim i, j as integer

if count > 1 then 'nếu có hơn 2 đối tượng

For i = 0 to count - 2 'duyệt qua từng text

for j = i + 1 to count - 1 'và các text nằm sau nó trong tập chọn

pts = text_sel_set.Item(i).IntersectWith(text_sel_set.Item(j)) 'Tìm giao

On Error Resume Next
if pts.Length > 0 'nếu có giao điểm (chỉ có 2 or 4 giao điểm)

'làm cái gì đó ở đây

end if

next j

next i

endif


  • 0
Khi Lập Trình Kiến Thức Là Một Phần, Nghệ Thuật Mới Là Tất Cả.

#7 anhcos

anhcos

    biết lệnh hatchedit

  • Advance Member
  • PipPipPipPip
  • 260 Bài viết
Điểm đánh giá: 170 (tàm tạm)

Đã gửi 19 November 2009 - 12:17 PM

Thay từ đoạn For Each Doituong... bằng đoạn sau

Dim count As Integer
count = asset.count

Dim pts As Object 'Luu cac giao diem tim thay
Dim i, j,k As Integer

If count > 1 Then 'neu co hon 2 doi tuong

For i = 0 To count - 2 'duyet qua tung text

For j = i + 1 To count - 1 'va ca cac text nam sau no trong tap chon

pts = asset .Item(i).IntersectWith(asset.Item(j), acExtendNone) 'tim giao

On Error Resume Next
If pts.Length > 0 Then 'neu co giao diem(co 2 hoc 4 giao diem)

asset.Highlight True

'hoac xu ly cho em bao point tai diem intersert cua text
for k=0 to pts.Length/3 - 1

pt(0)=pts(k*3) 'X
pt(1)=pts(k*3+1)'Y
ThisDrawing.ModelSpace.AddPoint(pt)

next k

End If

Next j

Next i


End If
  • 0
Clear sky!

MF Rock collection.

#8 mua_buon12

mua_buon12

    biết vẽ circle

  • Members
  • PipPip
  • 34 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 19 November 2009 - 01:26 PM

Tình hình là bất thình lình chương trình vẫn chưa chạy được bác anhcos xem lại hộ em với.Chương trình chẳng thấy báo lỗi gì cả. Em cảm ơn bác rất nhiều.
Sub TEST()
Dim asset As AcadSelectionSet
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
gpCode(0) = 0: dataValue(0) = "Text"

On Error Resume Next
ActiveDocument.SelectionSets.Item("temp").Delete
Set asset = ActiveDocument.SelectionSets.Add("temp")
asset.Select acSelectionSetAll, gpCode, dataValue

Dim count As Integer
count = asset.count
Dim pts As Object
Dim i, j, k As Integer
If count > 1 Then
For i = 0 To count - 2
For j = i + 1 To count - 1
pts = asset.Item(i).IntersectWith(asset.Item(j), acExtendBoth)
On Error Resume Next
If pts.Length > 0 Then
asset.Highlight True
Dim pt As AcadPoint
For k = 0 To pts.Length / 3 - 1
pt(0) = pts(k * 3)
pt(1) = pts(k * 3 + 1)
ThisDrawing.ModelSpace.AddPoint (pt)
Next k
End If
Next j
Next i
End If
End Sub
  • 0
Khi Lập Trình Kiến Thức Là Một Phần, Nghệ Thuật Mới Là Tất Cả.

#9 mua_buon12

mua_buon12

    biết vẽ circle

  • Members
  • PipPip
  • 34 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 03 December 2009 - 11:53 AM

Không có ai giúp em edit code trên àh.huhu
  • 0
Khi Lập Trình Kiến Thức Là Một Phần, Nghệ Thuật Mới Là Tất Cả.

#10 anhcos

anhcos

    biết lệnh hatchedit

  • Advance Member
  • PipPipPipPip
  • 260 Bài viết
Điểm đánh giá: 170 (tàm tạm)

Đã gửi 03 December 2009 - 01:46 PM

Không có ai giúp em edit code trên àh.huhu


thay cái dòng asset.Hightlight bằng
asset.Item(i).Hightlight xem sao. Mấy dòng khác mình không thấy có gì.
  • 0
Clear sky!

MF Rock collection.