Đến nội dung


Hình ảnh
* * * - - 8 Bình chọn

Viết lisp theo yêu cầu [phần 2]


  • Chủ đề bị khóa Chủ đề bị khóa
3783 replies to this topic

#2281 phamngoctukts

phamngoctukts

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1107 Bài viết
Điểm đánh giá: 696 (tốt)

Đã gửi 17 October 2010 - 07:39 PM

Chào bác Phamngoctukts,
Mình đã test lisp của bác với bản vẽ do bạn W1ndream cung cấp thì thấy chưa được như ý bác ạ.
Sau khi đọc lại code của bác thì thấy cái nguyên tắc giãn text của bác khá đơn giản. Như vậy chỉ giãn được trong trường hợp hai text trùng nhau mà thôi, Nếu có một búi text trùng nhau thì khi giãn kiểu này lại sinh ra một sự trùng khác bác ạ.
Cám ơn bác về khúc code thay width factor vì mình chả nhớ cái mã nào nó thể hiện điều này nên chưa làm trong đoạn lisp của mình. Mình sẽ bổ sung ngay bác ạ.
Chúc bác khỏe và vui.

Chào Bác bình phần code giãn text của em chạy thì cũng tạm được vì em dùng repeat ở đầu nên nó cũng sẽ giãn hết ra thôi. Nhưng nó có nhược điểm là không căn nhóm text giãn đều ra hai bên được. Cái này em mới làm lần đầu về giãn text.
BS: Em không rõ về hàm Lambda lắm bác có thể hướng dẫn cụ thể cho em biết được không. Thank Bác. Theo em thấy thì hàm này hay dùng khi sắp xếp đối tượng. Ngoài ra nó còn ứng dụng như thế nào nữa?? Thank Bác.
  • 0
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!

#2282 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

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

Đã gửi 17 October 2010 - 09:58 PM

Chào Bác bình phần code giãn text của em chạy thì cũng tạm được vì em dùng repeat ở đầu nên nó cũng sẽ giãn hết ra thôi. Nhưng nó có nhược điểm là không căn nhóm text giãn đều ra hai bên được. Cái này em mới làm lần đầu về giãn text.
BS: Em không rõ về hàm Lambda lắm bác có thể hướng dẫn cụ thể cho em biết được không. Thank Bác. Theo em thấy thì hàm này hay dùng khi sắp xếp đối tượng. Ngoài ra nó còn ứng dụng như thế nào nữa?? Thank Bác.

Chào bác Phamngoctukts,
Về đoạn code bác viết cho bạn W1ndream, mình test thì thấy chưa được như ý, bác co thể kiểm tra lại xem nhé.
Về hàm lambda thì thực tình mình cũng chỉ tham khảo trong help của CAD thôi.
lambda Function

Defines an anonymous function

(lambda arguments expr...)

Use the lambda function when the overhead of defining a new function is not justified. It also makes the programmer's intention more apparent by laying out the function at the spot where it is to be used. This function returns the value of its last expr, and is often used in conjunction with apply and/or mapcar to perform a function on a list.

Arguments

arguments

Arguments passed to an expression.

expr

An AutoLISP expression.

Return Values

The value of the last expr.

Examples

The following examples demonstrate the lambda function from the Visual LISP Console window:

_$ (apply '(lambda (x y z)
(* x (- y z))
)
'(5 20 14)
)
30
_$ (setq counter 0)
(mapcar '(lambda (x)
(setq counter (1+ counter))
(* x 5)
)
'(2 4 -6 10.2)
)
0
(10 20 -30 51.0)


Có thể hiểu như sau
Hàm lambda dùng để xác định (hay định nghĩa) một hàm mới chưa được đặt tên. Hàm này cho phép người lập trình có thể đặt nó vào bất cứ đâu cần sử dụng nó. Hàm lambda trả về giá trị của biếu thức cuối cùng của hàm. Hàm này có thể dùng kết hợp với hàm apply mapcar để thực hiện một chức năng đối với một list
Cú pháp của hàm là:
(lambda arguments expr...)
Trong đó argument là các đối số của hàm
expr là biểu thức được thể hiện trong ngôn ngữ Autolisp
Giá trị trả về là giá trị biểu thức cuối cùng của hàm.
Bác xem những ví dụ cụ thể của hàm sẽ hiểu dần bác ạ. Thực tế mình cũng mới chỉ dám ứng dụng nó cho những trường hợp đơn giản như các ví dụ đã nêu. Những trường hợp phức tạp khác thì mình chỉ mới cố đọc để hiểu nó đã chứ chưa ứng dụng được bao nhiêu. Nhất là khi kết hợp nó cùng hàm mapcar.
Hy vọng bác sẽ sử dụng tốt hàm này.
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#2283 phamngoctukts

phamngoctukts

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1107 Bài viết
Điểm đánh giá: 696 (tốt)

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

Chào bác Phamngoctukts,
Về đoạn code bác viết cho bạn W1ndream, mình test thì thấy chưa được như ý, bác co thể kiểm tra lại xem nhé.
Về hàm lambda thì thực tình mình cũng chỉ tham khảo trong help của CAD thôi.
lambda Function

Defines an anonymous function

(lambda arguments expr...)

Use the lambda function when the overhead of defining a new function is not justified. It also makes the programmer's intention more apparent by laying out the function at the spot where it is to be used. This function returns the value of its last expr, and is often used in conjunction with apply and/or mapcar to perform a function on a list.

Arguments

arguments

Arguments passed to an expression.

expr

An AutoLISP expression.

Return Values

The value of the last expr.

Examples

The following examples demonstrate the lambda function from the Visual LISP Console window:

_$ (apply '(lambda (x y z)
(* x (- y z))
)
'(5 20 14)
)
30
_$ (setq counter 0)
(mapcar '(lambda (x)
(setq counter (1+ counter))
(* x 5)
)
'(2 4 -6 10.2)
)
0
(10 20 -30 51.0)


Có thể hiểu như sau
Hàm lambda dùng để xác định (hay định nghĩa) một hàm mới chưa được đặt tên. Hàm này cho phép người lập trình có thể đặt nó vào bất cứ đâu cần sử dụng nó. Hàm lambda trả về giá trị của biếu thức cuối cùng của hàm. Hàm này có thể dùng kết hợp với hàm apply mapcar để thực hiện một chức năng đối với một list
Cú pháp của hàm là:
(lambda arguments expr...)
Trong đó argument là các đối số của hàm
expr là biểu thức được thể hiện trong ngôn ngữ Autolisp
Giá trị trả về là giá trị biểu thức cuối cùng của hàm.
Bác xem những ví dụ cụ thể của hàm sẽ hiểu dần bác ạ. Thực tế mình cũng mới chỉ dám ứng dụng nó cho những trường hợp đơn giản như các ví dụ đã nêu. Những trường hợp phức tạp khác thì mình chỉ mới cố đọc để hiểu nó đã chứ chưa ứng dụng được bao nhiêu. Nhất là khi kết hợp nó cùng hàm mapcar.
Hy vọng bác sẽ sử dụng tốt hàm này.

Xin lỗi Bác Bình đúng là code đó sai mất vài chỗ do ẩu quá đây mà. Bạn w1ndream down code mới này nhé.

;; free lisp from cadviet.com
(defun c:loc ()
(command "undo" "be")
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq ss (ssget '((0 . "text")))
k 0
tdoc (ssadd)
)
(while (< k (sslength ss))
(setq name (ssname ss k)
ent1 (entget name)
p1 (cdr (assoc 10 ent1))
goc (cdr (assoc 50 ent1))
nd (cdr (assoc 1 ent1))
)
(setq ent1 (entmod (subst (cons 41 0.8) (assoc 41 ent1) ent1)))
(if (eq nd "-0.00")
(setq ent1 (entmod (subst (cons 1 "0.00") (assoc 1 ent1) ent1)))
)
(if (and (eq nd "0.00") (eq goc (/ pi 2)))
(command "erase" (ssname ss k) "")
)
(if (and (eq goc (/ pi 2)) (/= nd "0.00"))
(setq tdoc (ssadd (cdr (assoc -1 ent1)) tdoc))
)
(giantext tdoc)
(setq k (1+ k))
)
(setvar "osmode" oldos)
(command "undo" "e")
)

(defun giantext ( td /)
(setq i 0)
(while (< i (sslength td))
(setq name1 (ssname td i)
ent1 (entget name1)
p1 (cdr (assoc 10 ent1))
goc (cdr (assoc 50 ent1))
j 0)
(while (and (< j (sslength td)) (/= j i))
(setq name2 (ssname td j)
ent2 (entget name2)
p2 (cdr (assoc 10 ent2))
di (distance p1 p2)
caochu (cdr (assoc 40 ent2))
)
(if (< di caochu)
(progn
(if (< (car p1) (car p2))
(progn
(setq tam (polar p1 0 (/ di 2))
pt1 (polar tam pi (/ caochu 2))
pt2 (polar tam 0 (/ caochu 2))
)
(command "move" name1 "" p1 pt1)
(command "move" name2 "" p2 pt2)
)
)
(if (> (car p1) (car p2))
(progn
(setq tam (polar p2 0 (/ di 2))
pt1 (polar tam 0 (/ caochu 2))
pt2 (polar tam pi (/ caochu 2))
)
(command "move" name1 "" p1 pt1)
(command "move" name2 "" p2 pt2)
)
)
)
)
(setq j (1+ j))
)
(setq i (1+ i))
)
)

  • 3
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!

#2284 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 October 2010 - 08:05 AM

Chào Bác Bình em chạy code của bác báo lỗi: ; error: no function definition: ACET-GEOM-SS-EXTENTS-FAST.
Cái này em cũng đã làm giúp w1ndream rồi (Vì thấy bạn đang rất cần). Bác test thử code xem có khác gì không nhé.
PS: em đã cài epress tool rồi nhé.

Vụ này thì mình không rõ vì mình dùng cad 2004 với bộ express tool của bác Giabach cho thì thấy nó chạy ngon lành. Có thể của bác đời sau không có hàm này chăng???? Nếu vậy nó phải có hàm tương đương là hàm gì đó chứ nhể,
Cái hàm này cũng do các bác trên diễn đàn cho mình mót về mà.
Hề hề hề....

Có thể Cad đời sau phải thêm dòng (vl-load-com) ?
  • 2

#2285 w1nDream

w1nDream

    biết lệnh ddedit

  • Members
  • PipPipPipPip
  • 293 Bài viết
Điểm đánh giá: 73 (tàm tạm)

Đã gửi 18 October 2010 - 10:41 AM

Bạn xài thử cái này xem đã đúng ý chưa nhé.

Em đã thử lisp Artxt nhưng chẳng hiểu sao không select objects được.

Đây là cái mình chạy ra từ bản vẽ mẫu bạn post, nếu có gì chưa ổn hãy post lên nhé.
http://www.cadviet.c.../3/windream.jpg
Và đây là file cad đã chạy lisp. Rất tiếc trang upload của diễn đàn bị l64i kh6ng upload file được, mình sẽ up sau nếu cần đối chứng.
http://www.cadviet.c...m15__km16_2.dwg
Chúc bạn vui.

Link hỏng rồi Pác à.

Xin lỗi Bác Bình đúng là code đó sai mất vài chỗ do ẩu quá đây mà. Bạn w1ndream down code mới này nhé.


Em đã thử nhưng có vấn đề thế này anh à.Lisp đã làm được những điều mà em yêu cầu tuy nhiên nó thực hiện qua lâu.Lượng bản vẽ trắc ngang của em rất nhiều(ít nhất là 50 mặt cắt/1Km).Em thử chạy với 4 mặt cắt cũng đã fải mất đến 1 fút.
Lý do là hình như nó fải tìm đến tất cả các Point đặt text để nhạn dạng và sửa từng text 1.
Em không biết jì về lisp nên không biết xử lý tn.

Chào Bác bình phần code giãn text của em chạy thì cũng tạm được vì em dùng repeat ở đầu nên nó cũng sẽ giãn hết ra thôi. Nhưng nó có nhược điểm là không căn nhóm text giãn đều ra hai bên được. Cái này em mới làm lần đầu về giãn text.


Em có đoạn Lisp này dãn Text rất nhanh.Em gửi rồi bác xử lý kết hợp xem thế nào nhé:

 (defun c:gc ()
(BLIP)
(command "redraw")
(prompt "\nSelect text objects to evenly space: ")
(setq ssText (ssget '((0 . "TEXT")))); select text
(setq ssNumber (sslength ssText); lines of text
ssIndex ssNumber; pointer
ssY_Handles '() ; list of Y values and Handles
dYfactor 1.05 ; default Y displacement factor
)
(repeat ssNumber
(setq ssIndex (- ssIndex 1))
(setq eName (ssname ssText ssIndex)); entity name
(setq eData (entget eName))
(setq eY (car (assoc '10 eData))); entity Y location value
(setq eYe (/ eY 100000)) ; assure correct ordering
(setq eYe (+ eYe 5))
(setq eYe (rtos eYe 2 8)) ; change to a string
(setq eHnd (cdr (assoc '5 eData))); entity handle
(setq ssY_Handles
(cons (strcat eYe "*" eHnd) ; add string to
ssY_Handles ; list
)
)
);repeat
(setq ssY_Handles
(acad_strlsort ssY_Handles) ; sort in order of Y value
)
(setq ssIndex ssNumber; pointer
ssY '() ; sorted list of Y values
ssHandles '() ; sorted list of handles
)
(repeat ssNumber
(setq ssIndex (- ssIndex 1))
(setq eY_H ; entity Y value and handle
(nth ssIndex ssY_Handles)
)
(setq eSL (strlen eY_H)) ; entity string length
(setq eSLIndex 1) ; pointer
(repeat eSL
(if (/=
(substr eY_H eSLIndex 1) ; if substring is not "-"
"*"
)
(setq eSLIndex (+ eSLIndex 1)); go to next substring
)
); repeat

(setq eHnd
(substr eY_H (+ eSLIndex 1) eSL); entity handle
)
(setq
eName (handent eHnd); get name of entity
eData (entget eName); get entity data
eText (assoc 1 eData); get text
lName (assoc '-1 eData)
)
(if (= (- ssNumber 1) ssIndex); if this is first line of text
(progn
(setq
eX (cadr (assoc '10 eData)); X location value
eY (caddr (assoc '10 eData)); Y location
eZ (cadddr(assoc '10 eData)); Z location
eX1 (cadr (assoc '11 eData)); X location value
eY1 (caddr (assoc '11 eData)); Y location
eZ1 (cadddr(assoc '11 eData)); Z location
eH (cdr (assoc '40 eData)); text height
eColor (assoc 62 eData); color
); setq
(if (not eColor) (setq
eData (subst '(62 . 256) (assoc 62 eData) eData))
)
(setq
feData eData
)
);progn
(progn
(setq eX (- eX (* eH dYfactor))); otherwise decrease y value
(setq eX1 (- eX1 (* eH dYfactor))); otherwise decrease y1 value
)
);if
(setq eXYZ (list 10 eX eY eZ ))
(setq eXYZ1 (list 11 eX1 eY1 eZ1))
(setq eData feData)
(setq eData (subst eText (assoc 1 eData) eData))
(setq eData (subst eXYZ (assoc '10 eData) eData))
(setq eData (subst eXYZ1 (assoc '11 eData) eData))
(setq eData (subst (cons 5 eHnd) (assoc 5 eData) eData))
(setq eData (subst lName (assoc -1 eData) eData))
(entmod eData) ; modify text entity

); repeat
(unblip)
)
(defun BLIP ()
(setq sblip (getvar "blipmode")
scmde (getvar "cmdecho")
)
(setvar "blipmode" 0)
(setvar "cmdecho" 0)
(princ)
)
(defun UNBLIP ()
(setvar "blipmode" sblip)
(setvar "cmdecho" scmde)
(princ)
)
(princ)

Rất cảm ơn các Pác! :lol: !
  • 1
__Tâm tựa lưu thủY__
Vi nhân nan

#2286 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

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

Đã gửi 18 October 2010 - 12:10 PM

Em đã thử lisp Artxt nhưng chẳng hiểu sao không select objects được.

Link hỏng rồi Pác à.
Em đã thử nhưng có vấn đề thế này anh à.Lisp đã làm được những điều mà em yêu cầu tuy nhiên nó thực hiện qua lâu.Lượng bản vẽ trắc ngang của em rất nhiều(ít nhất là 50 mặt cắt/1Km).Em thử chạy với 4 mặt cắt cũng đã fải mất đến 1 fút.
Lý do là hình như nó fải tìm đến tất cả các Point đặt text để nhạn dạng và sửa từng text 1.
Em không biết jì về lisp nên không biết xử lý tn.
Em có đoạn Lisp này dãn Text rất nhanh.Em gửi rồi bác xử lý kết hợp xem thế nào nhé:
Rất cảm ơn các Pác! :lol: !

Hề hề hề,
Việc bạn không chọn được đối tượng text có thể là do cái bản vẽ của bạn sử dụng text height khác với cái bản vẽ bạn đã post lên diễn đàn. Trong bản vẽ của bạn post lên tất cả các text cần chỉnh sửa đều có text height là 4. Do vậy để cho đỡ mất công chọn nhầm đối tượng, trong hàm ssget mình đã lọc luôn chỉ lấy các đối tượng text có chiều cao text là 4 mà thôi.
Bạn có thể tự chỉnh lại việc này bằng cách bỏ đoạn code (cons 40 4) trong filter list của hàm ssget đi là OK.
Vì việc lựa chọn đối tượng mình sử dụng hàm ssget không có tham số cách lựa chọn nên bạn có thể chọn theo tất cả các cách select thường dùng mà không ngại điều gì. Miễn sao hợp ý bạn là được. Hề hê hề, nhớ là thêm thằng (vl-load-com) vào lisp như bác Giabach góp ý hoặc download lại cái lisp mình đã chỉnh sửa kẻo lại dính chấu giống bác phamngoctukts nha.

Không phải là link die mà là cái trang download và upload của diễn đàn bị cảm cúm đó thôi. Thi thoảng mình vẫn xài được, nhưng nhiều lúc cũng dính đòn như bạn. Hề hề hề.... Cái này phải bắt tội admin của bạn. Hề hề hề....

Cái lisp mà bạn post của một cao thủ nào đó, đọc nó thấy nhức hết cả đầu mà vẫn chả sáng ra được bao nhiêu. Cái luận lý của nó cao siêu quá, loại học mót như mình chắc phải lâu lâu nũa mới dám vọc vạch nó. Hề hề hề...... mà chưa vọc, chưa hiểu thì cũng chửa dám áp dụng bạn ạ. Bạn thông cảm nhé, chờ ít bữa nũa xem sao. Trong khi chờ đợi bạn có thể xài tạm cái của bác Phamngoctukts hay cái củ "lisp" xấu xấu của mình cho nó đỡ sốt ruột nhé. Hề hề hề

@ Bác Phamngoctukts: Cái lisp của bác chạy chậm một chút do bác sử dụng vòng lặp (while ......) Với một đối tượng nó lần lượt phải kiểm tra với tất cả các đối tượng được chọn còn lại nên số bước lặp sẽ là n x n bước mà khi n kha khá lớn thì cũng oải bác ạ.
Bác có thể cho thêm điều kiện kiểm tra trước khi lặp để hạn chế bớt số bước lặp này.
Bác cũng có thể loại bớt đi các đối tương không cần phải giãn trước khi lặp để giảm thiểu số bước lặp. Sau đó tách các đối tượng cần giãn thành từng nhóm nhỏ để giãn thì số bước lặp cũng giảm đi đáng kể bác ạ.
Trong lisp của bác không xét trường hợp củ chuối là nhỡ có hai text trùng nhau điểm đặt bác ạ.
Với trường hợp các text trùng nhau nhưng có thằng dọc thằng ngang bác cũng chưa loại trừ mà vẫn cho giãn. Vậy nếu các text này có điểm đặt gần nhau hơn là chiều cao text thì bác sẽ giãn ra sao nhỉ????

Hề hề hề, chúc mọi người một tuần mới thành công.
  • 1
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#2287 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 October 2010 - 03:28 PM

.........
tôi có ý này : Bài toán này chỉ cần tập trung vào giải quyết Cách tạo ra đuờng biên từ tập chọn (Line, Pline, Arc), vấn đề trích xuất tọa độ khi đã có đuờng bao là chuyện nhỏ (các bác cũng viết nhiều rồi).

Về Cách tạo ra đuờng biên từ tập chọn (Line, Pline, Arc) thì có 2 cách :
1. Ph/án của phamngoctukts
- break tất cả các đối tuợng tại điểm giao
- tạo Region với các đối tuợng vừa break
- convert các region thành Pline (xóa Pline bao trùm)
.........

Lisp tạo BOUNDARY từ tập chọn các LINE cải tiến từ lisp của phamngoctukts.
Nội dung chính :
- duyệt qua tất cả các đối tuợng
+ tìm giao điểm với tất cả các đối tuợng khác
+ vẽ LINE mới qua các giao điểm này
- tạo REGION từ tập các LINE mới tạo
- convert các region thành Pline (xóa Pline bao trùm)

Kết quả :
- tạo đuợc khoảng 99% Boundary nhưng chỉ chấp nhận LINE
- không bị mất đối tuợng ban đầu
(T/hợp muốn áp dụng cho Pline, Arc thì dùng Lisp Break_ALL của CAB)

(defun c:makeBo (/ boun_lst cnt i ov sec ss time vl)
(vl-load-com)
(command "_.undo" "_begin")
(if (setq ss (ssget '((0 . "LINE"))))
(progn
(setq vl '("DELOBJ" "CMDECHO") ; Sys Var list
ov (mapcar 'getvar vl)) ; Get Old values
(setq time (getvar "millisecs"))
(mapcar 'setvar vl '( 1 0))
(setq ss (break_SSLine ss))
(command "region" ss "")
(if (setq ss (ssget "x" '((0 . "region"))))
(progn
(setq i 0)
(while (< i (sslength ss))
(if (> (sslength ss) 50)
(princ (strcat "Objects Convert " (itoa i) "\r")) )
(command "explode" (ssname ss i))
(command "pedit" "l" "" "j" (ssget "p") "" "")
(setq boun_lst (cons (entlast) boun_lst))
(setq i (1+ i)) )
(setq boun_lst(moveAreaMax boun_lst))
(setq sec (/ (- (getvar "MILLISECS") time) 1000.0) )
(if (>(setq cnt (length boun_lst))0)
(princ (strcat "\nTao duoc " (itoa cnt)
" duong bao voi Th/gian = "(rtos sec 2 2) " s."))
(princ (strcat "\nSorry! Khong tao duoc duong bao!"))) ))
(mapcar 'setvar vl ov)))
(command "_.undo" "_end")
(princ))

(defun moveAreaMax (lst / area otmp tmp)
(setq tmp 0
otmp nil)
(foreach e lst
(if (> (setq area (vla-get-area (vlax-ename->vla-object e))) tmp)
(setq tmp area
otmp e)) )
(if otmp
(progn
(entdel otmp)
(vl-remove otmp lst) ) ))

(defun break_SSLine (ss / ds ent intpts lastentindatabase lst masterlist oc sslst)
(defun ssget->vla-list (ss / i ename allobj)
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(setq allobj (cons (vlax-ename->vla-object ename) allobj)) )
allobj )

(defun list->3pair (old / new)
(while (setq new (cons (list (car old) (cadr old) (caddr old)) new)
old (cdddr old)))
(reverse new) )

(defun get_interpts (obj1 obj2 / iplist)
(if (not (vl-catch-all-error-p
(setq iplist (vl-catch-all-apply
'vlax-safearray->list
(list
(vlax-variant-value
(vla-intersectwith obj1 obj2 acextendnone) ))))))
iplist ))

;;====================================
;; CAB - get last entity in datatbase
(defun GetLastEnt ( / ename result )
(if (setq result (entlast))
(while (setq ename (entnext result))
(setq result ename) ) )
result)

(defun GetNewSS (ename / new)
(setq new (ssadd))
(cond
((null ename) (alert "Ename nil"))
((eq 'ENAME (type ename))
(while (setq ename (entnext ename))
(if (entget ename) (ssadd ename new)) ) )
((alert "Ename wrong type.")) )
new)

(defun break_line (ent brkptlst / pt1 pt2 x)
(if brkptlst
(progn
(setq brkptlst (mapcar '(lambda(x) (list x (vlax-curve-getdistatparam ent
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint ent x))
((vlax-curve-getparamatpoint ent
(vlax-curve-getclosestpointto ent x))))))
) brkptlst))
;; sort primary list on distance
(setq brkptlst (vl-sort brkptlst '(lambda (a1 a2) (< (cadr a1) (cadr a2)))))
(setq pt1 (car(car brkptlst)))
(foreach e (cdr brkptlst)
(setq pt2 (car e))
(entmake (list '(0 . "LINE")(cons 10 pt1)(cons 11 pt2) ))
(setq pt1 pt2)
(and *BrkVerbose* (princ (setq *brkcnt* (1+ *brkcnt*))) (princ "\r")) ) ) ))

;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S T A R T S U B R O U T I N E H E R E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(setq LastEntInDatabase (GetLastEnt))
(if ss
(progn
(setq oc 0
ssLst (ssget->vla-list ss))
(if (> (length ssLst) 22) (setq *BrkVerbose* t) )
(and *BrkVerbose*
(princ (strcat "Objects to be Checked: "
(rtos (* 0.5(length ssLst)(length ssLst))2 0) "\n")))
;; CREATE a list of entity & it's break points
(foreach obj ssLst
(setq lst nil)
;; check for break pts with other objects in ss2brkwith
(foreach intobj (vl-remove obj ssLst)
(if (and (not (equal obj intobj))
(setq intpts (get_interpts obj intobj)))
(setq lst (append (list->3pair intpts) lst)) ) )
(if lst
(setq masterlist (cons (cons (vlax-vla-object->ename obj) lst) masterlist)) ) )

(and *BrkVerbose* (princ "\nBreaking Objects.\n"))
(setq *brkcnt* 0) ; break counter
(if masterlist
(foreach obj2brk masterlist
(break_line (car obj2brk) (cdr obj2brk)) ) ) ) )
;;==============================================================
(and (zerop *brkcnt*) (princ "\nNone to be broken."))
(setq *BrkVerbose* nil)
(GetNewSS LastEntInDatabase) ; return list of enames of new objects
)

  • 2

#2288 DuongTrungHuy

DuongTrungHuy

    biết lệnh copy

  • Members
  • PipPipPip
  • 116 Bài viết
Điểm đánh giá: 41 (tàm tạm)

Đã gửi 18 October 2010 - 04:04 PM

Lisp tạo BOUNDARY từ tập chọn
Thấy các Bạn thảo luận hăng hái đề tài này quá!
Cái này của mấy Bạn mình chỉ thêm mắm muối 1 chút. Các Bạn test thử xem có đạt yêu cầu không!
Dùng cho cả ARC nửa. Nó vẫn còn chưa tốt như có Bạn nói nếu miền quá nhỏ thì bị bỏ qua!
Có Bạn góp ý là lúc này nên Zoom to vùng đó lên 1 tí...
Kết quả là các Region.
http://www.cadviet.c...iles/3/new2.lsp

:lol:
Bạn thêm giúp đoạn này
(Defun Mid0(ddA ddB)
(setq diemgiua (list (* 0.5 (+ (car dda)(car ddb))) (* 0.5 (+ (cadr dda)(cadr ddb)))))
)
  • 1

#2289 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 October 2010 - 04:26 PM

Lisp tạo BOUNDARY từ tập chọn
Thấy các Bạn thảo luận hăng hái đề tài này quá!
Cái này của mấy Bạn mình chỉ thêm mắm muối 1 chút. Các Bạn test thử xem có đạt yêu cầu không!
Dùng cho cả ARC nửa. Nó vẫn còn chưa tốt như có Bạn nói nếu miền quá nhỏ thì bị bỏ qua!
Có Bạn góp ý là lúc này nên Zoom to vùng đó lên 1 tí...
Kết quả là các Region.
http://www.cadviet.c...iles/3/new2.lsp

Lisp của bác thiếu hàm Mid0 .
Tôi tự chế ra hàm này, không biết có đúng không ?
(defun Mid0 (p1 p2)
(mapcar
'(lambda (x)
(/ x 2.) )
(mapcar '+ p1 p2 ) ))

  • 0

#2290 phamngoctukts

phamngoctukts

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1107 Bài viết
Điểm đánh giá: 696 (tốt)

Đã gửi 18 October 2010 - 04:29 PM

Lisp tạo BOUNDARY từ tập chọn
Thấy các Bạn thảo luận hăng hái đề tài này quá!
Cái này của mấy Bạn mình chỉ thêm mắm muối 1 chút. Các Bạn test thử xem có đạt yêu cầu không!
Dùng cho cả ARC nửa. Nó vẫn còn chưa tốt như có Bạn nói nếu miền quá nhỏ thì bị bỏ qua!
Có Bạn góp ý là lúc này nên Zoom to vùng đó lên 1 tí...
Kết quả là các Region.
http://www.cadviet.c...iles/3/new2.lsp

Bác ơi báo lỗi thiếu hàm.
; error: no function definition: MID0
  • 0
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!

#2291 DuongTrungHuy

DuongTrungHuy

    biết lệnh copy

  • Members
  • PipPipPip
  • 116 Bài viết
Điểm đánh giá: 41 (tàm tạm)

Đã gửi 18 October 2010 - 04:46 PM

[quote name='phamngoctukts' date='Oct 18 2010, 16:29' post='112819']
Bạn thêm giúp đoạn này: Là điểm giữa í mà...
(Defun Mid0(ddA ddB)
(setq diemgiua (list (* 0.5 (+ (car dda)(car ddb))) (* 0.5 (+ (cadr dda)(cadr ddb)))))
)
  • 0

#2292 phamngoctukts

phamngoctukts

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1107 Bài viết
Điểm đánh giá: 696 (tốt)

Đã gửi 18 October 2010 - 05:10 PM

Lisp tạo BOUNDARY từ tập chọn các LINE cải tiến từ lisp của phamngoctukts.
Nội dung chính :
- duyệt qua tất cả các đối tuợng
+ tìm giao điểm với tất cả các đối tuợng khác
+ vẽ LINE mới qua các giao điểm này
- tạo REGION từ tập các LINE mới tạo
- convert các region thành Pline (xóa Pline bao trùm)

Kết quả :
- tạo đuợc khoảng 99% Boundary nhưng chỉ chấp nhận LINE
- không bị mất đối tuợng ban đầu
(T/hợp muốn áp dụng cho Pline, Arc thì dùng Lisp Break_ALL của CAB)

(defun c:makeBo (/ boun_lst cnt i ov sec ss time vl)
(vl-load-com)
(command "_.undo" "_begin")
(if (setq ss (ssget '((0 . "LINE"))))
(progn
(setq vl '("DELOBJ" "CMDECHO") ; Sys Var list
ov (mapcar 'getvar vl)) ; Get Old values
(setq time (getvar "millisecs"))
(mapcar 'setvar vl '( 1 0))
(setq ss (break_SSLine ss))
(command "region" ss "")
(if (setq ss (ssget "x" '((0 . "region"))))
(progn
(setq i 0)
(while (< i (sslength ss))
(if (> (sslength ss) 50)
(princ (strcat "Objects Convert " (itoa i) "\r")) )
(command "explode" (ssname ss i))
(command "pedit" "l" "" "j" (ssget "p") "" "")
(setq boun_lst (cons (entlast) boun_lst))
(setq i (1+ i)) )
(setq boun_lst(moveAreaMax boun_lst))
(setq sec (/ (- (getvar "MILLISECS") time) 1000.0) )
(if (>(setq cnt (length boun_lst))0)
(princ (strcat "\nTao duoc " (itoa cnt)
" duong bao voi Th/gian = "(rtos sec 2 2) " s."))
(princ (strcat "\nSorry! Khong tao duoc duong bao!"))) ))
(mapcar 'setvar vl ov)))
(command "_.undo" "_end")
(princ))

(defun moveAreaMax (lst / area otmp tmp)
(setq tmp 0
otmp nil)
(foreach e lst
(if (> (setq area (vla-get-area (vlax-ename->vla-object e))) tmp)
(setq tmp area
otmp e)) )
(if otmp
(progn
(entdel otmp)
(vl-remove otmp lst) ) ))

(defun break_SSLine (ss / ds ent intpts lastentindatabase lst masterlist oc sslst)
(defun ssget->vla-list (ss / i ename allobj)
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(setq allobj (cons (vlax-ename->vla-object ename) allobj)) )
allobj )

(defun list->3pair (old / new)
(while (setq new (cons (list (car old) (cadr old) (caddr old)) new)
old (cdddr old)))
(reverse new) )

(defun get_interpts (obj1 obj2 / iplist)
(if (not (vl-catch-all-error-p
(setq iplist (vl-catch-all-apply
'vlax-safearray->list
(list
(vlax-variant-value
(vla-intersectwith obj1 obj2 acextendnone) ))))))
iplist ))

;;====================================
;; CAB - get last entity in datatbase
(defun GetLastEnt ( / ename result )
(if (setq result (entlast))
(while (setq ename (entnext result))
(setq result ename) ) )
result)

(defun GetNewSS (ename / new)
(setq new (ssadd))
(cond
((null ename) (alert "Ename nil"))
((eq 'ENAME (type ename))
(while (setq ename (entnext ename))
(if (entget ename) (ssadd ename new)) ) )
((alert "Ename wrong type.")) )
new)

(defun break_line (ent brkptlst / pt1 pt2 x)
(if brkptlst
(progn
(setq brkptlst (mapcar '(lambda(x) (list x (vlax-curve-getdistatparam ent
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint ent x))
((vlax-curve-getparamatpoint ent
(vlax-curve-getclosestpointto ent x))))))
) brkptlst))
;; sort primary list on distance
(setq brkptlst (vl-sort brkptlst '(lambda (a1 a2) (< (cadr a1) (cadr a2)))))
(setq pt1 (car(car brkptlst)))
(foreach e (cdr brkptlst)
(setq pt2 (car e))
(entmake (list '(0 . "LINE")(cons 10 pt1)(cons 11 pt2) ))
(setq pt1 pt2)
(and *BrkVerbose* (princ (setq *brkcnt* (1+ *brkcnt*))) (princ "\r")) ) ) ))

;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S T A R T S U B R O U T I N E H E R E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(setq LastEntInDatabase (GetLastEnt))
(if ss
(progn
(setq oc 0
ssLst (ssget->vla-list ss))
(if (> (length ssLst) 22) (setq *BrkVerbose* t) )
(and *BrkVerbose*
(princ (strcat "Objects to be Checked: "
(rtos (* 0.5(length ssLst)(length ssLst))2 0) "\n")))
;; CREATE a list of entity & it's break points
(foreach obj ssLst
(setq lst nil)
;; check for break pts with other objects in ss2brkwith
(foreach intobj (vl-remove obj ssLst)
(if (and (not (equal obj intobj))
(setq intpts (get_interpts obj intobj)))
(setq lst (append (list->3pair intpts) lst)) ) )
(if lst
(setq masterlist (cons (cons (vlax-vla-object->ename obj) lst) masterlist)) ) )

(and *BrkVerbose* (princ "\nBreaking Objects.\n"))
(setq *brkcnt* 0) ; break counter
(if masterlist
(foreach obj2brk masterlist
(break_line (car obj2brk) (cdr obj2brk)) ) ) ) )
;;==============================================================
(and (zerop *brkcnt*) (princ "\nNone to be broken."))
(setq *BrkVerbose* nil)
(GetNewSS LastEntInDatabase) ; return list of enames of new objects
)

Chào Bác gia_bach!
Em đã test code của bác. Lisp chạy ổn định nhưng nếu sử dụng cho nhiều nhóm đối tượng thì nó không xoá được các Boundary ngoài cùng. Cái này trước em cũng bị vấp phải. Dùng thuật toán của bác TRUNGNGAMY mới giải quyết được cái thằng này.
  • 1
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!

#2293 phamngoctukts

phamngoctukts

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1107 Bài viết
Điểm đánh giá: 696 (tốt)

Đã gửi 18 October 2010 - 05:17 PM

Bạn thêm giúp đoạn này: Là điểm giữa í mà...
(Defun Mid0(ddA ddB)
(setq diemgiua (list (* 0.5 (+ (car dda)(car ddb))) (* 0.5 (+ (cadr dda)(cadr ddb)))))
)

Lisp của Bác chạy khá tốt xong tốc độ lại bị chậm. Thank Bác đã tham gia
BS:chưa xoá point, không undo được, chưa trả lại biến hệ thống.
  • 0
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!

#2294 w1nDream

w1nDream

    biết lệnh ddedit

  • Members
  • PipPipPipPip
  • 293 Bài viết
Điểm đánh giá: 73 (tàm tạm)

Đã gửi 18 October 2010 - 05:42 PM

Hề hề hề,
Việc bạn không chọn được đối tượng text có thể là do cái bản vẽ của bạn sử dụng text height khác với cái bản vẽ bạn đã post lên diễn đàn. Trong bản vẽ của bạn post lên tất cả các text cần chỉnh sửa đều có text height là 4. Do vậy để cho đỡ mất công chọn nhầm đối tượng, trong hàm ssget mình đã lọc luôn chỉ lấy các đối tượng text có chiều cao text là 4 mà thôi.
Bạn có thể tự chỉnh lại việc này bằng cách bỏ đoạn code (cons 40 4) trong filter list của hàm ssget đi là OK.
Vì việc lựa chọn đối tượng mình sử dụng hàm ssget không có tham số cách lựa chọn nên bạn có thể chọn theo tất cả các cách select thường dùng mà không ngại điều gì. Miễn sao hợp ý bạn là được. Hề hê hề, nhớ là thêm thằng (vl-load-com) vào lisp như bác Giabach góp ý hoặc download lại cái lisp mình đã chỉnh sửa kẻo lại dính chấu giống bác phamngoctukts nha.

Không phải là link die mà là cái trang download và upload của diễn đàn bị cảm cúm đó thôi. Thi thoảng mình vẫn xài được, nhưng nhiều lúc cũng dính đòn như bạn. Hề hề hề.... Cái này phải bắt tội admin của bạn. Hề hề hề....

Cái lisp mà bạn post của một cao thủ nào đó, đọc nó thấy nhức hết cả đầu mà vẫn chả sáng ra được bao nhiêu. Cái luận lý của nó cao siêu quá, loại học mót như mình chắc phải lâu lâu nũa mới dám vọc vạch nó. Hề hề hề...... mà chưa vọc, chưa hiểu thì cũng chửa dám áp dụng bạn ạ. Bạn thông cảm nhé, chờ ít bữa nũa xem sao. Trong khi chờ đợi bạn có thể xài tạm cái của bác Phamngoctukts hay cái củ "lisp" xấu xấu của mình cho nó đỡ sốt ruột nhé. Hề hề hề

@ Bác Phamngoctukts: Cái lisp của bác chạy chậm một chút do bác sử dụng vòng lặp (while ......) Với một đối tượng nó lần lượt phải kiểm tra với tất cả các đối tượng được chọn còn lại nên số bước lặp sẽ là n x n bước mà khi n kha khá lớn thì cũng oải bác ạ.
Bác có thể cho thêm điều kiện kiểm tra trước khi lặp để hạn chế bớt số bước lặp này.
Bác cũng có thể loại bớt đi các đối tương không cần phải giãn trước khi lặp để giảm thiểu số bước lặp. Sau đó tách các đối tượng cần giãn thành từng nhóm nhỏ để giãn thì số bước lặp cũng giảm đi đáng kể bác ạ.
Trong lisp của bác không xét trường hợp củ chuối là nhỡ có hai text trùng nhau điểm đặt bác ạ.
Với trường hợp các text trùng nhau nhưng có thằng dọc thằng ngang bác cũng chưa loại trừ mà vẫn cho giãn. Vậy nếu các text này có điểm đặt gần nhau hơn là chiều cao text thì bác sẽ giãn ra sao nhỉ????

Hề hề hề, chúc mọi người một tuần mới thành công.


Thks Pác nhìu!
Mong Pác và mọi người hoàn thiện giúp em con Lisp này với.
:lol: :lol:
  • 0
__Tâm tựa lưu thủY__
Vi nhân nan

#2295 phamngoctukts

phamngoctukts

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1107 Bài viết
Điểm đánh giá: 696 (tốt)

Đã gửi 18 October 2010 - 08:28 PM

Chào bạn PhamngocTukts

Việc bạn cho rằng "Còn các boundary là arc hoặc pline cong thực ra trong chắc địa rất ít dùng" thì mình không đồng ý. Vì thực ra có những thửa đất có hình dạng bất kì, thửa đất vẫn có những đoạn bo thì việc sử dụng Arc hoặc Pline có phân đoạn Arc để biểu diễn khá nhiều đấy, bạn ạ. Có phải lúc nào thửa đất cũng "thẳng tưng như dây đàn" đâu bạn ạ, vẫn có những đoạn bo chứ. Cứ cho là thửa đất bạn biểu diễn bằng Line hết đi, nhưng nếu thửa đó chỉ có 1 đoạn bo bằng Arc hay Pline chứa Arc thì Lisp chưa giải quyết được. Việc lưu ý về phân đoạn Arc hay Pline chứa Arc thì Tue_NV đã lưu ý với bạn trước khi bạn viết Lisp này rồi bạn à

Chào bác Tue_VN em đã nghiên cứu tiếp phần pline cong và arc. Em port lên đây Các Bác test giúp xem còn lỗi gì không nhé.

;; free lisp from cadviet.com
(defun ndt();Nhom doi tuong
(setq tbl (tblsearch "layer" "point_template"))
(if (= tbl nil) (command "-layer" "n" "point_template" ""))
(setq sn 1 list_plmoi nil list_pl nil lss nil)
(while (setq ss (ssget "x" '((0 . "lwpolyline"))))
(command "explode" ss)
)
(setq ss (ssget '((0 . "line,arc"))))
(setq lss (append lss (list ss)))
(command "zoom" "e")
(creatbo lss)
)

(defun creatbo ( lss / )
(setq k 0 list_point (ssadd))
(while (< k (length lss))
(setq ss (nth k lss))
(setq i 0)
(while (< i (sslength ss))
(setq name (ssname ss i)
ent (entget name))
(if (/= (cdr (assoc 0 ent)) "ARC")
(progn
(setq p1 (cdr (assoc 10 ent))
p2 (cdr (assoc 11 ent)))
)
)
(if (= (cdr (assoc 0 ent)) "ARC")
(progn
(setq dgiua (midarc name)
p1 pdau
p2 pcuoi)
)
)
(setq j 0)
(while (and (< j (sslength ss)) (/= j i))
(setq name1 (ssname ss j)
ent1 (entget name1))
(if (/= (cdr (assoc 0 ent1)) "ARC")
(progn
(setq p3 (cdr (assoc 10 ent1))
p4 (cdr (assoc 11 ent1)))
)
)
(if (= (cdr (assoc 0 ent1)) "ARC")
(progn
(setq dgiua (midarc name1)
p3 pdau
p4 pcuoi)
)
)
(setq giao (inter name name1))
(if (and (/= (cdr (assoc 0 ent1)) "ARC") (/= (cdr (assoc 0 ent2)) "ARC"))
(progn
(if (and (/= giao nil) (not (equal giao p1 0.01)) (not (equal giao p2 0.01)))
(progn
(entmake (subst (cons 11 giao) (assoc 11 ent) ent))
(setq lm (entlast) ss (ssadd lm ss))
(entmod (subst (cons 10 giao) (assoc 10 ent) ent))
)
)
(if (and (/= giao nil) (not (equal giao p3 0.01)) (not (equal giao p4 0.01)))
(progn
(entmake (subst (cons 11 giao) (assoc 11 ent1) ent1))
(setq lm (entlast) ss (ssadd lm ss))
(entmod (subst (cons 10 giao) (assoc 10 ent1) ent1))
)
)
)
)
(if (and (/= giao nil) (= (cdr (assoc 0 ent)) "ARC") (/= (cdr (assoc 0 ent1)) "ARC")
(not (equal giao p1 0.01)) (not (equal giao p2 0.01)))
(progn
(breakarc name giao)
(entmake (subst (cons 11 giao) (assoc 11 ent1) ent1))
(setq lm (entlast) ss (ssadd lm ss))
(entmod (subst (cons 10 giao) (assoc 10 ent1) ent1))
)
)
(if (and (/= giao nil) (= (cdr (assoc 0 ent1)) "ARC") (/= (cdr (assoc 0 ent)) "ARC")
(not (equal giao p3 0.01)) (not (equal giao p4 0.01)))
(progn
(breakarc name1 giao)
(entmake (subst (cons 11 giao) (assoc 11 ent) ent))
(setq lm (entlast) ss (ssadd lm ss))
(entmod (subst (cons 10 giao) (assoc 10 ent) ent))
)
)
(if (and (/= giao nil) (= (cdr (assoc 0 ent)) "ARC") (= (cdr (assoc 0 ent1)) "ARC")
(not (equal giao p1 0.01)) (not (equal giao p2 0.01))
(not (equal giao p3 0.01)) (not (equal giao p4 0.01)))
(progn
(breakarc name giao)
(breakarc name1 giao)
)
)
(setq j (1+ j))
)
(setq i (1+ i))
)
(command "region" ss "")
(command "erase" ss "")
(setq ss (ssget "x" '((0 . "region"))))
(setq i 0)
(setq list_pl (ssadd))
(while (< i (sslength ss))
(setq reg (ssname ss i))
(command "explode" reg)
(setq plp (ssget "p"))
(command "pedit" "l" "" "j" plp "" "")
(setq boun (entlast))
(setq list_pl (ssadd boun list_pl))
(setq i (1+ i))
)
(locbo)
(setq k (1+ k))
)
)

(defun locbo ()
(setq i 0)
(while (< i (sslength list_pl))
(setq namel (ssname list_pl i))
(setq ptt (centroid namel))
(command "point" ptt)
(setq poi (entlast)
list_point (ssadd poi list_point))
(command "change" list_point "" "p" "la" "point_template" "")
(setq i (1+ i))
)
(setq i 0)
(while (< i (sslength list_pl))
(setq namel (ssname list_pl i))
(setq ob (vlax-ename->vla-object namel)
c 0 dsp nil)
(while (/= (vlax-curve-getPointAtParam ob c) nil)
(setq pt (vlax-curve-getPointAtParam ob c))
(setq dsp (append (list pt) dsp))
(setq c (1+ c))
)
(setq ssdk (ssget "Wp" dsp (list (cons 0 "point") (cons 8 "point_template"))))
(if (> (sslength ssdk) 2)
(progn
(command "erase" namel "")
(setq ss_pl (ssdel namel list_pl))
(setq nhomss (append (list (ssget "cp" dsp '((0 . "lwpolyline")))) nhomss))
)
)
(if (= (sslength (ssget "cp" dsp '((0 . "lwpolyline")))) 1)
(setq nhomss (append (list (ssget "cp" dsp '((0 . "lwpolyline")))) nhomss))
)
(setq i (1+ i))
)
(command "erase" list_point "")
)


(defun c:tddmoi ()
(inittdd)
(command "undo" "be")
(setq dlst (list (strcat "X" "\t" "\t" "Y" "\n"))
oldos (getvar "osmode")
pg (getvar "ucsorg")
pw (getpoint "\n Chon goc toa do ")
id 1
ptlst nil
dlst1 nil
list_pl nil
list_chu (ssadd)
nhomss nil
)
(ndt)
(setvar "osmode" 0)
(if (= pw nil) (setq pW (list 0 0 0)))
(setq k 0)
(while (< k (length nhomss))
(setq sscon (nth k nhomss))
(setq ssmoi (sapxep sscon))
(setq p 0)
(while (< p (sslength ssmoi))
(setq name (ssname ssmoi p))
(command "area" "o" name)
(setq i 0
ptlst nil
obj (vlax-ename->vla-object name)
dlst1 (append (list (strcat "hinh thu: " (rtos id 2 0) " dien tich: " (rtos (getvar "area") 2 3))) dlst1)
)
(setq ptam (centroid name))
(if (eq (cdr (assoc 40 (tblsearch "style" (getvar "textstyle")))) 0)
(command "text" "j" "m" ptam "" "" (rtos id 2 0))
(command "text" "j" "m" ptam "" (rtos id 2 0))
)
(setq list_chu (ssadd (entlast) list_chu))
(while (/= (vlax-curve-getPointAtParam obj (1+ i)) nil)
(setq p1 (vlax-curve-getPointAtParam obj i))
(setq dlst1 (append (list (strcat (rtos (- (car p1) (car pw) (car pg)) 2 3)
"\t"
"\t"
(rtos (- (cadr p1) (cadr pw) (cadr pg)) 2 3)
)
)
dlst1))
(setq ptlst (append (list p1) ptlst))
(setq i (1+ i))
)
(setq p (1+ p))
(setq dlst1 (append (list "\n") dlst1))
(setq dlst (append dlst1 dlst))
(setq dlst1 nil)
(setq id (1+ id))
)
(setq k (1+ k))
)
(setq dlst (reverse dlst))
(alert (strcat "Qua trinh da hoan thanh. Chon duong dan de luu file toa do"))
(setq file (getfiled "chon duong dan de luu file" (getvar "DWGPREFIX") "txt" 1))
(setq opw (open file "w"))
(foreach n dlst (write-line n opw))
(close opw)
(command "_.copyclip" list_chu "")
(command "block" "chu" "0,0" list_chu "")
(command "insert" "chu" "0,0" "" "" "")
(setq pchu (nth 0 (acet-ent-geomextents (entlast))))
(setvar "osmode" oldos)
(command "undo" "e")
(command "undo" "")
(command "_.pasteclip" pchu)
(alert (strcat "file da duoc luu tai: " file))
(startapp "notepad" file)
)

(defun inittdd ()
(setq
tdd_old_er *error*
*error* tdderror
)
)

(defun tdderror (errmsg)
(loitdd)
)


(defun loitdd ()
(setq *error* tdd_old_er)
(command "undo" "end")
(command "undo" "")
(princ "xay ra loi trong qua trinh thao tac")
)

(defun centroid (e / op ptam)
(vl-load-com)
(command "region" e "")
(setq re (entlast))
(setq ob (vlax-ename->vla-object re)
ptam (vlax-safearray->list (vlax-variant-value (vla-get-Centroid ob)))
)
(command "undo" 1)
ptam
)

(defun sapxep ( sscu /)
(setq i 0 l_i nil l_ps nil)
(while (< i (sslength sscu))
(setq ename (ssname sscu i))
(setq ps (centroid ename))
(setq l_ps (append (list (+ (cadr ps) (* i 0.001))) l_ps)
l_i (append (list i) l_i)
)
(setq i (1+ i))
)
(setq ssmoi (ssadd))
(setq m 0)
(while (/= l_i nil)
(setq nho (apply 'max l_ps))
(setq kt (nth (vl-position nho l_ps) l_i))
(setq ssmoi (ssadd (ssname sscu kt) ssmoi))
(setq l_ps (vl-remove nho l_ps))
(setq l_i (vl-remove kt l_i))
(setq m (1+ m))
)
ssmoi
)


(defun inter ( t1 t2 / ob1 ob2 g kq sd)
(Vl-Load-Com)
(setq ob1 (vlax-ename->vla-object t1)
ob2 (vlax-ename->vla-object t2)
)
(setq g (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone)))
(if (/= (vlax-safearray-get-u-bound g 1) -1)
(setq g (vlax-safearray->list g))
(setq g nil)
)
g
)

(defun breakarc ( n1 pn / )
(setq entarc (entget n1)
tam (cdr (assoc 10 entarc))
bk (cdr (assoc 40 entarc))
pdau (polar tam (cdr (assoc 50 entarc)) bk)
pcuoi (polar tam (cdr (assoc 51 entarc)) bk)
ang (angle tam pn)
)
(entmod (subst (cons 50 ang) (assoc 50 entarc) entarc))
(entmakex (subst (cons 51 ang) (assoc 51 entarc) entarc))
(setq lm (entlast) ss (ssadd lm ss))
)

(defun midarc ( n1 /)
(setq entarc (entget n1)
tam (cdr (assoc 10 entarc))
bk (cdr (assoc 40 entarc))
pdau (polar tam (cdr (assoc 50 entarc)) bk)
pcuoi (polar tam (cdr (assoc 51 entarc)) bk)
pgiua (polar pdau (angle pdau pcuoi) (/ (distance pdau pcuoi) 2))
)
pgiua
)

Hình đã gửi
  • 0
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!

#2296 tamkt

tamkt

    biết vẽ ellipse

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

Đã gửi 18 October 2010 - 09:19 PM

E thấy kết quả bị lỗi anh ah, anh xem lại giúp em nha.lisp a nó xuất ra như vậy:
1,d 12,2184.71,7.71
2,d 12,2209.28,.62
3,d 12,2209.28,10.62
4,d 12,2209.28,20.62
5,d 12,2209.28,30.62
6,d 12,2209.28,40.62
7,d 12,2209.28,50.62
8,d 12,2216.78,50.62
9,d 12,2224.28,50.62
10,d 12,2231.76,50.62
11,d 12,2239.26,50.62
12,d 12,2239.28,40.62
13,d 12,2239.28,30.62
14,d 12,2239.28,20.62
15,d 12,2239.28,10.62
16,d 12,2239.28,.62
17,d 12,2231.76,.62
18,d 12,2224.28,.62
19,d 12,2216.78,.62
Hoàn tòan chính xác với cấu trúc mà e cần, nhưng tọa độ không chính xác anh.
E xài Cad2010 nên không load VBA được, anh chuyển sang dạng LSP được không ha.
Mong mấy a giúp em.
File Cad: http://www.mediafire...8stz8i1gmxc7ibd

huhu, sao không ai giúp e hết vậy???
  • 0

#2297 Tue_NV

Tue_NV

    KS Võ Quang Tuệ

  • Moderator
  • PipPipPipPipPipPipPip
  • 4296 Bài viết
Điểm đánh giá: 3804 (đỉnh cao)

Đã gửi 18 October 2010 - 09:54 PM

Chào bác Tue_VN em đã nghiên cứu tiếp phần pline cong và arc. Em port lên đây Các Bác test giúp xem còn lỗi gì không nhé.


;; free lisp from cadviet.com
(defun ndt();Nhom doi tuong
(setq tbl (tblsearch "layer" "point_template"))
(if (= tbl nil) (command "-layer" "n" "point_template" ""))
(setq sn 1 list_plmoi nil list_pl nil lss nil)
(while (setq ss (ssget "x" '((0 . "lwpolyline"))))
(command "explode" ss)
)
(setq ss (ssget '((0 . "line,arc"))))
(setq lss (append lss (list ss)))
(command "zoom" "e")
(creatbo lss)
)

(defun creatbo ( lss / )
(setq k 0 list_point (ssadd))
(while (< k (length lss))
(setq ss (nth k lss))
(setq i 0)
(while (< i (sslength ss))
(setq name (ssname ss i)
ent (entget name))
(if (/= (cdr (assoc 0 ent)) "ARC")
(progn
(setq p1 (cdr (assoc 10 ent))
p2 (cdr (assoc 11 ent)))
)
)
(if (= (cdr (assoc 0 ent)) "ARC")
(progn
(setq dgiua (midarc name)
p1 pdau
p2 pcuoi)
)
)
(setq j 0)
(while (and (< j (sslength ss)) (/= j i))
(setq name1 (ssname ss j)
ent1 (entget name1))
(if (/= (cdr (assoc 0 ent1)) "ARC")
(progn
(setq p3 (cdr (assoc 10 ent1))
p4 (cdr (assoc 11 ent1)))
)
)
(if (= (cdr (assoc 0 ent1)) "ARC")
(progn
(setq dgiua (midarc name1)
p3 pdau
p4 pcuoi)
)
)
(setq giao (inter name name1))
(if (and (/= (cdr (assoc 0 ent1)) "ARC") (/= (cdr (assoc 0 ent2)) "ARC"))
(progn
(if (and (/= giao nil) (not (equal giao p1 0.01)) (not (equal giao p2 0.01)))
(progn
(entmake (subst (cons 11 giao) (assoc 11 ent) ent))
(setq lm (entlast) ss (ssadd lm ss))
(entmod (subst (cons 10 giao) (assoc 10 ent) ent))
)
)
(if (and (/= giao nil) (not (equal giao p3 0.01)) (not (equal giao p4 0.01)))
(progn
(entmake (subst (cons 11 giao) (assoc 11 ent1) ent1))
(setq lm (entlast) ss (ssadd lm ss))
(entmod (subst (cons 10 giao) (assoc 10 ent1) ent1))
)
)
)
)
(if (and (/= giao nil) (= (cdr (assoc 0 ent)) "ARC") (/= (cdr (assoc 0 ent1)) "ARC")
(not (equal giao p1 0.01)) (not (equal giao p2 0.01)))
(progn
(breakarc name giao)
(entmake (subst (cons 11 giao) (assoc 11 ent1) ent1))
(setq lm (entlast) ss (ssadd lm ss))
(entmod (subst (cons 10 giao) (assoc 10 ent1) ent1))
)
)
(if (and (/= giao nil) (= (cdr (assoc 0 ent1)) "ARC") (/= (cdr (assoc 0 ent)) "ARC")
(not (equal giao p3 0.01)) (not (equal giao p4 0.01)))
(progn
(breakarc name1 giao)
(entmake (subst (cons 11 giao) (assoc 11 ent) ent))
(setq lm (entlast) ss (ssadd lm ss))
(entmod (subst (cons 10 giao) (assoc 10 ent) ent))
)
)
(if (and (/= giao nil) (= (cdr (assoc 0 ent)) "ARC") (= (cdr (assoc 0 ent1)) "ARC")
(not (equal giao p1 0.01)) (not (equal giao p2 0.01))
(not (equal giao p3 0.01)) (not (equal giao p4 0.01)))
(progn
(breakarc name giao)
(breakarc name1 giao)
)
)
(setq j (1+ j))
)
(setq i (1+ i))
)
(command "region" ss "")
(command "erase" ss "")
(setq ss (ssget "x" '((0 . "region"))))
(setq i 0)
(setq list_pl (ssadd))
(while (< i (sslength ss))
(setq reg (ssname ss i))
(command "explode" reg)
(setq plp (ssget "p"))
(command "pedit" "l" "" "j" plp "" "")
(setq boun (entlast))
(setq list_pl (ssadd boun list_pl))
(setq i (1+ i))
)
(locbo)
(setq k (1+ k))
)
)

(defun locbo ()
(setq i 0)
(while (< i (sslength list_pl))
(setq namel (ssname list_pl i))
(setq ptt (centroid namel))
(command "point" ptt)
(setq poi (entlast)
list_point (ssadd poi list_point))
(command "change" list_point "" "p" "la" "point_template" "")
(setq i (1+ i))
)
(setq i 0)
(while (< i (sslength list_pl))
(setq namel (ssname list_pl i))
(setq ob (vlax-ename->vla-object namel)
c 0 dsp nil)
(while (/= (vlax-curve-getPointAtParam ob c) nil)
(setq pt (vlax-curve-getPointAtParam ob c))
(setq dsp (append (list pt) dsp))
(setq c (1+ c))
)
(setq ssdk (ssget "Wp" dsp (list (cons 0 "point") (cons 8 "point_template"))))
(if (> (sslength ssdk) 2)
(progn
(command "erase" namel "")
(setq ss_pl (ssdel namel list_pl))
(setq nhomss (append (list (ssget "cp" dsp '((0 . "lwpolyline")))) nhomss))
)
)
(if (= (sslength (ssget "cp" dsp '((0 . "lwpolyline")))) 1)
(setq nhomss (append (list (ssget "cp" dsp '((0 . "lwpolyline")))) nhomss))
)
(setq i (1+ i))
)
(command "erase" list_point "")
)
(defun c:tddmoi ()
(inittdd)
(command "undo" "be")
(setq dlst (list (strcat "X" "\t" "\t" "Y" "\n"))
oldos (getvar "osmode")
pg (getvar "ucsorg")
pw (getpoint "\n Chon goc toa do ")
id 1
ptlst nil
dlst1 nil
list_pl nil
list_chu (ssadd)
nhomss nil
)
(ndt)
(setvar "osmode" 0)
(if (= pw nil) (setq pW (list 0 0 0)))
(setq k 0)
(while (< k (length nhomss))
(setq sscon (nth k nhomss))
(setq ssmoi (sapxep sscon))
(setq p 0)
(while (< p (sslength ssmoi))
(setq name (ssname ssmoi p))
(command "area" "o" name)
(setq i 0
ptlst nil
obj (vlax-ename->vla-object name)
dlst1 (append (list (strcat "hinh thu: " (rtos id 2 0) " dien tich: " (rtos (getvar "area") 2 3))) dlst1)
)
(setq ptam (centroid name))
(if (eq (cdr (assoc 40 (tblsearch "style" (getvar "textstyle")))) 0)
(command "text" "j" "m" ptam "" "" (rtos id 2 0))
(command "text" "j" "m" ptam "" (rtos id 2 0))
)
(setq list_chu (ssadd (entlast) list_chu))
(while (/= (vlax-curve-getPointAtParam obj (1+ i)) nil)
(setq p1 (vlax-curve-getPointAtParam obj i))
(setq dlst1 (append (list (strcat (rtos (- (car p1) (car pw) (car pg)) 2 3)
"\t"
"\t"
(rtos (- (cadr p1) (cadr pw) (cadr pg)) 2 3)
)
)
dlst1))
(setq ptlst (append (list p1) ptlst))
(setq i (1+ i))
)
(setq p (1+ p))
(setq dlst1 (append (list "\n") dlst1))
(setq dlst (append dlst1 dlst))
(setq dlst1 nil)
(setq id (1+ id))
)
(setq k (1+ k))
)
(setq dlst (reverse dlst))
(alert (strcat "Qua trinh da hoan thanh. Chon duong dan de luu file toa do"))
(setq file (getfiled "chon duong dan de luu file" (getvar "DWGPREFIX") "txt" 1))
(setq opw (open file "w"))
(foreach n dlst (write-line n opw))
(close opw)
(command "_.copyclip" list_chu "")
(command "block" "chu" "0,0" list_chu "")
(command "insert" "chu" "0,0" "" "" "")
(setq pchu (nth 0 (acet-ent-geomextents (entlast))))
(setvar "osmode" oldos)
(command "undo" "e")
(command "undo" "")
(command "_.pasteclip" pchu)
(alert (strcat "file da duoc luu tai: " file))
(startapp "notepad" file)
)

(defun inittdd ()
(setq
tdd_old_er *error*
*error* tdderror
)
)

(defun tdderror (errmsg)
(loitdd)
)
(defun loitdd ()
(setq *error* tdd_old_er)
(command "undo" "end")
(command "undo" "")
(princ "xay ra loi trong qua trinh thao tac")
)

(defun centroid (e / op ptam)
(vl-load-com)
(command "region" e "")
(setq re (entlast))
(setq ob (vlax-ename->vla-object re)
ptam (vlax-safearray->list (vlax-variant-value (vla-get-Centroid ob)))
)
(command "undo" 1)
ptam
)

(defun sapxep ( sscu /)
(setq i 0 l_i nil l_ps nil)
(while (< i (sslength sscu))
(setq ename (ssname sscu i))
(setq ps (centroid ename))
(setq l_ps (append (list (+ (cadr ps) (* i 0.001))) l_ps)
l_i (append (list i) l_i)
)
(setq i (1+ i))
)
(setq ssmoi (ssadd))
(setq m 0)
(while (/= l_i nil)
(setq nho (apply 'max l_ps))
(setq kt (nth (vl-position nho l_ps) l_i))
(setq ssmoi (ssadd (ssname sscu kt) ssmoi))
(setq l_ps (vl-remove nho l_ps))
(setq l_i (vl-remove kt l_i))
(setq m (1+ m))
)
ssmoi
)
(defun inter ( t1 t2 / ob1 ob2 g kq sd)
(Vl-Load-Com)
(setq ob1 (vlax-ename->vla-object t1)
ob2 (vlax-ename->vla-object t2)
)
(setq g (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone)))
(if (/= (vlax-safearray-get-u-bound g 1) -1)
(setq g (vlax-safearray->list g))
(setq g nil)
)
g
)

(defun breakarc ( n1 pn / )
(setq entarc (entget n1)
tam (cdr (assoc 10 entarc))
bk (cdr (assoc 40 entarc))
pdau (polar tam (cdr (assoc 50 entarc)) bk)
pcuoi (polar tam (cdr (assoc 51 entarc)) bk)
ang (angle tam pn)
)
(entmod (subst (cons 50 ang) (assoc 50 entarc) entarc))
(entmakex (subst (cons 51 ang) (assoc 51 entarc) entarc))
(setq lm (entlast) ss (ssadd lm ss))
)

(defun midarc ( n1 /)
(setq entarc (entget n1)
tam (cdr (assoc 10 entarc))
bk (cdr (assoc 40 entarc))
pdau (polar tam (cdr (assoc 50 entarc)) bk)
pcuoi (polar tam (cdr (assoc 51 entarc)) bk)
pgiua (polar pdau (angle pdau pcuoi) (/ (distance pdau pcuoi) 2))
)
pgiua
)

Hình đã gửi

Đầu mút của Arc hoặc Line hoặc PLINE "thò ra" như hình vẽ trên của bạn thì không bị lỗi, nhưng nếu đầu mút của chúng tiếp xúc thì xay ra loi trong qua trinh thao tac. Và nếu chỉ cần có 1 đối tượng không "thò ra" (đối tượng có thể là Arc hoặc Line hoặc PLINE) => Là Lisp bị lỗi


huhu, sao không ai giúp e hết vậy???

Chào bạn tamkt
Bạn hãy post kết quả mà bạn muốn lên đây, tương ứng với file .dwg này của bạn và bạn vui lòng nói rõ hơn nhé
http://www.mediafire...8stz8i1gmxc7ibd
Đọc các bài viết trước của bạn mà mình chẳng hiểu đầu cua tai nheo chi cả.
Vậy nhé. Chúc bạn vui.
  • 0

#2298 duy782006

duy782006

    PHẠM QUỐC DUY

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

Đã gửi 18 October 2010 - 10:30 PM

huhu, sao không ai giúp e hết vậy???

Thử cái củ chuối này xem!

(Defun C:xtdpl ( )
(command "undo" "be")
(Prompt "\nChon doi tuong pline")
(setq doituong1 (entsel))
(while
(null doituong1)
(Prompt "\nChon doi tuong pline")
(setq doituong1 (entsel))
)
(setq doituongt (car doituong1))
(setq doituong (entget doituongt))

(setq TENFILELUUKETQUA (getfiled "Chon file de luu ket qua .txt:" "" "txt" 1))
(setq FILEMODEVIET (open TENFILELUUKETQUA "a"))
(setq luubatdiem (getvar "osmode"))
(setvar "osmode" 0)
(setq sodinh (cdr (assoc 90 doituong)))
(setq drong (cdr (assoc 40 doituong)))
(setq Rec (acet-geom-vertex-list doituongt))
(setq ttd 0)
(while (< ttd sodinh)
(setq noidungdong (strcat (itoa (+ ttd 1)) ",d " (rtos drong 2 4) "," (rtos (car (nth ttd Rec)) 2 4) "," (rtos (cadr (nth ttd Rec)) 2 4)))

(write-line noidungdong FILEMODEVIET)
(setq ttd (1+ ttd))
)
(setvar "osmode" luubatdiem)
(close FILEMODEVIET)
(command "undo" "end")
(Princ)
)

  • 1

Cứ ngỡ trần gian là cõi thật.Cho nên tất bật đến bây giờ.
Tạo hộp thoại bằng lisp My blog QUY ĐỊNH ĐẶT TÊN TOPIC TRONG CHUYÊN MỤC LISPD http://ktsduy.wordpress.com/
Để cám ơn chỉ cần nhấn rep_up.png
(Là nhấn vào nút đó phía bài viết của người ta í chứ đừng có nhè cái hình này mà nhấn miết đi nha :-D


#2299 tamkt

tamkt

    biết vẽ ellipse

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

Đã gửi 19 October 2010 - 08:24 PM

Đầu mút của Arc hoặc Line hoặc PLINE "thò ra" như hình vẽ trên của bạn thì không bị lỗi, nhưng nếu đầu mút của chúng tiếp xúc thì xay ra loi trong qua trinh thao tac. Và nếu chỉ cần có 1 đối tượng không "thò ra" (đối tượng có thể là Arc hoặc Line hoặc PLINE) => Là Lisp bị lỗi
Chào bạn tamkt
Bạn hãy post kết quả mà bạn muốn lên đây, tương ứng với file .dwg này của bạn và bạn vui lòng nói rõ hơn nhé
http://www.mediafire...8stz8i1gmxc7ibd
Đọc các bài viết trước của bạn mà mình chẳng hiểu đầu cua tai nheo chi cả.
Vậy nhé. Chúc bạn vui.

Là vậy anh nè:
Với lisp này: http://www.mediafire...pq42e3y492v12in
Tên lệnh là XPL ( Xuất Pline),
Anh KS.PhanThanhTu viết cho em đó.
Xuất ra file txt có dạng là:
1,d 16,38.2,38.2
2,d 16,38.2,878
3,d 16,572.6,878
4,d 16,572.6,38.2

là hoàn toàn chính xác với yêu cầu của e rồi. Nhưng tọa độ xuất không chính xác,hichic,...

(Giải thích file xuất ra txt trên:
1,2,3,4... là thứ tự các điểm nút pline
d là mặc định
16 cho phép nhập theo yêu cầu của lisp
còn lại là tọa độ x,y của điểm nút pline )
Mong anh chỉnh lại dạng .lsp giúp e luôn nha, máy e load ko được vba, hichic...
  • 0

#2300 tamkt

tamkt

    biết vẽ ellipse

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

Đã gửi 19 October 2010 - 08:32 PM

Thử cái củ chuối này xem!

(Defun C:xtdpl ( )
(command "undo" "be")
(Prompt "\nChon doi tuong pline")
(setq doituong1 (entsel))
(while
(null doituong1)
(Prompt "\nChon doi tuong pline")
(setq doituong1 (entsel))
)
(setq doituongt (car doituong1))
(setq doituong (entget doituongt))

(setq TENFILELUUKETQUA (getfiled "Chon file de luu ket qua .txt:" "" "txt" 1))
(setq FILEMODEVIET (open TENFILELUUKETQUA "a"))
(setq luubatdiem (getvar "osmode"))
(setvar "osmode" 0)
(setq sodinh (cdr (assoc 90 doituong)))
(setq drong (cdr (assoc 40 doituong)))
(setq Rec (acet-geom-vertex-list doituongt))
(setq ttd 0)
(while (< ttd sodinh)
(setq noidungdong (strcat (itoa (+ ttd 1)) ",d " (rtos drong 2 4) "," (rtos (car (nth ttd Rec)) 2 4) "," (rtos (cadr (nth ttd Rec)) 2 4)))

(write-line noidungdong FILEMODEVIET)
(setq ttd (1+ ttd))
)
(setvar "osmode" luubatdiem)
(close FILEMODEVIET)
(command "undo" "end")
(Princ)
)

File anh xuất ra dạng như vậy nè:
1,d 20.0000,-36.5000,-11.5000
2,d 20.0000,-15.0000,-5.0000
3,d 20.0000,-15.0000,5.0000
4,d 20.0000,15.0000,5.0000
5,d 20.0000,0.0000,-25.0000

Mà e cần xuất ra file txt có dạng là:
1,d 20,-36.5,-11.5
2,d 20,-15.0,-5.0
3,d 20,-15.0,5.0
4,d 20,15.0,5.0
5,d 20,0.0,-25.0
Nếu mà
1,d 20.0000,-36.5000,-11.5000
nó xuất thành : 1,d 20,-36.5,-11.5
thì quá tuyệt luôn, xuất nhanh như điện, hehe...
Mong anh giúp.
  • 0