Chuyển đến nội dung
Diễn đàn CADViet
Đăng nhập để thực hiện theo  
mua_buon12

Text cắt nhau

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

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.

giaotext.jpg

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

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.

giaotext.jpg

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

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

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

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

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

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

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ì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

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

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  

×