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

Tháng 10 17, 2010

Chào bạn PhamngocTukts
Bị lỗi trong trường hợp này, bạn nè :

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 à

Lisp bị lỗi trong trường hợp trên, chỉ sử dụng với Line hay Pline thẳng, chưa giải quyết được với Arc hay Pline chứa Arc

Cảm ơn bạn đã bỏ nhiều thời gian viết Lisp. Thanks

Cái này em cũng không rõ lắm có lẽ phải để dân Trắc địa lên tiếng thôi. Trong cả cái bản đồ địa chính thị xã Sơn Tây em quét qua không thấy một cái arc hay pline cong nào nên suy luận vậy thôi. Theo em nghĩ chỉ dùng spline khi vẽ bản đồ địa hình còn bản đồ địa chính dùng chủ yếu đường thẳng vì đường cong rất khó xác định mà trong địa chính sai một tí thôi là cãi nhau to.

Tháng 10 17, 2010

Rất cảm ơn bác Thanh Bình đã quan tâm đến câu chuyện của em! :lol: !

http://www.cadviet.com/upfiles/3/km15__km16_1_5.dwg

1.Em đã up lại file thể hiện rõ hơn

2.Vị trí của các text đó có thể thay đổi nó không ảnh hưởng nhiều đến công việc của em nên chỉ cần đẹp thôi pác à(tuy nhiên không nên thay đổi quá nhiều).

3.Tất cả các text có trên bản vẽ đều phải chuyển về width=0.8 ngoại trừ Text 1 mà em đã đánh dấu trên bản vẽ.

4.Em không muốn xoá 1 text nào.Em đã thấy trên diễn đàn có Lisp xoá các text chồng lên nhau nhưng ở đây em chi muốn giãn nó ra thôi.

Chào bạn W1ndream,

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

(defun c:artxt ()
(vl-load-com)
(command "undo" "be")
(setq orth (getvar "ucsorg"))
(setq sst (ssget (list (cons 0 "text") (cons 40 4) ))
       n (sslength sst)
       i 0
       ssp (ssadd)
)
(while (       (setq ent (ssname sst i)
              elst (entget ent)
      )
      (setq elst (entmod (subst (cons 41 0.8) (assoc 41 elst) elst)))
      (if (and (= (cdr (assoc 1 elst)) "-0.00") (equal (cdr (assoc 50 elst)) 0 0.00000001))
          (setq elst (subst (cons 1 "0.00") (assoc 1 elst) elst))
      )
      (entmod elst)
      (setq p1 (car (acet-ent-geomextents ent))
              p2 (cadr (acet-ent-geomextents ent))
              p1 (list (- (car p1) (car orth)) (- (cadr p1) (cadr orth)) (- (caddr p1) (caddr orth)))
              p2 (list (- (car p2) (car orth)) (- (cadr p2) (cadr orth)) (- (caddr p2) (caddr orth)))
      )
      (if (and (setq ss (ssget "c" p1 p2 (list (cons 0 "text") )))
                 (> (sslength ss) 1))
          (setq ssp (ssadd ent ssp))
      )
      (if (and (= (cdr (assoc 1 elst )) "0.00") (equal (cdr (assoc 50 elst)) 1.5708 0.0001))
         (command "erase" ent "")
      )

      (setq i (1+ i))
)
ssp

(while (> (sslength ssp) 0)
  (setq ssp1 (ssadd)
          k (sslength ssp1)
          ent (ssname ssp 0)
          p1 (car (acet-ent-geomextents ent))
          p2 (cadr (acet-ent-geomextents ent))
          p1 (list (- (car p1) (car orth)) (- (cadr p1) (cadr orth)) (- (caddr p1) (caddr orth)))
          p2 (list (- (car p2) (car orth)) (- (cadr p2) (cadr orth)) (- (caddr p2) (caddr orth)))
          ssp1 (ssget "c" p1 p2 (list (cons 0 "text") ))
          m (sslength ssp1)   
  )

  (while (/= m k)
         (setq p1 (car (acet-geom-ss-extents-fast ssp1))
                 p2 (cadr (acet-geom-ss-extents-fast ssp1))
                 ;;;p1 (list (- (car p1) (car orth)) (- (cadr p1) (cadr orth)) (- (caddr p1) (caddr orth)))
                 ;;;p2 (list (- (car p2) (car orth)) (- (cadr p2) (cadr orth)) (- (caddr p2) (caddr orth)))
                 ssp1 (ssget "c" p1 p2 (list (cons 0 "text") ))
                 k m
                 j 0
                 m (sslength ssp1)
         )
   )
   (setq chss nil)
   (setq m (sslength ssp1)
       i 0
   )
   (while (        (setq ent (ssname ssp1 i)
               els1 (entget ent)
       )
       (if (equal (cdr (assoc 50 els1)) 0.0 0.0000001)
           (setq chss T)
       )
       (setq i (1+ i))
   )
   (if (= chss nil)
      (xeptxt ssp1)
   )
   (while (          (setq ent (ssname ssp1 j)
                 ssp (ssdel ent ssp)
                 j (1+ j)
         )
   )
)

(command "undo" "e")
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun xeptxt ( ss / n i j p1 p2 h el1 el2 )
(setq ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;ss (ssget (list (cons 0 "text")))
        n (sslength ss)
        i 0
        elst (list)
) 
(while (         (setq ent (ssname ss i)
                elst (append elst (list (entget ent)))
                i (1+ i)
        )
)
(setq elst (vl-sort elst '(lambda (x1 x2) (        j 0
)
(setq el1 (last elst)
       p1 (cdr (assoc 10 el1))
       h (cdr (assoc 40 el1))
       p2 (cdr (assoc 11 el1))
)
(repeat (1- n)
       (setq el2 (nth j elst)
              ;;;;;;;; el2 (subst (cons 10 (polar p1 pi (* h (- n (1+ j))))) (assoc 10 el2) el2)
               el2 (subst (cons 11 (polar p2 pi (* h (- n (1+ j))))) (assoc 11 el2) el2)
               j (1+ j)
       )
      (entmod el2)
)
)

Đâ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.com/upfiles/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.com/upfiles/3/km15__km16_2.dwg

Chúc bạn vui.

Bài được chỉnh sửa bổ sung bởi Phạm Thanh Bình ngày 17-18/10/2010 dựa vào sự tham khảo từ bác Phamngoctukts và bác Giabach

Tháng 10 17, 2010

Chào bạn W1ndream,

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

(defun c:artxt ()
(command "undo" "be")
(setq orth (getvar "ucsorg"))
(setq sst (ssget (list (cons 0 "text") (cons 40 4) ))
       n (sslength sst)
       i 0
       ssp (ssadd)
)
(while (< i n)
      (setq ent (ssname sst i)
              elst (entget ent)
      )
      (if (and (= (cdr (assoc 1 elst)) "-0.00") (equal (cdr (assoc 50 elst)) 0 0.00000001))
          (setq elst (subst (cons 1 "0.00") (assoc 1 elst) elst))
      )
      (entmod elst)
      (setq p1 (car (acet-ent-geomextents ent))
              p2 (cadr (acet-ent-geomextents ent))
              p1 (list (- (car p1) (car orth)) (- (cadr p1) (cadr orth)) (- (caddr p1) (caddr orth)))
              p2 (list (- (car p2) (car orth)) (- (cadr p2) (cadr orth)) (- (caddr p2) (caddr orth)))
      )
      (if (and (setq ss (ssget "c" p1 p2 (list (cons 0 "text") )))
                 (> (sslength ss) 1))
          (setq ssp (ssadd ent ssp))
      )
      (if (and (= (cdr (assoc 1 elst )) "0.00") (equal (cdr (assoc 50 elst)) 1.5708 0.0001))
         (command "erase" ent "")
      )

      (setq i (1+ i))
)
ssp

(while (> (sslength ssp) 0)
  (setq ssp1 (ssadd)
          k (sslength ssp1)
          ent (ssname ssp 0)
          p1 (car (acet-ent-geomextents ent))
          p2 (cadr (acet-ent-geomextents ent))
          p1 (list (- (car p1) (car orth)) (- (cadr p1) (cadr orth)) (- (caddr p1) (caddr orth)))
          p2 (list (- (car p2) (car orth)) (- (cadr p2) (cadr orth)) (- (caddr p2) (caddr orth)))
          ssp1 (ssget "c" p1 p2 (list (cons 0 "text") ))
          m (sslength ssp1)   
  )

  (while (/= m k)
         (setq p1 (car (acet-geom-ss-extents-fast ssp1))
                 p2 (cadr (acet-geom-ss-extents-fast ssp1))
                 ;;;p1 (list (- (car p1) (car orth)) (- (cadr p1) (cadr orth)) (- (caddr p1) (caddr orth)))
                 ;;;p2 (list (- (car p2) (car orth)) (- (cadr p2) (cadr orth)) (- (caddr p2) (caddr orth)))
                 ssp1 (ssget "c" p1 p2 (list (cons 0 "text") ))
                 k m
                 j 0
                 m (sslength ssp1)
         )
   )
   (setq chss nil)
   (setq m (sslength ssp1)
       i 0
   )
   (while (< i m)
       (setq ent (ssname ssp1 i)
               els1 (entget ent)
       )
       (if (equal (cdr (assoc 50 els1)) 0.0 0.0000001)
           (setq chss T)
       )
       (setq i (1+ i))
   )
   (if (= chss nil)
      (xeptxt ssp1)
   )
   (while (< j m)
         (setq ent (ssname ssp1 j)
                 ssp (ssdel ent ssp)
                 j (1+ j)
         )
   )
)

(command "undo" "e")
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun xeptxt ( ss / n i j p1 p2 h el1 el2 )
(setq ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;ss (ssget (list (cons 0 "text")))
        n (sslength ss)
        i 0
        elst (list)
) 
(while (< i n)
        (setq ent (ssname ss i)
                elst (append elst (list (entget ent)))
                i (1+ i)
        )
)
(setq elst (vl-sort elst '(lambda (x1 x2) (< (cadr (assoc 10 x1)) (cadr (assoc 10 x2)))))
       j 0
)
(setq el1 (last elst)
       p1 (cdr (assoc 10 el1))
       h (cdr (assoc 40 el1))
       p2 (cdr (assoc 11 el1))
)
(repeat (1- n)
       (setq el2 (nth j elst)
              ;;;;;;;; el2 (subst (cons 10 (polar p1 pi (* h (- n (1+ j))))) (assoc 10 el2) el2)
               el2 (subst (cons 11 (polar p2 pi (* h (- n (1+ j))))) (assoc 11 el2) el2)
               j (1+ j)
       )
      (entmod el2)
)
)

Đâ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.com/upfiles/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.

Chúc bạn vui.

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

Tháng 10 17, 2010

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

Tháng 10 17, 2010

Của bạn đây

;; 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
td (ssadd)
)
(while ((setq name (ssname ss k)
ent1 (entget name)
p1 (cdr (assoc 10 ent1))
goc (cdr (assoc 50 ent1))
nd (cdr (assoc 1 ent1))
j 0)
(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 i) "")
)
(if (and (eq goc (/ pi 2)) (/= nd "0.00"))
(setq td (ssadd (cdr (assoc -1 ent1)) td))
)
(setq k (1+ k))
)
(giantext td)
(setvar "osmode" oldos)
(command "undo" "e")
)

(defun giantext ( td /)
(repeat (sslength td)
(setq i 0)
(while ((setq name1 (ssname td i)
ent1 (entget name1)
p1 (cdr (assoc 10 ent1))
goc (cdr (assoc 50 ent1))
j 0)
(while (and ((setq name2 (ssname td j)
ent2 (entget name2)
p2 (cdr (assoc 10 ent2))
di (distance p1 p2)
caochu (cdr (assoc 40 ent2))
)
(if ((progn
(if ((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))
)
)
)

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.

Tháng 10 17, 2010

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.

Tháng 10 17, 2010

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.

Tháng 10 17, 2010

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

Tháng 10 18, 2010

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

Tháng 10 18, 2010

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.com/upfiles/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.com/upfiles/3/km15__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: !

Tháng 10 18, 2010

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.

Tháng 10 18, 2010

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

Tháng 10 18, 2010

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.com/upfiles/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)))))

)

Tháng 10 18, 2010

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.com/upfiles/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  )  ))

Tháng 10 18, 2010

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.com/upfiles/3/new2.lsp

Bác ơi báo lỗi thiếu hàm.

; error: no function definition: MID0

Tháng 10 18, 2010

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

)

Tháng 10 18, 2010

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.

Tháng 10 18, 2010

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.

Tháng 10 18, 2010

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:

Tháng 10 18, 2010

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
)

Tháng 10 18, 2010

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.com/?8stz8i1gmxc7ibd

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

Tháng 10 18, 2010

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 ((setq ss (nth k lss))
(setq i 0)
(while ((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 ((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 ((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 ((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 ((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 ((setq sscon (nth k nhomss))
(setq ssmoi (sapxep sscon))
(setq p 0)
(while ((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 ((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
)

Đầ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.com/?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.

Tháng 10 18, 2010

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)

)

Tháng 10 19, 2010

Đầ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.com/?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.com/?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...

Tháng 10 19, 2010

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.

Đăng nhập

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

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

phamngoctukts 714

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

phamthanhbinh 3.146

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

phamngoctukts 714

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

phamthanhbinh 3.146

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

phamthanhbinh 3.146

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

phamngoctukts 714

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

phamthanhbinh 3.146

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

phamngoctukts 714

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

gia_bach 1.549

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

w1nDream 73

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

phamthanhbinh 3.146

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

gia_bach 1.549

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

DuongTrungHuy 128

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

gia_bach 1.549

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

phamngoctukts 714

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

DuongTrungHuy 128

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

phamngoctukts 714

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

phamngoctukts 714

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

w1nDream 73

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

phamngoctukts 714