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

Tháng 10 15, 2010

Tóm lại là cái anh nào đó Post yêu cầu lên rồi chẳng thấy đâu cả ?
Chỉ còn các Lisper trao đổi với nhau thôi.

Đôi khi tôi nghĩ có nên theo đuổi vấn đề này nữa không? Nhưng ....

"Lỡ yêu rồi ..." : chua cay mặn ngọt ... gì gì nữa cũng "trăm dâu đổ đầu tằm".

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)

2. Ph/án của bác Bình

- tìm giao điểm của tất cả các đối tuợng

- duyệt qua các giao điểm này : tạo Boundary

- xóa các Boundary trùng nhau

Vài dòng, chúc các bác cuối tuần "vui vẻ với nguời yêu".

Lisp cải tiến từ lisp xpatp của bác Bình.

Nội dung chính :

- tìm giao điểm của tất cả các đối tuợng

- duyệt qua các giao điểm này :

+ nếu tạo đuợc Boundary : duyệt qua các đỉnh của Boundary xóa các điểm này trong tập giao điểm ớ buớc 1

Kết quả : chỉ tạo đuợc khoảng 90% Boundary nhưng tốc độ chấp nhận đuợc.
(defun c:xpatp (/ boun boundFlag dis_min i j nEnt plst pt sec ss time tmp vl ov rempt)  
 (if (setq ss (ssget (list (cons 0 "LINE,LWPOLYLINE,ARC"))))
   (progn
     (command "undo" "be")
     (setq time (getvar "millisecs"))
     (setq nEnt (entlast)
    vl '("BLIPMODE" "CMDECHO" "OSMODE") ; Sys Var list
    ov (mapcar 'getvar vl))   ; Get Old values
     (mapcar 'setvar vl '( 0 0 0))
     (setq j 0
    plst (getSS_Inter ss)
    plst (vl-sort plst '(lambda (x y)(or (					     (and (						  (= (cadr x)(cadr y))) ) ))
    dis_min (* 0.8(getDistan_min plst)))
     (while plst
(setq i 0 
      boundFlag t
      pt (car plst)
      plst (cdr plst))
(while (and boundFlag (	  (setq tmp (polar pt (+ 3.2 (* 0.25 i)) dis_min))
  (if (and
	(not (ssget tmp));Point is directly on an object.
	(MakeBPoly tmp) )
    (progn
      (setq boun (entlast) k (1+ k)
	    boundFlag nil)
      (foreach bounPt (poly-pts boun)
	(if (setq rempt (member1 bounPt plst))
	  (setq plst (vl-remove rempt plst)) ))))
  (setq i (1+ i))  )  )
     (setq sec (/ (- (getvar "MILLISECS") time) 1000.0)  )
     (while (setq nEnt (entnext nEnt))
(setq j (1+ j))	)
     (if (> j 0)
(princ (strcat "\nTao duoc " (itoa j) " duong bao voi Th/gian = "(rtos sec 2 2) " s."))
(princ (strcat "\nSorry! Khong tao duoc duong bao!")))
     (mapcar 'setvar vl ov)
     (command "undo" "e"))
   (princ (strcat "\nKhong chon duoc doi tuong!")))
 (princ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun MakeBPoly (pt / ele)
 (setq ele (entlast))
 (if(vl-cmdf "_BPOLY" "_A" "_I" "_N" "" "" pt "");(vl-cmdf "boundary" pt "")
   (if (not(equal (entlast) ele)) t )))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun giao (ob1 ob2 / inter_lst iplist)
 (if (not (vl-catch-all-error-p
     (setq iplist (vl-catch-all-apply
		    'vlax-safearray->list
		    (list (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone) ))))))
   (progn
     (while (setq inter_lst (cons (list (car iplist) (cadr iplist) (caddr iplist)) inter_lst)
	   iplist (cdddr iplist)))
     (reverse inter_lst) ) ))

(defun getSS_Inter (ss / e giao_lst i lst obj tmp_lst)
 (setq i -1)
 (while (setq e (ssname ss (setq i (1+ i))))
   (setq lst (cons (vlax-ename->vla-object e) lst)) )
 (repeat (1- (vl-list-length lst))
   (setq obj (car lst))
   (foreach ob1 (setq lst (vl-remove obj lst ))
     (if ;(setq tmp_lst (giao ob1 obj))
(and
    (not (equal ob1 obj))
    (setq tmp_lst (giao ob1 obj)) )
(foreach pt tmp_lst
  (if (not (vl-position pt giao_lst))
    (setq giao_lst (cons pt giao_lst))))) ) )
 giao_lst )

(defun poly-pts (pl / n p l)
 (vl-load-com)
 (setq n (fix (vlax-curve-getEndParam pl)))
 (or (vlax-curve-IsClosed pl) (setq n (1+ n)))
 (while (setq p (vlax-curve-getPointAtParam pl (setq n (1- n))))
   (setq l (cons p l))  ))

(defun member1 (a b / res)
 (if b
   (foreach x b
     (if (equal x a 0.1)
       (setq res x) ) ) )
 res)

(defun getDistan_min (lst / dis pt1 tmp)
 (setq dis (distance (car lst) (cadr lst)))
 (repeat (1- (vl-list-length lst))
   (setq pt1 (car lst))
   (foreach pt2 (setq lst (vl-remove pt1 lst ))
     (if (	(setq dis tmp)	) ) ) 
 dis )

Tại sao lại được có 90% vậy bác nhỉ. Em chưa đọc code mới test thử thì thấy tốc độ cưc nhanh nhưng lại thiếu mất mấy cáo boundary.

Hề hề hề,

Có nhẽ bác lại bị dính ở chỗ các boundary có chứa arc rồi bác ạ. Khi boundary có chứa arc thì bác sẽ phải tạo region rồi lại explode nó mới được bác ạ. Vấn đề này bác Tue_NV đã có đề cập và mình cũng chỉ mới phát hiện ra sau khi bác ấy nhắc nhở. Có nhẽ đây cũng chính là nhược điểm của cái phương án mình đưa ra bác ạ

Mình đang dò cái lisp của bác để mót lấy một vài kỹ thuật tạo và lọc boundary sao cho hiệu quả nhất. Có nhẽ nên check và loại ngay sau khi tạo boundary vì như vậy sẽ tiết kiệm được các bước lọc bác ạ.

Hề hề hề.....

Mặt khác trong quá trình thử lisp, mình phát hiện ra là nếu như cái boundary không được nhòm thấy đủ lớn thì việc pick điểm sẽ rất dễ bị bỏ qua mà chả thèm quan tâm đến nó. Đặc biệt là khi khoảng cách điểm pick với điểm đỉnh boundary khá nhỏ bác ạ.

Hề hề hề, cái anh cu boundary này cũng đỏng đảnh ra phết đấy.....

Tháng 10 15, 2010

Tóm lại là cái anh nào đó Post yêu cầu lên rồi chẳng thấy đâu cả ?
Chỉ còn các Lisper trao đổi với nhau thôi.

Đôi khi tôi nghĩ có nên theo đuổi vấn đề này nữa không? Nhưng ....

"Lỡ yêu rồi ..." : chua cay mặn ngọt ... gì gì nữa cũng "trăm dâu đổ đầu tằm".

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)

2. Ph/án của bác Bình

- tìm giao điểm của tất cả các đối tuợng

- duyệt qua các giao điểm này : tạo Boundary

- xóa các Boundary trùng nhau

Vài dòng, chúc các bác cuối tuần "vui vẻ với nguời yêu".

Lisp cải tiến từ lisp xpatp của bác Bình.

Nội dung chính :

- tìm giao điểm của tất cả các đối tuợng

- duyệt qua các giao điểm này :

+ nếu tạo đuợc Boundary : duyệt qua các đỉnh của Boundary xóa các điểm này trong tập giao điểm ớ buớc 1

Kết quả : chỉ tạo đuợc khoảng 90% Boundary nhưng tốc độ chấp nhận đuợc.
(defun c:xpatp (/ boun boundFlag dis_min i j nEnt plst pt sec ss time tmp vl ov rempt)  
 (if (setq ss (ssget (list (cons 0 "LINE,LWPOLYLINE,ARC"))))
   (progn
     (command "undo" "be")
     (setq time (getvar "millisecs"))
     (setq nEnt (entlast)
    vl '("BLIPMODE" "CMDECHO" "OSMODE") ; Sys Var list
    ov (mapcar 'getvar vl))   ; Get Old values
     (mapcar 'setvar vl '( 0 0 0))
     (setq j 0
    plst (getSS_Inter ss)
    plst (vl-sort plst '(lambda (x y)(or (					     (and (						  (= (cadr x)(cadr y))) ) ))
    dis_min (* 0.8(getDistan_min plst)))
     (while plst
(setq i 0 
      boundFlag t
      pt (car plst)
      plst (cdr plst))
(while (and boundFlag (	  (setq tmp (polar pt (+ 3.2 (* 0.25 i)) dis_min))
  (if (and
	(not (ssget tmp));Point is directly on an object.
	(MakeBPoly tmp) )
    (progn
      (setq boun (entlast) k (1+ k)
	    boundFlag nil)
      (foreach bounPt (poly-pts boun)
	(if (setq rempt (member1 bounPt plst))
	  (setq plst (vl-remove rempt plst)) ))))
  (setq i (1+ i))  )  )
     (setq sec (/ (- (getvar "MILLISECS") time) 1000.0)  )
     (while (setq nEnt (entnext nEnt))
(setq j (1+ j))	)
     (if (> j 0)
(princ (strcat "\nTao duoc " (itoa j) " duong bao voi Th/gian = "(rtos sec 2 2) " s."))
(princ (strcat "\nSorry! Khong tao duoc duong bao!")))
     (mapcar 'setvar vl ov)
     (command "undo" "e"))
   (princ (strcat "\nKhong chon duoc doi tuong!")))
 (princ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun MakeBPoly (pt / ele)
 (setq ele (entlast))
 (if(vl-cmdf "_BPOLY" "_A" "_I" "_N" "" "" pt "");(vl-cmdf "boundary" pt "")
   (if (not(equal (entlast) ele)) t )))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun giao (ob1 ob2 / inter_lst iplist)
 (if (not (vl-catch-all-error-p
     (setq iplist (vl-catch-all-apply
		    'vlax-safearray->list
		    (list (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone) ))))))
   (progn
     (while (setq inter_lst (cons (list (car iplist) (cadr iplist) (caddr iplist)) inter_lst)
	   iplist (cdddr iplist)))
     (reverse inter_lst) ) ))

(defun getSS_Inter (ss / e giao_lst i lst obj tmp_lst)
 (setq i -1)
 (while (setq e (ssname ss (setq i (1+ i))))
   (setq lst (cons (vlax-ename->vla-object e) lst)) )
 (repeat (1- (vl-list-length lst))
   (setq obj (car lst))
   (foreach ob1 (setq lst (vl-remove obj lst ))
     (if ;(setq tmp_lst (giao ob1 obj))
(and
    (not (equal ob1 obj))
    (setq tmp_lst (giao ob1 obj)) )
(foreach pt tmp_lst
  (if (not (vl-position pt giao_lst))
    (setq giao_lst (cons pt giao_lst))))) ) )
 giao_lst )

(defun poly-pts (pl / n p l)
 (vl-load-com)
 (setq n (fix (vlax-curve-getEndParam pl)))
 (or (vlax-curve-IsClosed pl) (setq n (1+ n)))
 (while (setq p (vlax-curve-getPointAtParam pl (setq n (1- n))))
   (setq l (cons p l))  ))

(defun member1 (a b / res)
 (if b
   (foreach x b
     (if (equal x a 0.1)
       (setq res x) ) ) )
 res)

(defun getDistan_min (lst / dis pt1 tmp)
 (setq dis (distance (car lst) (cadr lst)))
 (repeat (1- (vl-list-length lst))
   (setq pt1 (car lst))
   (foreach pt2 (setq lst (vl-remove pt1 lst ))
     (if (	(setq dis tmp)	) ) ) 
 dis )

Chào bác Giabach,

Sau khi ngâm cứu cái lisp của bác hơn một tiếng đồng hồ, mình thấy có một vài điểm muốn hỏi lại bác như sau:

1/- Ở bước duyệt qua các điểm giao cắt và tạo boundary (code màu đỏ dưới đây),

(while plst

(setq i 0

boundFlag t

pt (car plst)

plst (cdr plst))

(while (and boundFlag (

(setq tmp (polar pt (+ 3.2 (* 0.25 i)) dis_min))

(if (and

(not (ssget tmp));Point is directly on an object.

(MakeBPoly tmp) )

(progn

(setq boun (entlast) k (1+ k)

boundFlag nil)

(foreach bounPt (poly-pts boun)

(if (setq rempt (member1 bounPt plst))

(setq plst (vl-remove rempt plst)) ))))

(setq i (1+ i)) ) )

theo lisp thì bác sẽ chỉ lặp cho tới khi có được boundary đầu tiên , khi đó biến boundflag sẽ nhận giá trị nil và lisp sẽ dừng lại không tiếp tục xét cái điểm đang xét nữa và chuyển sang điểm khác. Phải vậy không ạ???

Nếu vậy có thể sẽ gây nên việc thiếu boundary do rất có khả năng tại các điểm tiếp theo lisp cũng sẽ dừng tại chính cái boundary này bác ạ.

2/- Cái biến k của bác có tác dụng gì không ạ????

3/- Theo lý thuyết thì sẽ có 24 điểm tmp vì bác đặt biến i chạy từ 0 tới 23, nhưng khi bác polar với hàm (polar pt (+ 3.2 (* 0.25 i)) dis_min) thì có chắc chắn các điểm tmp này phân bố đều đủ một vòng quanh pt hay không ??? Các góc phân bố sẽ là 3.2, 3.45, 3.7, 3.95, 4.2, 4.45, 4.7, 4.95, 5.2, 5.45, 5.7, 5.95, 6.2, 6.45,.........., 8.95 (radian)

Do đó đây cũng có thể là nguyên nhân dẫn tới bị sót boundary bác ạ.

Rất mong bác giải đáp sớm để cái sự mót của mình được hanh thông bác nhé.

Cám ơn bác trước.

Tháng 10 15, 2010

UNDO được rồi nhưng khi UNDO nó mất truy bắt điểm.Mình đã thử làm như cách các bác chỉ trên diễn đàn nhưng không được.Mong các bác giúp đỡ.Chân thành cảm ơn trước.

Không bác nào giúp được e sao?

Tháng 10 15, 2010

Bài toán mình đặt ra cho đến bây ra h thực ra đã được giải quyết (đối với công việc + phần mềm của mình), tức là gồm các bước:

+ Chọn toạ độ ban đầu

+ Chọn từng nhóm đối tượng (đối với công việc của mình chỉ cần 1 nhóm thôi)

+ Break giao điểm giữa các line, tạo đa giác (region)

+ Xuất ra toạ độ của các đa giác.

Bạn Tú xem như đã giải quyết xong bài toán trên :cheers:

Những phát sinh khác chưa giải quyết triệt để (ứng dụng cho bên địa chính, làm về thửa đất ...) :

+ Chọn nhiều nhóm đối tượng => chỉ chọn 1 lần => Lisp sẽ tự tách ra thành từng nhóm riêng (thay vì chọn xong mỗi nhóm rồi nhấn Enter) như ý của bạn Tue_VN

+ Xuất Text ra ở mỗi đa giác => xuất ra tại trọng tâm . Với mỗi đa giác tìm được 1 trọng tâm => tạo 1 biến nào đó lưu 3 giá trị x y và S (số thứ tự của đa giác), sau khi undo trở lại trạng thái ban đầu => ghi text vào vị trí x y với giá trị là S.

- Nên thêm 1 dòng lệnh nhập chiều cao Text : sẽ tiện lợi cho 2 việc :

1- Chữ không lớn quá và chồng lên nhau.

2- Kiểm tra, VD chọn text hight = 3.59 => cả bản vẽ chỉ có 1 loại text có chiều cao như vậy, VD cần tìm thửa thứ 102 ta chỉ việc chọn quick select text = "102" và high = 3.59 , không sợ bị trùng 1 text nào đó cũng có giá trị "102" trong bản vẽ.

+ Ngoài break giao điểm của Line ra còn tính thêm Polyline, Arc ..

Lisp hiện h đang bị lỗi phần cuối cùng sau khi ghi text chưa xoá region. (Lúc này chỉ cần "u" 1 lần là trở về như ban đầu => ghi lại giá trị text, đc k nhỉ ? )

Tháng 10 15, 2010

Bài toán mình đặt ra cho đến bây ra h thực ra đã được giải quyết (đối với công việc + phần mềm của mình), tức là gồm các bước:
+ Chọn toạ độ ban đầu

+ Chọn từng nhóm đối tượng (đối với công việc của mình chỉ cần 1 nhóm thôi)

+ Break giao điểm giữa các line, tạo đa giác (region)

+ Xuất ra toạ độ của các đa giác.

Bạn Tú xem như đã giải quyết xong bài toán trên :cheers:

Những phát sinh khác chưa giải quyết triệt để (ứng dụng cho bên địa chính, làm về thửa đất ...) :

+ Chọn nhiều nhóm đối tượng => chỉ chọn 1 lần => Lisp sẽ tự tách ra thành từng nhóm riêng (thay vì chọn xong mỗi nhóm rồi nhấn Enter) như ý của bạn Tue_VN

+ Xuất Text ra ở mỗi đa giác => xuất ra tại trọng tâm . Với mỗi đa giác tìm được 1 trọng tâm => tạo 1 biến nào đó lưu 3 giá trị x y và S (số thứ tự của đa giác), sau khi undo trở lại trạng thái ban đầu => ghi text vào vị trí x y với giá trị là S.

- Nên thêm 1 dòng lệnh nhập chiều cao Text : sẽ tiện lợi cho 2 việc :

1- Chữ không lớn quá và chồng lên nhau.

2- Kiểm tra, VD chọn text hight = 3.59 => cả bản vẽ chỉ có 1 loại text có chiều cao như vậy, VD cần tìm thửa thứ 102 ta chỉ việc chọn quick select text = "102" và high = 3.59 , không sợ bị trùng 1 text nào đó cũng có giá trị "102" trong bản vẽ.

+ Ngoài break giao điểm của Line ra còn tính thêm Polyline, Arc ..

Lisp hiện h đang bị lỗi phần cuối cùng sau khi ghi text chưa xoá region. (Lúc này chỉ cần "u" 1 lần là trở về như ban đầu => ghi lại giá trị text, đc k nhỉ ? )

Bạn thử lisp cuối cùng của mình đi hầu như đã giải quyết hết các vấn đề. Vấn đề cònd lại chủ yếu là sắp xếp thứ tự các hình sao cho dễ tìm thôi.

Tháng 10 15, 2010

Hề hề hề,
cái vụ sắp xếp ấy khó mà cũng chả khó lắm bác ạ, vấn đề là phải hiểu cái quy luạt họ cần mà thôi. Tỷ như từ trên xuống, từ dưới lên, từ bé đến to vv.....

Hề hề hề, bác cứ chọn cái nào khoái mà chơi vì đó là cái quy luật của bác , có ai bắt bò đâu mà bác lo....

.....................

Hề hề hề,

Bác Tue_NV ơi,

Thực ra cái việc sắp xếp này ấy là do mấy anh cu địa chính làm, mình thấy các bản vẽ của mấy anh cu đó cũng lộn xộn ghê gớm, chả có quy luật quy liệc gì cả. Hình như với các anh cu ấy thì cái quy luật lại là tùy hứng bác ạ.

Vì lẽ đó cho nên người dùng phải đưa ra được cái gọi là quy luật ấy thì lisper mới viết được, còn bảo là tự định ra quy luật thì có khi mấy anh cu ấy lại bảo là chơi trèo bác ạ.

Hề hề hề....

Chào bác Bình

Em không phải là dân địa chính, em chỉ đam mê, yêu Lisp và tìm tòi các thuật toán của Lisp mà nó đem đến. Đôi lúc là niềm vui rất lớn, bác ạ. Còn bác bảo khó hay không thì bác vô bài toán này luôn là biết liền à :cheers:

Về vấn đề quy luật, thì nói thực ra do em đặt ra quy luật cho nó, chỉ là việc sắp xếp lại text cho dễ tìm kiếm, không được sắp xếp lộn xộn bác à. Em cũng đang ngâm cứu bài toán này bác ạ

Em ví dụ như : Có 3 đa giác mẹ. Mỗi đa giác mẹ lại có 6 đa giác con. Vậy thì đa giác mẹ thứ nhất được đánh số từ 1->6; đa giác mẹ thứ 2 được đánh số từ 7->12, đa giác mẹ thứ 3 đánh số từ 13->18. Khi chạy Lisp của bạn Tú thì việc sắp xếp bị lộn xộn, như hình dưới đây :

Đó là em nói số lượng đa giác con không lớn, nếu lớn thì....

Các đa giác con trong đa giác mẹ lại được sắp xếp theo 1 trật tự nào đó như theo bạn Tú đề nghị là

Chào bác Bình.
Quả thật việc sắp xếp này đối với em là rất khó vì chưa làm trường hợp này bao giờ. Cái khó ở đây là sắp xếp lại trật tự của selection set. em đã làm riêng trong phần (defun sapxep () ....). Các bác nghiên cứu xem có thể giúp được cho em không. Em muốn sắp xếp đơn giản là từ trên xuống dưới từ trái qua phải thôi bác ạ.

.....

Cách làm vẫn thế -> Chọn 1 loạt đối tượng bác ạ.

.............
+ Ngoài break giao điểm của Line ra còn tính thêm Polyline, Arc ..

.........

Tóm lại là cái anh nào đó Post yêu cầu lên rồi chẳng thấy đâu cả ?
Chỉ còn các Lisper trao đổi với nhau thôi.

Đôi khi tôi nghĩ có nên theo đuổi vấn đề này nữa không? Nhưng ....

"Lỡ yêu rồi ..." : chua cay mặn ngọt ... gì gì nữa cũng "trăm dâu đổ đầu tằm".

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)

......................

Bài toán này thì Lisp của bạn Tú chưa làm được ạ

Cách tạo ra đuờng biên từ tập chọn (Line, Pline, Arc)

Chỉ đúng với Line, Pline thôi còn arc, Pline chứa Arc thì không còn đúng nữa

@w1nDream : Bạn hãy làm theo các ý của bác Bình ở bài viết số 2280 và upload file .dwg và nói rõ hơn nhé. Dường như 1 trong các ý bạn muốn là giãn đều Text ra 2 bên, tính từ điểm giữa thì phải??

Tháng 10 15, 2010

Bạn thử lisp cuối cùng của mình đi hầu như đã giải quyết hết các vấn đề. Vấn đề cònd lại chủ yếu là sắp xếp thứ tự các hình sao cho dễ tìm thôi.

Việc sắp xếp số thửa trong ngành địa chính là cực kỳ khó khăn các bạn ạ. Một số CT chuyên ngành vẫn kg sắp xếp đc vì lý do các thửa đất có hình thù rất đa dạng mà qui định thì rất khắc khe. Thường công đoạn đánh số phải làm bằng tay mới đạt. Qui định đại khái như vậy :

Thửa xuất phát từ đỉnh cao nhất hướng tây bắc và kết thúc ở thửa thấp nhất hướng đông nam. Đi từ trái qua phải rồi ngược lại và từ trên xuống dưới. Giữa hai thửa liền nhau có ít nhất một cạnh chung. Nếu có nhảy (qua thửa dài hay đường, rạch ...) thì khoảng nhảy là gần nhất. Một số CT tự động đánh số thửa theo kiểu vạch một đường nằm ngang, rồi đánh số các thửa giao với đg này từ trái qua phải hay ngược lại. Do đó, đôi lúc hai thửa liên nhau lại cách xa nhau. Mình có thể giải quyết hầu hết các yêu cầu của bản đồ địa chính nhưng cái giải thuật đánh số thửa này mình đã suy nghĩ và bỏ ngõ mưới mấy năm, cuối cùng thấy đánh tay vẫn đúng qui trình hơn và mình kiểm soát đc cái đg bao đi có đúng ranh thửa hay kg. Nếu bạn nào có ý tưởng giải quyết đc việc sắp xếp này thì quá hay.

Tuy nhiên, mình tìm đường bao thửa kg theo con đường của các bạn

Tháng 10 15, 2010

Bạn thử thay dòng :
(command ".boundary" "A" "B" "E" "I" "Y" "" p "")

bằng dòng :

(command "boundary" p "")

Được rùi anh ơi, em cám ơn anh nhiều.

Tháng 10 16, 2010

Mình copy dc cái líp này trên diễn đàn dùng để đánh số thứ tự bản vẽ. Tuy nhiên trong bản vẽ của mình số các bản từ 1đến 9 viết là 01, 02, 03....09. mà líp này lại chỉ ghi là 1, 2 ,3...9. thiếu số 0 ở đầu. bác nào giúp e thêm số 0 vào trước với.

Số bản vẽ từ 10 trở lên thi ngon rồi .THnk

(defun SS-enlst	(ss / c L)
 (setq c -1)
 (repeat (sslength ss)
   (setq L (cons (ssname ss (setq c (1+ c))) L))
 )
 (reverse L)
)
(defun getatt (itm)
 (vlax-safearray->list
   (vlax-variant-value
     (vla-GetAttributes itm)
   )
 )
)
(defun List->String (Lst Del)
 (apply 'strcat
 (cons
   (car Lst)
   (mapcar
     '(lambda (l)
	(strcat Del l)
      )
     (cdr Lst)
   )
 )
 )
)
(defun dxf (id en) (cdr (assoc id (entget en))))
;;;-----------------------------------------------------------
(vl-load-com)
(defun c:chatt (/ blSet attLst lstbl bkname enblock)
 (setq enblock (car (entsel "\nPick a blockref for get name")))
 (while (null enblock)
   (princ "\nIncorrect, Please pick again:")
   (setq enblock (car (entsel "\nPick a blockref for get name")))
 )
 (setq	lstTag (getatt (vlax-ename->vla-object enblock)))
 (setq lstTag (mapcar 'vla-get-TagString lstTag))


;;;-----------------------------
 (setq dcl_id (load_dialog "ATTI.dcl"))
 (if (not (new_dialog "Atti" dcl_id))
   (alert "\nKhong tim duoc file ATTI.dcl !")
 )
;;;------- DCL Init  ------------
 (start_list "attdata" 3)
 (mapcar 'add_list lstTag)
 (end_list)
;;;------------------------------
 (set_tile "attdata" "0")
 (setq	att_list "0"
order 1
star 1
delta 1
 )
 (action_tile "okay" "(done_dialog 1)")
 (action_tile "cancel" "(done_dialog)")
 (action_tile "attdata" "(setq att_list $value)")
 (action_tile "startstr" "(setq star (atoi $value))")
 (action_tile "increment" "(setq delta (atoi $value))")
 (action_tile "order1" "(setq order 1)")
 (action_tile "order2" "(setq order 0)")
 (setq execute_it (start_dialog))
 (unload_dialog dcl_id)
;;;------- Main Program -----------
 (if (= execute_it 1)
   (progn
     (setq bkname (cdr (assoc 8 (entget enblock))))
     (princ "<<< Select blocks to change attributes >>>")
     (if
(setq
  blSet	(ssget
	  (list (cons 0 "INSERT") (cons 8 bkname) (cons 66 1))
	)
)
 (progn
   (cond ((= order 1)
	  (setq	lstbl
		 (vl-sort (SS-enlst blSet)
			  '(lambda (x y)
			    (if	(equal
				  (car (setq
					 x1 (trans (dxf 10 x) 0 1)
				       )
				  )
				  (car (setq
					 y1 (trans (dxf 10 y) 0 1)
				       )
				  )
				)
			      (< (cadr x1) (cadr y1))
			      (< (car x1) (car y1))
			    )
			  )
		 )
	  )
	 )
	 ((= order 0)
	  (setq	lstbl
		 (vl-sort (SS-enlst blSet)
			  '(lambda (x y)
			    (if	(equal
				  (car (setq
					 x1 (trans (dxf 10 x) 0 1)
				       )
				  )
				  (car (setq
					 y1 (trans (dxf 10 y) 0 1)
				       )
				  )
				)
			      (> (cadr x1) (cadr y1))
			      (> (car x1) (car y1))
			    )
			  )
		 )
	  )
	 )
   )
   (setq blSet (mapcar 'vlax-ename->vla-object lstbl))
   (setq TAG (nth (atoi att_list) lstTag))
   (setq n star)
   (foreach itm	blSet
     (setq attLst (getatt itm))
     (foreach att attLst
       (if (eq (strcase (vla-get-TagString att)) (strcase Tag))
	 (progn
	   (vla-put-textstring att (itoa n))
	   (setq n (+ n delta))
	 )
       )
     )
   )
 );;END progn
 (princ ">>> Nothing blockref selected! <<<")
     );end if
   )
 );end if
 (princ "\nTHANK YOU FOR USE LISP CHANGE ATTRIBUTES. THIEP")
 (princ)
)

đây là dcl ( ATTI.DCL)

Atti : dialog{
label ="STT CHO THUOC TINH";
: column{
: column{
: list_box{
label ="Chon Tag Name";
key ="attdata";
height = 15;
width = 30;
multiple_select = false;
fixed_width_font = false;
}
}
: column{
: edit_box{
key ="startstr";
label ="Chu bat dau:";
edit_width = 8;
value ="1";
}
: edit_box{
key ="increment";
label ="Tham so tang:";
edit_width = 8;
value ="1";
}
: column {
: boxed_radio_column {
	label = "Cach sap xep :" ;
	: radio_button {
		label ="Trai -> Phai ; Duoi -> Tren";
		key ="order1";
		value ="1";
	}
	: radio_button {
		label ="Phai -> Trai ; Tren -> Duoi";
		key ="order2";
		value ="0";
	}
}
}            
}
: boxed_row{
: button{key ="okay";
label ="Dong y";
is_default = true;
}
: button{key ="cancel";
label ="Thoat";
is_default = false;
is_cancel = true;
}
}
}
}

Tháng 10 16, 2010

Chào bác Giabach,
Sau khi ngâm cứu cái lisp của bác hơn một tiếng đồng hồ, mình thấy có một vài điểm muốn hỏi lại bác như sau:

1/- Ở bước duyệt qua các điểm giao cắt và tạo boundary (code màu đỏ dưới đây),

........

theo lisp thì bác sẽ chỉ lặp cho tới khi có được boundary đầu tiên , khi đó biến boundflag sẽ nhận giá trị nil và lisp sẽ dừng lại không tiếp tục xét cái điểm đang xét nữa và chuyển sang điểm khác. Phải vậy không ạ???

Nếu vậy có thể sẽ gây nên việc thiếu boundary do rất có khả năng tại các điểm tiếp theo lisp cũng sẽ dừng tại chính cái boundary này bác ạ.

2/- Cái biến k của bác có tác dụng gì không ạ????

3/- Theo lý thuyết thì sẽ có 24 điểm tmp vì bác đặt biến i chạy từ 0 tới 23, nhưng khi bác polar với hàm (polar pt (+ 3.2 (* 0.25 i)) dis_min) thì có chắc chắn các điểm tmp này phân bố đều đủ một vòng quanh pt hay không ??? Các góc phân bố sẽ là 3.2, 3.45, 3.7, 3.95, 4.2, 4.45, 4.7, 4.95, 5.2, 5.45, 5.7, 5.95, 6.2, 6.45,.........., 8.95 (radian)

Do đó đây cũng có thể là nguyên nhân dẫn tới bị sót boundary bác ạ.

Rất mong bác giải đáp sớm để cái sự mót của mình được hanh thông bác nhé.

Cám ơn bác trước.

Chào bác phamthanhbinh, Cám ơn bác đã góp ý.

sorry, cái biến k tôi quên xóa, (* 0.25 i) đổi thành (* 0.26 i) k/quả cũng không khá hơn là mấy.

Vấn đề bị sót boundary là do ở bước 1 thuật toán chưa tốt bác ạ.

Tôi nghĩ là giá trị góc ban đầu 3.2 trong công thức (+ 3.2 (* 0.25 i)) phải thay đổi theo từng điểm khác nhau thì k/quả sẽ khá hơn ?!

- nếu sau khi tìm được boundary đầu tiên, mình tiếp tục vòng lặp thì nhiều khả năng sẽ bị trùng boundary.

Vâng, việc lựa chọn giữa bị sót boundary và trùng boundary là vấn đề khó khăn.

...
Có nhẽ bác lại bị dính ở chỗ các boundary có chứa arc rồi bác ạ. Khi boundary có chứa arc thì bác sẽ phải tạo region rồi lại explode nó mới được bác ạ.

....

List vẫn tạo được boundary có chứa arc bác a.

nhờ bác k/tra lại dùm.

Tháng 10 16, 2010

Mình copy dc cái líp này trên diễn đàn dùng để đánh số thứ tự bản vẽ. Tuy nhiên trong bản vẽ của mình số các bản từ 1đến 9 viết là 01, 02, 03....09. mà líp này lại chỉ ghi là 1, 2 ,3...9. thiếu số 0 ở đầu. bác nào giúp e thêm số 0 vào trước với.

Số bản vẽ từ 10 trở lên thi ngon rồi .THnk

(defun SS-enlst	(ss / c L)
 (setq c -1)
 (repeat (sslength ss)
   (setq L (cons (ssname ss (setq c (1+ c))) L))
 )
 (reverse L)
)
(defun getatt (itm)
 (vlax-safearray->list
   (vlax-variant-value
     (vla-GetAttributes itm)
   )
 )
)
(defun List->String (Lst Del)
 (apply 'strcat
 (cons
   (car Lst)
   (mapcar
     '(lambda (l)
	(strcat Del l)
      )
     (cdr Lst)
   )
 )
 )
)
(defun dxf (id en) (cdr (assoc id (entget en))))
;;;-----------------------------------------------------------
(vl-load-com)
(defun c:chatt (/ blSet attLst lstbl bkname enblock)
 (setq enblock (car (entsel "\nPick a blockref for get name")))
 (while (null enblock)
   (princ "\nIncorrect, Please pick again:")
   (setq enblock (car (entsel "\nPick a blockref for get name")))
 )
 (setq	lstTag (getatt (vlax-ename->vla-object enblock)))
 (setq lstTag (mapcar 'vla-get-TagString lstTag))
;;;-----------------------------
 (setq dcl_id (load_dialog "ATTI.dcl"))
 (if (not (new_dialog "Atti" dcl_id))
   (alert "\nKhong tim duoc file ATTI.dcl !")
 )
;;;------- DCL Init  ------------
 (start_list "attdata" 3)
 (mapcar 'add_list lstTag)
 (end_list)
;;;------------------------------
 (set_tile "attdata" "0")
 (setq	att_list "0"
order 1
star 1
delta 1
 )
 (action_tile "okay" "(done_dialog 1)")
 (action_tile "cancel" "(done_dialog)")
 (action_tile "attdata" "(setq att_list $value)")
 (action_tile "startstr" "(setq star (atoi $value))")
 (action_tile "increment" "(setq delta (atoi $value))")
 (action_tile "order1" "(setq order 1)")
 (action_tile "order2" "(setq order 0)")
 (setq execute_it (start_dialog))
 (unload_dialog dcl_id)
;;;------- Main Program -----------
 (if (= execute_it 1)
   (progn
     (setq bkname (cdr (assoc 8 (entget enblock))))
     (princ "<<< Select blocks to change attributes >>>")
     (if
(setq
  blSet	(ssget
	  (list (cons 0 "INSERT") (cons 8 bkname) (cons 66 1))
	)
)
 (progn
   (cond ((= order 1)
	  (setq	lstbl
		 (vl-sort (SS-enlst blSet)
			  '(lambda (x y)
			    (if	(equal
				  (car (setq
					 x1 (trans (dxf 10 x) 0 1)
				       )
				  )
				  (car (setq
					 y1 (trans (dxf 10 y) 0 1)
				       )
				  )
				)
			      (< (cadr x1) (cadr y1))
			      (< (car x1) (car y1))
			    )
			  )
		 )
	  )
	 )
	 ((= order 0)
	  (setq	lstbl
		 (vl-sort (SS-enlst blSet)
			  '(lambda (x y)
			    (if	(equal
				  (car (setq
					 x1 (trans (dxf 10 x) 0 1)
				       )
				  )
				  (car (setq
					 y1 (trans (dxf 10 y) 0 1)
				       )
				  )
				)
			      (> (cadr x1) (cadr y1))
			      (> (car x1) (car y1))
			    )
			  )
		 )
	  )
	 )
   )
   (setq blSet (mapcar 'vlax-ename->vla-object lstbl))
   (setq TAG (nth (atoi att_list) lstTag))
   (setq n star)
   (foreach itm	blSet
     (setq attLst (getatt itm))
     (foreach att attLst
       (if (eq (strcase (vla-get-TagString att)) (strcase Tag))
	 (progn
	   (vla-put-textstring att (itoa n))
	   (setq n (+ n delta))
	 )
       )
     )
   )
 );;END progn
 (princ ">>> Nothing blockref selected! <<<")
     );end if
   )
 );end if
 (princ "\nTHANK YOU FOR USE LISP CHANGE ATTRIBUTES. THIEP")
 (princ)
)

Chào bạn nguyentuyen6,

bạn tìm dòng mã (vla-put-textstring att (itoa n))

và thay bằng dòng mã (vla-put-textstring att (strcat "0" (itoa n))) là được.

Tháng 10 16, 2010

Chào các bác , em định nhờ các bác viết hộ 1 cái lisp mà giúp chúng ta dim được khoảng cách và diện tích trên thực tế dựa vào tỉ lệ cho sẵn của bản vẽ . Cám ơn các bác trước ! :lol: :lol: :lol:

Tháng 10 16, 2010

@bác thiep:

Nếu thay như BÁC thì bản vẽ thứ tự là 10 trở lên nó sẽ ghi 010 rồi 011.... Ý mình là chỉ từ 1 đến 9 là thêm số 0 thôi.

Tháng 10 16, 2010

Chào bạn nguyentuyen6,
bạn tìm dòng mã (vla-put-textstring att (itoa n))

và thay bằng dòng mã (vla-put-textstring att (strcat "0" (itoa n))) là được.

từ số 10 trở đi thì nó cũng thêm số 0 phía trước.

đề nghị :

(if (< n 10)

(vla-put-textstring att (strcat "0" (itoa n)))

(vla-put-textstring att (itoa n)))

Tháng 10 16, 2010

@bác thiep:
Nếu thay như BÁC thì bản vẽ thứ tự là 10 trở lên nó sẽ ghi 010 rồi 011.... Ý mình là chỉ từ 1 đến 9 là thêm số 0 thôi.

Thiệp đang bận, nên không suy nghĩ, cứ viết nhanh. Khi biết bị lỗi, chuẩn bị chỉnh sữa thì có bác Giabach tiếp tay rồi. Cảm ơn Giabach.

Tháng 10 16, 2010

Chào bạn W1ndream,
Mình đã đọc yêu cầu của bạn song có một số điểm chưa rõ muốn hỏi lại bạn như sau:

1/- Cái hình bạn post lên tìm hoài chả thấy chỗ nào giống như cái yêu cầu cả, tức là chả có chỗ nào thấy cái text -0.00 màu vàng và text 0.00 màu xanh cả.

2/- Có phải bạn muốn chỉnh tất cả các text màu vàng mà bị chồng lên nhau thành các text cách đều nhau không??? Như vậy thì vị trí của nó có thể sẽ không còn tương thích với vị trí thực trên bản vẽ. Điều này có ảnh hưởng gì đến công việc của bạn hay không???

3/- Bạn chỉ hiệu chỉnh các text có width factor là 0.8 thôi hay tất cả các text bất kể width factor của nó.

4/- Có thể thay thế việc dãn các text ra bằng việc xóa bớt các text chồng lên nhau để đảm bảo giữ đúng vị trí của các text tương ứng với vị trí thực trên bản vẽ hay không???

Nhìn chung yêu cầu của bạn là có thể thực hiện được, tuy nhiên bạn cần gửi một bản vẽ thể hiện hai trạng thái trước và sau khi chạy lisp với đúng tình trạng thực của nó chứ không phải là copy cái ảnh ví dụ ra. (do trên bản vẽ bạn gửi mình tìm không thấy cái đoạn mẫu đó nên không biết phải thử lisp ở đâu trên bản vẽ của bạn) Bạn hãy đánh dấu cái vị trí cần chỉnh sửa của bạn trên bản vẽ. Nhớ là bản vẽ chứ không phải file ảnh vì khi viết lisp sẽ cần sử dụng tới các thuộc tính của các đối tượng trên bả vẽ của bạn, mà file ảnh thì không thể có các thuộc tính này.

Chờ sự hồi âm của bạn.

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.

Tháng 10 16, 2010

Em ví dụ như : Có 3 đa giác mẹ. Mỗi đa giác mẹ lại có 6 đa giác con. Vậy thì đa giác mẹ thứ nhất được đánh số từ 1->6; đa giác mẹ thứ 2 được đánh số từ 7->12, đa giác mẹ thứ 3 đánh số từ 13->18. Khi chạy Lisp của bạn Tú thì việc sắp xếp bị lộn xộn, như hình dưới đây :

Đó là em nói số lượng đa giác con không lớn, nếu lớn thì....

Các đa giác con trong đa giác mẹ lại được sắp xếp theo 1 trật tự nào đó như theo bạn Tú đề nghị là

Theo như góp ý của Bác em đã phân ra đánh số thứ thự theo nhóm rồi.

Còn các boundary là arc hoặc pline cong thực ra trong chắc địa rất ít dùng nên em không nghiên cứu tiếp vào phần này.

;; 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"))))
(setq lss (append lss (list ss)))
(command "zoom" "e")
(taobo lss)
)

(defun taobo ( 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)
p1 (cdr (assoc 10 ent))
p2 (cdr (assoc 11 ent))
j 0
)
(command "point" (polar p1 (angle p1 p2) (/ (distance p1 p2) 2)))
(setq poi (entlast)
list_point (ssadd poi list_point))
(command "change" list_point "" "p" "la" "point_template" "")
(while (< j (sslength ss))
(setq name1 (ssname ss j)
ent1 (entget name1)
p3 (cdr (assoc 10 ent1))
p4 (cdr (assoc 11 ent1))
giao (inters p1 p2 p3 p4 T)
)
(if (not (eq name name1))
(progn
(if (and (/= giao nil) (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
(entmake (subst (cons 11 giao) (assoc 11 ent1) ent1))
(setq lm (entlast) ss (ssadd lm ss) dk1 (sslength ss))
(entmod (subst (cons 10 giao) (assoc 10 ent1) ent1))
)
)
(if (and (/= giao nil) (or (equal giao p1 0.01) (equal giao p2 0.01)) 
(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) dk1 (sslength ss))
(entmod (subst (cons 10 giao) (assoc 10 ent1) ent1))
)
)
)
)
(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 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 (/= ssdk nil)
(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
)

Tháng 10 16, 2010

Em có chủ đề này, đây là lisp xuất tạo độ em sưu tầm trên cadviet:

;;;;        Design by  : VVA 
;;;;        Posted     
; [url="http://forum.dwg.ru/showthread.php?t=20509"]http://forum.dwg.ru/showthread.php?t=20509[/url]

;;;RUSSIAN
;;; Ýêñïîðò êîîðäèíàò óêàçàííûõ òî÷åê, âûáðàííûõ îáúåêòîâ: òî÷åê, áëîêîâ, ïîëèëèíèé, 
;;;;;;;ñïëàéíîâ â òåêñòîâûé ôàéë, åêñåë ñ ïðîñòàíîâêîé íîìåðîâ
;;; Òåêñòîâûé ôàéë — ëèáî txt, ëèáî csv.
;;; ===================================================================

;;; Âàæíî !!!
;;; Íîìåðà òî÷åê îòðèñîâûâàþòñÿ òåêñòîì íà òåêóùåì ñëîå, òåêóùèì ñòèëåì, òåêóùåé âûñîòîé ( TEXTSIZE )
;;; Îêðóãëåíèå êîîðäèíàò â ñîîòâåòñòâèè ñ òåêóùèìè íàñòðîéêàìè êîìàíäû _UNITS (ïåðåìåííàÿ LUPREC !!!)
;;;!!!!!!!!!!!!!
;;; Íàáðàòü â êîìàíäíîé ñòðîêå LUPREC è óñòàíîâèòü íóæíóþ òî÷íîñòü îêðóãëåíèÿ.
;;;!!!!!!!!!!
;;; ===================================================
;;; Îïðåäåëåíû 4 êîìàíäû
;;; COOR - ýêñïîðò êîîðäèíàò
;;; COORN -ýêñïîðò êîîðäèíàò ñ íóìåðàöèåé. Íîìåðà òî÷åê ðèñóòñÿ òåêñòîì íà òåêóùåì ñëîå, 
;;;;;;òåêóùèì ñòèëåì, òåêóùåé âûñîòîé ( TEXTSIZE )
;;; COORT -ýêñïîðò êîîðäèíàò ñ íóìåðàöèåé, ãäå íîìåðîì ñ÷èòàåòñÿ áëèæàéøèé ê òî÷êå òåêñò
;;; COOR-GEO - ýêñïîðò êîîðäèíàò ñ íóìåðàöèåé, ãäå íîìåðîì ñ÷èòàåòñÿ áëèæàéøèé ê òî÷êå òåêñò.
;;;;;;;; Âû÷èñëÿåòñÿ äèðåêöèîííûé óãîë è ðàññòîÿíèå



;;;; Commands 
;;Export of coordinates of the specified points, the chosen objects: points, blocks, 
;;;;;;;;;polylines, splines in a text file, Excel.
;;   Text file — txt, or csv. A rounding off of coordinates according to current adjustments of 
;;;;;;;;a command _UNITS (LUPREC !!!)
;;; 4 commands Are certain
;;; COOR - export of coordinates
;;; COORN-export of coordinates with numbering. Numbers of points are drawn by the text on the current layer,
;;;;;;;;;;;;;;;;;;; the current style, current height (TEXTSIZE)
;;; COORT-export of coordinates with numbering where number considers the text nearest to a point
;;; COOR-GEO - export of coordinates with numbering where number considers the text nearest to a point. 
;;;;;;;;;;;It is calculated äèðåêöèîííûé a corner and distance


;;http://www.caduser.ru/cgi-bin/f1/board.cgi?t=39175jU
;|=============== Êîìàíäà COORN ===============================================

EN:
  Export of coordinates of the specified points, the chosen objects: points, blocks, polylines, 
                                                        splines in a text file, Excel.
  Text file — txt, or csv. A rounding off of coordinates according to current adjustments of a 
;;;command _UNITS (LUPREC !!!)
RUS:
Ýêñïîðò êîîðäèíàò óêàçàííûõ òî÷åê, âûáðàííûõ îáúåêòîâ: òî÷åê, áëîêîâ, ïîëèëèíèé, ñïëàéíîâ â òåêñòîâûé ôàéë, 
      ;;;;;;;;åêñåë ñ ïðîñòàíîâêîé íîìåðîâ
Òåêñòîâûé ôàéë — ëèáî txt, ëèáî csv.
Íîìåðà òî÷åê îòðèñîâûâàþòñÿ òåêñòîì íà òåêóùåì ñëîå, òåêóùèì ñòèëåì, òåêóùåé âûñîòîé
Îêðóãëåíèå êîîðäèíàò â ñîîòâåòñòâèè ñ òåêóùèìè íàñòðîéêàìè êîìàíäû _UNITS (ïåðåìåííàÿ LUPREC !!!)

|;

(defun c:COORN (/ cFile curPt filPath objSet oFlag oldMode ptLst sFlag lw isRus Npt)
(defun group-by-num (lst num / ls ret)(if (= (rem (length lst) num ) 0)(progn (setq ls nil)
 (repeat (/ (length lst) num)(repeat num (setq ls(cons (car lst) ls)lst (cdr lst)))
 (setq ret (append ret (list (reverse ls))) ls nil)))) ret)
(defun PtCollect(SelSet)(mapcar 'cdr (mapcar '(lambda(x)(assoc 10 x))(mapcar 'entget
(vl-remove-if 'listp(mapcar 'cadr(ssnamex SelSet))))))); end of PtCollect
(defun PLCollect(SelSet / ret)
(foreach lw (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp(mapcar 'cadr(ssnamex SelSet))))
 (cond ((wcmatch (vla-get-ObjectName lw) "*Polyline")
 (setq ret (append ret (group-by-num (vlax-get lw 'Coordinates)
 (if (=(vla-get-ObjectName lw) "AcDbPolyline") 2 3)))))
      ((=(vla-get-ObjectName lw) "AcDbSpline")(setq ret (append ret (group-by-num
        (vlax-safearray->list(vlax-variant-value (vla-get-controlpoints lw)))  3))))
     (t nil))) ret)
 (vl-load-com)(setq isRus(= (getvar "SysCodePage") "ANSI_1251"))(if(not ptcol:mode)(setq ptcol:mode "Pick"))
 (initget "Óêàçàòü Òî÷êà Áëîêè Ïîëèëèíèÿ Pick pOints Blocks poLyline _Pick pOints Blocks poLyline Pick 
              pOints Blocks poLyline")
(setq oldMode ptcol:mode ptcol:mode
(getkword (if IsRus (strcat "\nÂûáåðèòå ðåæèì [Óêàçàòü/Òî÷êà/Áëîêè/Ïîëèëèíèÿ èëè ñïëàéí] <"
(cadr (assoc ptcol:mode '(("Pick" "Óêàçàòü")("pOints" "Óêàçàòü")("Blocks" "Áëîêè")("poLyline" "Ïîëèëèíèÿ")))) ">: ")
(strcat "\nSpecify mode [Pick/pOints/Blocks/poLyline or spline] <"ptcol:mode">: "))) ptLst nil)
(if(null ptcol:mode)(setq ptcol:mode oldMode))
(cond ((= "Pick" ptcol:mode)(setq curPt T)
      (while curPt (setq curPt(getpoint (if IsRus
        "\nÓêàæèòå òî÷êó èëè Enter çàâåðøåíèÿ > " "\nPick point or Enter to continue > ")))
 (if curPt (setq ptLst(append ptLst(list (trans curPt 1 0))))))); end condition #1
     ((= "pOints" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "POINT")))))(progn
        (if IsRus (princ "\nÂûáåðèòå òî÷êè è íàæìèòå Enter ")(princ "\nSelect points and press Enter "))
  (setq objSet(ssget '((0 . "POINT"))))))(if objSet (setq ptLst(PtCollect objSet)))); end condition #2
     ((= "Blocks" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "INSERT")))))(progn
       (if IsRus(princ "\nÂûáåðèòå áëîêè è íàæìèòå Enter ")(princ "\nSelect blocks and press Enter "))
    (setq objSet(ssget '((0 . "INSERT"))))))(if objSet (setq ptLst(PtCollect objSet)))); end condition #3
     ((= "poLyline" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "*POLYLINE,SPLINE")))))(progn
       (if IsRus(princ "\nÂûáåðèòå ïîëèëèíèè è íàæìèòå Enter  ")(princ "\nSelect polyline and press Enter "))
    (setq objSet(ssget '((0 . "*POLYLINE,SPLINE"))))))(if objSet 
                                (setq ptLst(PLCollect objSet)))); end condition #4
); end cond
(if ptLst (progn (princ "\n+++ Coordinates list ++++\n")(setq ptLst (mapcar '(lambda(x)(trans x 0 1)) ptLst))
(mapcar '(lambda(x)(princ(strcat "\n"(rtos(car x))","(rtos(cadr x))
(if(= 3(length x))(strcat ","(rtos(nth 2 x))) "")))) ptLst); end mapcar
(princ "\n\n+++++++++ End of list +++++++++")
(setq Npt (getint (if IsRus "\nÍà÷àëüíûé íîìåð òî÷êè <Íå ìàðêèðîâàòü> : " 
                           "\nStart number of points  : " )))
(initget "Ôàéë Excel Íå Text Excel Not _Text Excel Not Text Excel Not")
(setq sFlag (getkword (if IsRus "\nÑîõðàíèòü êîîðäèíàòû â [Ôàéë/Excel/Íå ñîõðàíÿòü] <Ôàéë> : "
"\nSave coordinates to [Text file/Excel/Not save]  : ")))
(if(null sFlag)(setq sFlag "Text"))(setq oFlag Npt)(if (numberp Npt)
(foreach ln ptlst
 (text-draw                 ;_Îòðèñîâêà òåêñòà
   (itoa Npt)               ;_Íîìåð òî÷êè
   (polar ln (/ pi 4) 1.)   ;_Êîîðäèíàòû íà 1 åä ïî óãëîì 45 ãðàäóñîâ
   (getvar "TEXTSIZE")      ;_ Òåêóùåé âûñîòîé òåêñòà
   0                        ;_Óãîë ïîâîðîòà
   nil
   )
 (setq Npt (1+ Npt))))
(setq Npt oFlag)    
(setq ptLst (mapcar '(lambda(x)(mapcar 'rtos x)) ptlst))
(cond ((and (= "Text" sFlag)(setq filPath
      (getfiled (if IsRus "Ñîõðàíåíèå êîîðäèíàò â òåêñòîâûé ôàéë" "Save Coordinates to Text File") 
                                "Coordinates.txt" "txt;csv" 33)))
      (setq cFile(open filPath "w"))(foreach ln ptLst (write-line (strcat (if (numberp Npt)
                                (strcat (itoa Npt) ",") "")(car ln)","(cadr ln)
        (if(= 3(length ln))(strcat ","(nth 2 ln)))) cFile)(if (numberp Npt)
                                          (setq Npt (1+ Npt))))(close cFile)(initget "Yes No")
      (setq oFlag(getkword (if IsRus "\nÎòêðûòü ôàéë? [Yes/No]  : " 
                                        "\nOpen text file? [Yes/No]  : " )))
      (if(= oFlag "Yes")(startapp "notepad.exe" filPath))); end condition #1
    ((= "Excel" sFlag)(if (numberp Npt)(progn
     (setq ptlst (mapcar '(lambda(x)(cons (1- (setq Npt (1+ Npt))) x)) ptlst))
     (xls ptlst '("N" "X" "Y" "Z") nil "COORN"))
     (xls ptLst nil nil "COOR"))); end condition #2
    (t nil)))) (princ)); end of c:COOR
;|================== XLS ========================================
*  published
[url="http://www.autocad.ru/cgi-bin/f1/board.cgi?t=31371zf"]
[url="http://www.autocad.ru/cgi-bin/f1/board.cgi?t=31371zf"]


http://www.autocad.ru/cgi-bin/f1/board.cgi?t=31371zf[/url][/url]
[url="http://www.autocad.ru/cgi-bin/f1/board.cgi?t=31596eW"]
[url="http://www.autocad.ru/cgi-bin/f1/board.cgi?t=31596eW"]


http://www.autocad.ru/cgi-bin/f1/board.cgi?t=31596eW[/url][/url]
* Purpose: Export of the list of data Data-list in Excell
*             It is exported to a new leaf of the current book.
             If the book is not present, it is created
* Arguments:
             Data-list — The list of lists of data (LIST)
                           ((Value1 Value2 ... VlalueN)(Value1 Value2 ... VlalueN)...)
                           Each list of a kind (Value1 Value2... VlalueN) enters the name in
                           a separate line in corresponding columns (Value1-A Value2-B and .ò.ä.)
                 header —  The list (LIST) headings or nil a kind (" Signature A " " Signature B "...)
                           If header nil, is accepted ("X" "Y" "Z")
                Colhide —  The list of alphabetic names of columns to hide or nil — to not hide ("A" "C" "D") 
                            — to hide columns A, C, D
                Name_list — The name of a new leaf of the active book or nil — is not present
* Return: nil
* Usage
(xls '((1.1 1.2 1.3 1.4)(2.1 2.2 2.3 2.4)(3.1 3.2 3.3 3.4)) '("Col1" "Col2" "Col3"  "Col4") '("B") "test")   |;


;|================== XLS ========================================
* Îïóáëèêîâàíî 
[url="http://www.autocad.ru/cgi-bin/f1/board.cgi?t=19833nl&page=2"]
[url="http://www.autocad.ru/cgi-bin/f1/board.cgi...33nl&page=2"]


http://www.autocad.ru/cgi-bin/f1/board.cgi...33nl&page=2[/url][/url]
[url="http://www.autocad.ru/cgi-bin/f1/board.cgi?t=31371zf"]
[url="http://www.autocad.ru/cgi-bin/f1/board.cgi?t=31371zf"]


http://www.autocad.ru/cgi-bin/f1/board.cgi?t=31371zf[/url][/url]
[url="http://www.autocad.ru/cgi-bin/f1/board.cgi?t=31596eW"]
[url="http://www.autocad.ru/cgi-bin/f1/board.cgi?t=31596eW"]


http://www.autocad.ru/cgi-bin/f1/board.cgi?t=31596eW[/url][/url]
* Àâòîð: Âëàäèìèð Àçàðêî aka VVA
* Íàçíà÷åíèå: Ïå÷àòü ñïèñêà äàííûõ Data-list â Excell
*             Äëÿ âûâîäà ñîçäàåòñÿ íîâàÿ êíèãà
             Âûâîä îñóùåñòâëÿåòñÿ â ïåðâîì ëèñòå
* Àðãóìåíòû:
             Data-list — ñïèñîê ñïèñêîâ äàííûõ (LIST) âèäà
                           ((Value1 Value2 ... VlalueN)(Value1 Value2 ... VlalueN)...)
                           Êàæäûé ñïèñîê âèäà (Value1 Value2 ... VlalueN) çàïèñûâàåòñÿ
                           â îòäåëüíóþ ñòðîêó â ñîîòâåòñòâóþùèå ñòîëáöû (Value1-A Value2-B è .ò.ä.)
                 header —  ñïèñîê (LIST) çàãîëîâêîâ èëè nil âèäà ("Ïîäïèñü A" "Ïîäïèñü B" ...)
                           Åñëè header nil, ïðèíèìàåòñÿ ("X" "Y" "Z")
                Colhide —  ñïèñîê áóêâåííûõ íàçâàíèé ñòîáëöîâ äëÿ ñêðûòèÿ èëè nil — íå ñêðûâàòü
                           ("A" "C" "D") — ñêðûòü ñòîëáöû A, C, D
                Name_list — èìÿ íîâîãî ëèñòà àêòèâíîé êíèãè èëè nil — íîâàÿ êíèãà
* Âîçâðàò: nil
* TIPS!!! : Ïðè ïåðåäà÷è ôóíêöèè xls ÷èñëîâûõ âåùåñòâåííûõ äàííûõ íåò íåîáõîäèìîñòè ïðîâåðÿòü òåêóùèé ñèñòåìíûé
           ðàçäåëèòåëü öåëîé è äðîáíîé ÷àñòè ("HKEY_CURRENT_USER\\Control Panel\\International" "sDecimal")
           Ôóíêöèåé íà âðåìÿ âûâîäà îòêëþ÷àåòñÿ èñïîëüçîâàíèå â Excele ñèñòåìíîãî ðàçäåëèòåëÿ, ðàçäåëèòåëåì
           öåëîé è äðîáíîé ÷àñòè óñòàíàâëèâàåòñÿ òî÷êà. Ïîñëå çàâåðøåíèÿ ô-öèè âñå âîññòàíàâëèâàåòñÿ.
Ïðèìåð âûçîâà
(xls '((1.1 1.2 1.3 1.4)(2.1 2.2 2.3 2.4)(3.1 3.2 3.3 3.4)) '("Ñòîëáåö1" "Ñòîëáåö2" "Ñòîëáåö3" "Ñòîëáåö4") '("B"))|;
(vl-load-com)
(defun xls ( Data-list header Colhide Name_list / *aplexcel* *books-colection* Currsep
*excell-cells* *new-book* *sheet#1* *sheet-collection* col iz_listo row cell cols)
(defun Letter (N / Res TMP)(setq Res "")(while (> N 0)(setq TMP (rem N 26)
 TMP (if (zerop TMP)(setq N (1- N) TMP 26) TMP)
 Res (strcat (chr (+ 64 TMP)) Res)  N   (/ N 26))) Res)
(if (null Name_list)(setq Name_list ""))
 (setq  *AplExcel*     (vlax-get-or-create-object "Excel.Application"))
 (if (setq *New-Book*  (vlax-get-property *AplExcel* "ActiveWorkbook"))
   (setq *Books-Colection*  (vlax-get-property *AplExcel* "Workbooks")
         *Sheet-Collection* (vlax-get-property *New-Book* "Sheets")
              *Sheet#1*     (vlax-invoke-method *Sheet-Collection* "Add"))
(setq *Books-Colection*  (vlax-get-property *AplExcel* "Workbooks")
             *New-Book*     (vlax-invoke-method *Books-Colection* "Add")
         *Sheet-Collection* (vlax-get-property *New-Book* "Sheets")
              *Sheet#1*     (vlax-get-property *Sheet-Collection* "Item" 1)))
(setq *excell-cells*     (vlax-get-property *Sheet#1* "Cells"))
(setq Name_list (if (= Name_list "")
                 (vl-filename-base(getvar "DWGNAME"))
                 (strcat (vl-filename-base(getvar "DWGNAME")) "&" Name_list))
  col 0 cols nil)
(if (> (strlen Name_list) 26)
(setq Name_list (strcat (substr Name_list 1 10) "..." (substr Name_list (- (strlen Name_list) 13) 14))))
(vlax-for sh *Sheet-Collection* (setq cols (cons (strcase(vlax-get-property sh 'Name)) cols)))
(setq row Name_list)
(while (member (strcase row) cols)(setq row (strcat Name_list " (" (itoa(setq col (1+ col)))")")))
(setq Name_list row)
(vlax-put-property *Sheet#1* 'Name Name_list)
(setq Currsep (vlax-get-property *AplExcel* "UseSystemSeparators"))
(vlax-put-property *AplExcel* "UseSystemSeparators" :vlax-false) ;_íå èñïîëüçîâàòü ñèñòåìíûå óñòàíîâêè
(vlax-put-property *AplExcel* "DecimalSeparator" ".")            ;_ðàçäåëèòåëü äðîáíîé è öåëîé ÷àñòè
(vlax-put-property *AplExcel* "ThousandsSeparator" " ")          ;_ðàçäåëèòåëü òûñÿ÷åé
(vla-put-visible *AplExcel* :vlax-true)(setq row 1 col 1)
(if (null header)(setq header '("X" "Y" "Z")))
(repeat (length header)(vlax-put-property *excell-cells* "Item" row col
(vl-princ-to-string (nth (1- col) header)))(setq col (1+ col)))(setq  row 2 col 1)
(repeat (length Data-list)(setq iz_listo (car Data-list))(repeat (length iz_listo)
(vlax-put-property *excell-cells* "Item" row col (vl-princ-to-string (car iz_listo)))
(setq iz_listo (cdr iz_listo) col (1+ col)))(setq Data-list (cdr Data-list))(setq col 1 row (1+ row)))
(setq col (1+(length header)) row (1+ row))
(setq cell (vlax-variant-value (vlax-invoke-method *Sheet#1* "Evaluate"
   (strcat "A1:" (letter col)(itoa row))))) ;_ end of setq
(setq cols (vlax-get-property cell  'Columns))
(vlax-invoke-method cols 'Autofit)
(vlax-release-object cols)(vlax-release-object cell)
(foreach item ColHide (if (numberp item)(setq item (letter item)))
(setq cell (vlax-variant-value (vlax-invoke-method *Sheet#1* "Evaluate"
   (strcat item "1:" item "1"))))
(setq cols (vlax-get-property cell  'Columns))
(vlax-put-property cols 'hidden 1)
(vlax-release-object cols)(vlax-release-object cell))
(vlax-put-property *AplExcel* "UseSystemSeparators" Currsep)
(mapcar 'vlax-release-object (list *excell-cells* *Sheet#1* *Sheet-Collection* *New-Book* *Books-Colection*
*AplExcel*))(setq *AplExcel* nil)(gc)(gc)(princ))
;;;Îòðèñîâêà òåêñòà
;;; txt - òåêñò
;;; pnt - òî÷êà îòðèñîâêè â ÏÑÊ
;;; heigtht - âûñîòà
;;; rotation - óãîë ïîâîðîòà
;;;justification - èëè nil
;;;Âîçâðàùàåò èìÿ ïðèìèòèâà
(defun text-draw (txt pnt height rotation justification)
  (if (null pnt)(command "_.-TEXT" "" txt)
  (if (= (cdr (assoc 40 (tblsearch "STYLE" (getvar "TEXTSTYLE"))))
   0.0
      ) ;_ end of =
    (progn
    ;; íóëåâàÿ âûñîòà òåêñòà
      (if justification
  (command "_.-TEXT" "_J" justification "_none" pnt height rotation txt)
  (command "_.-TEXT" "_none" pnt height rotation txt)
      ) ;_ end of if
    ) ;_ end of progn
    (progn
      ;; ôèêñèðîâàíííàÿ âûñîòà
      (if justification
  (command "_.-TEXT" "_J" justification "_none" pnt rotation txt)
  (command "_.-TEXT" "_none" pnt rotation txt)
      ) ;_ end of if
    ) ;_ end of progn
  ) ;_ end of if
    )
 (entlast)
)
(defun c:COOR(/ cFile curPt filPath objSet oFlag oldMode ptLst sFlag lw isRus)
(defun group-by-num (lst num / ls ret)(if (= (rem (length lst) num ) 0)(progn (setq ls nil)
 (repeat (/ (length lst) num)(repeat num (setq ls(cons (car lst) ls)lst (cdr lst)))
 (setq ret (append ret (list (reverse ls))) ls nil)))) ret)
(defun PtCollect(SelSet)(mapcar 'cdr (mapcar '(lambda(x)(assoc 10 x))(mapcar 'entget
(vl-remove-if 'listp(mapcar 'cadr(ssnamex SelSet))))))); end of PtCollect
(defun PLCollect(SelSet / ret)
(foreach lw (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp(mapcar 'cadr(ssnamex SelSet))))
 (cond ((wcmatch (vla-get-ObjectName lw) "*Polyline")
(setq ret (append ret (group-by-num (vlax-get lw 'Coordinates)
(if (=(vla-get-ObjectName lw) "AcDbPolyline") 2 3)))))
      ((=(vla-get-ObjectName lw) "AcDbSpline")(setq ret (append ret (group-by-num
        (vlax-safearray->list(vlax-variant-value (vla-get-controlpoints lw)))  3))))
     (t nil))) ret)
 (vl-load-com)(setq isRus(= (getvar "SysCodePage") "ANSI_1251"))(if(not ptcol:mode)
                              (setq ptcol:mode "Pick"))
 (initget "Óêàçàòü Òî÷êà Áëîêè Ïîëèëèíèÿ Pick pOints Blocks poLyline _Pick pOints Blocks 
                poLyline Pick pOints Blocks poLyline")
(setq oldMode ptcol:mode ptcol:mode
(getkword (if IsRus (strcat "\nÂûáåðèòå ðåæèì [Óêàçàòü/Òî÷êà/Áëîêè/Ïîëèëèíèÿ èëè ñïëàéí] <"
(cadr (assoc ptcol:mode '(("Pick" "Óêàçàòü")("pOints" "Óêàçàòü")("Blocks" "Áëîêè")
                                     ("poLyline" "Ïîëèëèíèÿ")))) ">: ")
(strcat "\nSpecify mode [Pick/pOints/Blocks/poLyline or spline] <"ptcol:mode">: "))) ptLst nil)
(if(null ptcol:mode)(setq ptcol:mode oldMode))
(cond ((= "Pick" ptcol:mode)(setq curPt T)
      (while curPt (setq curPt(getpoint (if IsRus
        "\nÓêàæèòå òî÷êó èëè Enter çàâåðøåíèÿ > " "\nPick point or Enter to continue > ")))
(if curPt (setq ptLst(append ptLst(list (trans curPt 1 0))))))); end condition #1
     ((= "pOints" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "POINT")))))(progn
        (if IsRus (princ "\nÂûáåðèòå òî÷êè è íàæìèòå Enter ")(princ "\nSelect points and press Enter "))
 (setq objSet(ssget '((0 . "POINT"))))))(if objSet (setq ptLst(PtCollect objSet)))); end condition #2
     ((= "Blocks" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "INSERT")))))(progn
       (if IsRus(princ "\nÂûáåðèòå áëîêè è íàæìèòå Enter ")(princ "\nSelect blocks and press Enter "))
   (setq objSet(ssget '((0 . "INSERT"))))))(if objSet (setq ptLst(PtCollect objSet)))); end condition #3
     ((= "poLyline" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "*POLYLINE,SPLINE")))))(progn
       (if IsRus(princ "\nÂûáåðèòå ïîëèëèíèè è íàæìèòå Enter  ")(princ "\nSelect polyline and press Enter "))
   (setq objSet(ssget '((0 . "*POLYLINE,SPLINE"))))))(if objSet 
             (setq ptLst(PLCollect objSet)))); end condition #4
); end cond
(if ptLst (progn (princ "\n++++ Coordinates list ++++\n")(setq ptLst (mapcar '(lambda(x)(trans x 0 1)) ptLst))
(mapcar '(lambda(x)(princ(strcat "\n"(rtos(car x))","(rtos(cadr x))
(if(= 3(length x))(strcat ","(rtos(nth 2 x))) "")))) ptLst); end mapcar
(princ "\n\n+++++ End of list ++++")(initget "Ôàéë Excel Íå Text Excel Not _Text Excel Not Text Excel Not")
(setq sFlag (getkword (if IsRus "\nÑîõðàíèòü êîîðäèíàòû â [Ôàéë/Excel/Íå ñîõðàíÿòü] <Ôàéë> : "
"\nSave coordinates to [Text file/Excel/Not save]  : ")))
(if(null sFlag)(setq sFlag "Text"))
(cond ((and (= "Text" sFlag)(setq filPath
      (getfiled (if IsRus "Ñîõðàíåíèå êîîðäèíàò â òåêñòîâûé ôàéë" "Save Coordinates to Text File") 
                                "Coordinates.txt" "txt;csv" 33)))
      (setq cFile(open filPath "w"))(foreach ln ptLst (write-line (strcat (rtos(car ln))","(rtos(cadr ln))
        (if(= 3(length ln))(strcat ","(rtos(nth 2 ln))))) cFile))(close cFile)(initget "Yes No")
      (setq oFlag(getkword (if IsRus "\nÎòêðûòü ôàéë? [Yes/No]  : " "\nOpen text file? [Yes/No]  : " )))
      (if(= oFlag "Yes")(startapp "notepad.exe" filPath))); end condition #1
    ((= "Excel" sFlag)(xls (mapcar '(lambda(x)(mapcar 'rtos x)) ptLst) nil nil "COOR")); end condition #2
    (t nil)))) (princ)); end of c:COOR

(defun c:COORT(/ cFile curPt filPath objSet oFlag oldMode ptLst sFlag lw isRus txtList buf pat)
(defun group-by-num (lst num / ls ret)(if (= (rem (length lst) num ) 0)(progn (setq ls nil)
 (repeat (/ (length lst) num)(repeat num (setq ls(cons (car lst) ls)lst (cdr lst)))
 (setq ret (append ret (list (reverse ls))) ls nil)))) ret)
(defun PtCollect(SelSet)(mapcar 'cdr (mapcar '(lambda(x)(assoc 10 x))(mapcar 'entget
(vl-remove-if 'listp(mapcar 'cadr(ssnamex SelSet))))))); end of PtCollect
(defun PLCollect(SelSet / ret)
(foreach lw (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp(mapcar 'cadr(ssnamex SelSet))))
 (cond ((wcmatch (vla-get-ObjectName lw) "*Polyline")
(setq ret (append ret (group-by-num (vlax-get lw 'Coordinates)
(if (=(vla-get-ObjectName lw) "AcDbPolyline") 2 3)))))
      ((=(vla-get-ObjectName lw) "AcDbSpline")(setq ret (append ret (group-by-num
        (vlax-safearray->list(vlax-variant-value (vla-get-controlpoints lw)))  3))))
     (t nil))) ret)
 (vl-load-com)(setq isRus(= (getvar "SysCodePage") "ANSI_1251"))(if(not ptcol:mode)
                                      (setq ptcol:mode "Pick"))
 (initget "Óêàçàòü Òî÷êà Áëîêè Ïîëèëèíèÿ Pick pOints Blocks poLyline _Pick pOints Blocks 
                     poLyline Pick pOints Blocks poLyline")
(setq oldMode ptcol:mode ptcol:mode
(getkword (if IsRus (strcat "\nÂûáåðèòå ðåæèì [Óêàçàòü/Òî÷êà/Áëîêè/Ïîëèëèíèÿ èëè ñïëàéí] <"
(cadr (assoc ptcol:mode '(("Pick" "Óêàçàòü")("pOints" "Óêàçàòü")("Blocks" "Áëîêè")
                                     ("poLyline" "Ïîëèëèíèÿ")))) ">: ")
      (strcat "\nSpecify mode [Pick/pOints/Blocks/poLyline or spline] <"ptcol:mode">: "))) ptLst nil)
(if(null ptcol:mode)(setq ptcol:mode oldMode))
(cond ((= "Pick" ptcol:mode)(setq curPt T)
      (while curPt (setq curPt(getpoint (if IsRus
        "\nÓêàæèòå òî÷êó èëè Enter çàâåðøåíèÿ > " "\nPick point or Enter to continue > ")))
(if curPt (setq ptLst(append ptLst(list (trans curPt 1 0))))))); end condition #1
     ((= "pOints" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "POINT")))))(progn
        (if IsRus (princ "\nÂûáåðèòå òî÷êè è íàæìèòå Enter ")(princ "\nSelect points and press Enter "))
 (setq objSet(ssget '((0 . "POINT"))))))(if objSet (setq ptLst(PtCollect objSet)))); end condition #2
     ((= "Blocks" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "INSERT")))))(progn
       (if IsRus(princ "\nÂûáåðèòå áëîêè è íàæìèòå Enter ")(princ "\nSelect blocks and press Enter "))
   (setq objSet(ssget '((0 . "INSERT"))))))(if objSet (setq ptLst(PtCollect objSet)))); end condition #3
     ((= "poLyline" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "*POLYLINE,SPLINE")))))(progn
       (if IsRus(princ "\nÂûáåðèòå ïîëèëèíèè è íàæìèòå Enter  ")(princ "\nSelect polyline and press Enter "))
   (setq objSet(ssget '((0 . "*POLYLINE,SPLINE"))))))(if objSet 
                          (setq ptLst(PLCollect objSet)))); end condition #4
); end cond
(if ptLst
 (progn
   (setq objSet(ssget "_X" (list '(0 . "*TEXT")(cons 410 (getvar "CTAB")))))
   (setq lw (vl-remove-if 'listp(mapcar 'cadr(ssnamex objSet))))
   (setq lw (mapcar '(lambda(x)(setq x (entget x))(list (cdr(assoc 10 x))(cdr(assoc 1 x)))) lw))
   (foreach pt ptlst
     (setq buf (mapcar '(lambda(x)(list (distance pt (car x))(cadr x))) lw))
     (setq pat (car buf))
     (foreach dst buf (if (< (car dst) (car pat))(setq pat dst)))
     (setq txtList (cons (cadr pat) txtList))
     )
   (setq txtList (reverse txtList))
   (princ "\n+++++++ Coordinates list +++++++\n")
   (setq ptLst (mapcar '(lambda (x) (trans x 0 1)) ptLst))
   (setq buf
   (mapcar '(lambda (x y)
              (princ (strcat "\n" y "  "
                             (rtos (car x))
                             ","
                             (rtos (cadr x))
                             (if (= 3 (length x))
                               (strcat "," (rtos (nth 2 x)))
                               ""
                             ) ;_ end of if
                     ) ;_ end of strcat
              ) ;_ end of princ
             (list y (rtos (car x))(rtos (cadr x))
                             (if (= 3 (length x))(rtos (nth 2 x))) ;_ end of if
                     )
            ) ;_ end of lambda
           ptLst txtList
   );_ end mapcar
         )
   (princ "\n\n+++++++++ End of list +++++++++")
   (initget
     "Ôàéë Excel Íå Text Excel Not _Text Excel Not Text Excel Not"
   ) ;_ end of initget
   (setq sFlag
          (getkword
            (if IsRus
              "\nÑîõðàíèòü êîîðäèíàòû â [Ôàéë/Excel/Íå ñîõðàíÿòü] <Ôàéë> : "
              "\nSave coordinates to [Text file/Excel/Not save]  : "
            ) ;_ end of if
          ) ;_ end of getkword
   ) ;_ end of setq
   (if (null sFlag)
     (setq sFlag "Text")
   ) ;_ end of if
   (cond ((and (= "Text" sFlag)
               (setq filPath
                      (getfiled (if IsRus
                                  "Ñîõðàíåíèå êîîðäèíàò â òåêñòîâûé ôàéë"
                                  "Save Coordinates to Text File"
                                ) ;_ end of if
                                "Coordinates.txt"
                                "txt;csv"
                                33
                      ) ;_ end of getfiled
               ) ;_ end of setq
          ) ;_ end of and
          (setq cFile (open filPath "w"))
          (foreach ln buf
            (write-line
              (apply 'strcat
              (append (list(car ln))
                      (mapcar '(lambda(x)(strcat "," x))
                              (cdr ln)
                              )
                      )
                )     
              cFile
            ) ;_ end of write-line
          ) ;_ end of foreach
          (close cFile)
          (initget "Yes No")
          (setq oFlag (getkword (if IsRus
                                  "\nÎòêðûòü ôàéë? [Yes/No]  : "
                                  "\nOpen text file? [Yes/No]  : "
                                ) ;_ end of if
                      ) ;_ end of getkword
          ) ;_ end of setq
          (if (= oFlag "Yes")
            (startapp "notepad.exe" filPath)
          ) ;_ end of if
         )                                       ; end condition #1
         ((= "Excel" sFlag)
          (xls buf
               '("Íîìåð òî÷êè" "X" "Y" "Z")
               nil
               "COORM"
          ) ;_ end of xls
         )                                       ; end condition #2
         (t nil)
   ) ;_ end of cond
 ) ;_ end of progn
) ;_ end of if
(princ))
(defun c:COOR-GEO (/ cFile curPt filPath objSet oFlag oldMode ptLst sFlag lw isRus txtList buf pat geo txt)
(defun group-by-num (lst num / ls ret)(if (= (rem (length lst) num ) 0)(progn (setq ls nil)
 (repeat (/ (length lst) num)(repeat num (setq ls(cons (car lst) ls)lst (cdr lst)))
 (setq ret (append ret (list (reverse ls))) ls nil)))) ret)
(defun PtCollect(SelSet)(mapcar 'cdr (mapcar '(lambda(x)(assoc 10 x))(mapcar 'entget
(vl-remove-if 'listp(mapcar 'cadr(ssnamex SelSet))))))); end of PtCollect
(defun PLCollect(SelSet / ret)
(foreach lw (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp(mapcar 'cadr(ssnamex SelSet))))
 (cond ((wcmatch (vla-get-ObjectName lw) "*Polyline")
(setq ret (append ret (group-by-num (vlax-get lw 'Coordinates)
(if (=(vla-get-ObjectName lw) "AcDbPolyline") 2 3)))))
      ((=(vla-get-ObjectName lw) "AcDbSpline")(setq ret (append ret (group-by-num
        (vlax-safearray->list(vlax-variant-value (vla-get-controlpoints lw)))  3))))
     (t nil))) ret)
 (vl-load-com)(setq isRus(= (getvar "SysCodePage") "ANSI_1251"))(if(not ptcol:mode)
(setq ptcol:mode "Pick"))
 (initget "Óêàçàòü Òî÷êà Áëîêè Ïîëèëèíèÿ Pick pOints Blocks poLyline _Pick pOints Blocks
                        poLyline Pick pOints Blocks poLyline")
(setq oldMode ptcol:mode ptcol:mode
(getkword (if IsRus (strcat "\nÂûáåðèòå ðåæèì [Óêàçàòü/Òî÷êà/Áëîêè/Ïîëèëèíèÿ èëè ñïëàéí] <"
(cadr (assoc ptcol:mode '(("Pick" "Óêàçàòü")("pOints" "Óêàçàòü")("Blocks" "Áëîêè")
                                     ("poLyline" "Ïîëèëèíèÿ")))) ">: ")
      (strcat "\nSpecify mode [Pick/pOints/Blocks/poLyline or spline] <"ptcol:mode">: "))) ptLst nil)
(if(null ptcol:mode)(setq ptcol:mode oldMode))
(cond ((= "Pick" ptcol:mode)(setq curPt T)
      (while curPt (setq curPt(getpoint (if IsRus
        "\nÓêàæèòå òî÷êó èëè Enter çàâåðøåíèÿ > " "\nPick point or Enter to continue > ")))
(if curPt (setq ptLst(append ptLst(list (trans curPt 1 0))))))); end condition #1
     ((= "pOints" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "POINT")))))(progn
        (if IsRus (princ "\nÂûáåðèòå òî÷êè è íàæìèòå Enter ")(princ "\nSelect points and press Enter "))
 (setq objSet(ssget '((0 . "POINT"))))))(if objSet (setq ptLst(PtCollect objSet)))); end condition #2
     ((= "Blocks" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "INSERT")))))(progn
       (if IsRus(princ "\nÂûáåðèòå áëîêè è íàæìèòå Enter ")(princ "\nSelect blocks and press Enter "))
   (setq objSet(ssget '((0 . "INSERT"))))))(if objSet (setq ptLst(PtCollect objSet)))); end condition #3
     ((= "poLyline" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "*POLYLINE,SPLINE")))))(progn
       (if IsRus(princ "\nÂûáåðèòå ïîëèëèíèè è íàæìèòå Enter  ")(princ "\nSelect polyline and press Enter "))
   (setq objSet(ssget '((0 . "*POLYLINE,SPLINE"))))))(if objSet 
                     (setq ptLst(PLCollect objSet)))); end condition #4
); end cond
(if ptLst
 (progn
   (if (setq objSet(ssget "_X" (list '(0 . "*TEXT")(cons 410 (getvar "CTAB")))))
     (progn
 (setq lw (vl-remove-if 'listp(mapcar 'cadr(ssnamex objSet))))
   (setq lw (mapcar '(lambda(x)(setq x (entget x))(list (cdr(assoc 10 x))(cdr(assoc 1 x)))) lw))
   (foreach pt ptlst
     (setq buf (mapcar '(lambda(x)(list (distance pt (car x))(cadr x))) lw))
     (setq pat (car buf))
     (foreach dst buf (if (< (car dst) (car pat))(setq pat dst)))
     (setq txtList (cons (cadr pat) txtList))
     )
   (setq txtList (reverse txtList))
)
     (setq txtList '("? 1"))
     )
   ;;; Ôîðìèðóåì ãåîäåçè÷åñêèå êîîðäèíàòû (ïåðåâîðà÷èâàåì X è Y, âû÷èñëÿåì ðàññòîÿíèå è íîìåðà òî÷åê)
   (setq lw 0)
   (repeat (length ptLst)
     (setq curPt (nth lw ptLst)) ;_Òåêóùàÿ òî÷êà
     (if (setq buf (nth (1+ lw) ptLst)) ;_Ïîñëåäóþùàÿ
(progn
(setq txt (nth (1+ lw) txtList)) ;_Íîìåð ñëåäóþùåé òî÷êè
(if (null txt)(setq txt (strcat "? "(itoa (+ 2 lw)))))
)
(progn
(setq buf (car ptLst) txt (car txtList))
(if (null txt)(setq txt "? 1"))
)
)
     (setq curPt (list (cadr curPt)(car curPt))) ;_ Êîîðäèíàòû òåêóùåé òî÷êè (ïåðåâîðà÷èâàåì)
     (setq buf (list (cadr buf)(car buf))) ;_ Êîîðäèíàòû ñëåäóþùåé (ïåðåâîðà÷èâàåì)
     (setq geo (cons (list
		(if (nth lw txtList)(nth lw txtList)(strcat "? "(itoa (1+ lw)))) ;_ Íîìåð òî÷êè
		curPt                                                       ;_ Êîîðäèíàòû
		                                                            ;_ Äèð. óãîë
		(vl-string-subst "' " "'"  ;_çàìåíÿåì ñèìâîë '(ìèí) íà ñèìâîë '' '(c ïðîáåëîì)
		  (vl-string-subst "° " "d" ;_ çàìåíÿåì ñèìâîë d(ãðàä) íà ñèìâîë '° '
		    (angtos (angle curPt buf) 1 3)
		    )
		  )
		(distance curPt buf) ;_Ðàññòîÿíèå
		txt ;_ Íà òî÷êó
		)
	      geo
	      )
    )

     (setq lw (1+ lw))
     )
   (setq geo (reverse geo))
   (princ "\n+++++++ Coordinates list +++++++\n")
   (setq buf
   (mapcar '(lambda (x)
              (princ (strcat "\n" (nth 0 x) "  "
                             (rtos (car (nth 1 x)))
                             ","
                             (rtos (cadr (nth 1 x)))
                     ) ;_ end of strcat
              ) ;_ end of princ
       (list
	 (nth 0 x)                  ;_ Íîìåð òî÷êè
	 (rtos (car (nth 1 x)) 2 2) ;_ Êîîðä X
	 (rtos (cadr (nth 1 x)) 2 2);_ Êîîðä Y
	 (nth 2 x)                  ;_ Äèð óãîë
	 (rtos (nth 3 x) 2 2)       ;_ Ðàññòîÿíèå
	 (nth 4 x)                  ;_ Íà òî÷êó
	 )
             ) ;_ end of lambda
           geo
   );_ end mapcar
  )
   (princ "\n\n+++++++++ End of list +++++++++")
   (initget
     "Ôàéë Excel Íå Text Excel Not _Text Excel Not Text Excel Not"
   ) ;_ end of initget
   (setq sFlag
          (getkword
            (if IsRus
              "\nÑîõðàíèòü êîîðäèíàòû â [Ôàéë/Excel/Íå ñîõðàíÿòü] <Ôàéë> : "
              "\nSave coordinates to [Text file/Excel/Not save]  : "
            ) ;_ end of if
          ) ;_ end of getkword
   ) ;_ end of setq
   (if (null sFlag)
     (setq sFlag "Text")
   ) ;_ end of if
   (cond ((and (= "Text" sFlag)
               (setq filPath
                      (getfiled (if IsRus
                                  "Ñîõðàíåíèå êîîðäèíàò â òåêñòîâûé ôàéë"
                                  "Save Coordinates to Text File"
                                ) ;_ end of if
                                "Coordinates.txt"
                                "txt;csv"
                                33
                      ) ;_ end of getfiled
               ) ;_ end of setq
          ) ;_ end of and
          (setq cFile (open filPath "w"))
          (foreach ln buf
            (write-line
              (apply 'strcat
              (append (list(car ln))
                      (mapcar '(lambda(x)(strcat "," x))
                              (cdr ln)
                              )
                      )
                )     
              cFile
            ) ;_ end of write-line
          ) ;_ end of foreach
          (close cFile)
          (initget "Yes No")
          (setq oFlag (getkword (if IsRus
                                  "\nÎòêðûòü ôàéë? [Yes/No]  : "
                                  "\nOpen text file? [Yes/No]  : "
                                ) ;_ end of if
                      ) ;_ end of getkword
          ) ;_ end of setq
          (if (= oFlag "Yes")
            (startapp "notepad.exe" filPath)
          ) ;_ end of if
         )                                       ; end condition #1
         ((= "Excel" sFlag)
          (xls buf
               '("Íîìåð òî÷êè" "X" "Y" "Äèð. óãîë" "Ðàññòîÿíèå" "Íà òî÷êó")
               nil
               "COORM"
          ) ;_ end of xls
         )                                       ; end condition #2
         (t nil)
   ) ;_ end of cond
 ) ;_ end of progn
) ;_ end of if
(princ))

(defun C:PTXL ( / ss lst pt dL lstp lstt ret Z)
;;;http://forum.dwg.ru/showthread.php?t=14353
;;;Êîìàíäà PTXL.
;;;Max distance from point to text - ìàêñèìàëüíîå îòêëîíåíèå òî÷êè è òåêñòà.
;;;Êîîðäèíàòû òåêñòà áåðóòñÿ èç ïîëÿ 10 (âûðàâíèâàíèå âëåâî)
;;;Åñëè íàéäåíî íåñêîëüêî òåêñòîâ ñ îòêëîíåíèåì ìåíüøå Max distance, áåðåòñÿ òåêñò ñ íàèìåíüøèì ðàññòîÿíèåì.

 (vl-load-com)
 (initget 1)
 (setq dL (getreal "\nMax distance from point to text: "))
 (and
 (princ "\nSelect text and Point")
 (setq ss (ssget "_:L" '((0 . "TEXT,Point"))))
 (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
 (foreach en lst
   (if (= (cdr(assoc 0 (entget en))) "POINT")
     (setq lstp (cons en lstp))
     (setq lstt (cons en lstt))
     )
   )
 (foreach en lstp
   (setq pt (cdr(assoc 10 (entget en))))
   (setq pt (mapcar '+ pt '(0 0)))
   (setq lst (vl-remove-if '(lambda(txt)
         (< (distance pt
        (mapcar '+ (cdr(assoc 10 (entget txt)))
            '(0 0)))
     dL
     )
         )
 lstt
 )
  )
   (setq lst (vl-sort lst '(lambda(x y)
        (< (distance pt (mapcar '+ (cdr(assoc 10 (entget x)))  '(0 0)))
    (distance pt (mapcar '+ (cdr(assoc 10 (entget y)))  '(0 0))) 
     )
        )
        )
  )
   (setq Z (cdr(assoc 1 (entget (car lst)))))
   (setq Z (vl-string-translate "," "." (vl-string-trim  "%UuoOcC \t" Z)))
   (setq Z (atof Z))
   (setq pt (append pt (list Z)))
   (setq ret (cons pt ret))
   )
 )
   (if ret (xls ret '("X" "Y" "Z") nil nil))
   (princ)
)
(princ "\nType COOR, COORN, COORT or COOR-GEO in command line")

-------------------------------------------------------------------------------

xuất ra text có dạng tọa độ là:

32.9039,33.1631,0.0000

54.3737,33.1631,0.0000

54.3737,16.2295,0.0000

32.9039,16.2295,0.0000

-------------------------------------------------------------------------------

Giờ e muốn xuất ra có dạng:

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

Với:

1,2,3,4... là thứ tự các điểm nút pline

d là mặc định

16 thay đổi theo chiều dày của pline

còn lại là tọa độ x,y của điểm nút pline

Mong mấy bậc tiền bối giúp em.

Tháng 10 16, 2010

Bạn TamKt có thể gửi 1 file dwg của bạn cần xuất ra txt đc ko :lol:

Tháng 10 16, 2010

Bạn TamKt có thể gửi 1 file dwg của bạn cần xuất ra txt đc ko :lol:

Còn đây là file Cad, file lisp COORN, và 2 file txt ( 1 file thì lisp COORN xuất, 1 file thì cần sửa lại sao cho xuất ra dạng như nội dung trong file "dang file can xuat")

http://www.mediafire.com/?fj9771jc3aj1ykb

E cám ơn anh trước nha, hihi....

Tháng 10 16, 2010

Mình copy dc cái líp này trên diễn đàn dùng để đánh số thứ tự bản vẽ. Tuy nhiên trong bản vẽ của mình số các bản từ 1đến 9 viết là 01, 02, 03....09. mà líp này lại chỉ ghi là 1, 2 ,3...9. thiếu số 0 ở đầu. bác nào giúp e thêm số 0 vào trước với.
Số bản vẽ từ 10 trở lên thi ngon rồi .THnk

Ở đây mình đã viết lại hoàn toàn , bạn tải file về, load ( lệnh AP) 2 file trong tệp nén đó và sau đó gõ lệnh TAT (TĂNG ATTRIB BLOCK)

Đây là kết quả :lol:

Do diễn đàn đang bị lỗi upload mình sẽ up lên mediafire , khi nào 4rum ổn định sẽ attach nó luôn :lol:

http://www.mediafire.com/?zvrqjm8vwipvaxb

Tháng 10 16, 2010

bạn tamkt này

1,d 25,0.9,0.9

2,d 25,0.9,48.9

3,d 25,44.1,48.9

4,d 25,44.1,0.9

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

16 thay đổi theo chiều dày của pline

tức là thay đổi thế nào nhỉ :lol:

Chỉ có chổ này chưa hiểu thôi, nên mình sẽ yêu cầu bạn nhập số này vào thôi :lol:

Đây là chương trình của bạn

http://www.mediafire.com/?pq42e3y492v12in

Tên lệnh là XPL ( Xuất Pline)

Kết quả trả về dưới file txt cho bạn

Tháng 10 17, 2010

Theo như góp ý của Bác em đã phân ra đánh số thứ thự theo nhóm rồi.

Còn các boundary là arc hoặc pline cong thực ra trong chắc địa rất ít dùng nên em không nghiên cứu tiếp vào phần này.

;; 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"))))
(setq lss (append lss (list ss)))
(command "zoom" "e")
(taobo lss)
)

(defun taobo ( 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)
p1 (cdr (assoc 10 ent))
p2 (cdr (assoc 11 ent))
j 0
)
(command "point" (polar p1 (angle p1 p2) (/ (distance p1 p2) 2)))
(setq poi (entlast)
list_point (ssadd poi list_point))
(command "change" list_point "" "p" "la" "point_template" "")
(while ((setq name1 (ssname ss j)
ent1 (entget name1)
p3 (cdr (assoc 10 ent1))
p4 (cdr (assoc 11 ent1))
giao (inters p1 p2 p3 p4 T)
)
(if (not (eq name name1))
(progn
(if (and (/= giao nil) (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
(entmake (subst (cons 11 giao) (assoc 11 ent1) ent1))
(setq lm (entlast) ss (ssadd lm ss) dk1 (sslength ss))
(entmod (subst (cons 10 giao) (assoc 10 ent1) ent1))
)
)
(if (and (/= giao nil) (or (equal giao p1 0.01) (equal giao p2 0.01)) 
(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) dk1 (sslength ss))
(entmod (subst (cons 10 giao) (assoc 10 ent1) ent1))
)
)
)
)
(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 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 (/= ssdk nil)
(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
)

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

Tháng 10 17, 2010

bạn tamkt này

1,d 25,0.9,0.9

2,d 25,0.9,48.9

3,d 25,44.1,48.9

4,d 25,44.1,0.9

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

16 thay đổi theo chiều dày của pline

tức là thay đổi thế nào nhỉ :lol:

Chỉ có chổ này chưa hiểu thôi, nên mình sẽ yêu cầu bạn nhập số này vào thôi :lol:

Đây là chương trình của bạn

http://www.mediafire.com/?pq42e3y492v12in

Tên lệnh là XPL ( Xuất Pline)

Kết quả trả về dưới file txt cho bạn

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

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.

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

Đăng nhập

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

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

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

hugo75 4

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

hdt4151 1

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

Tue_NV 3.912

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

TRUNGNGAMY 91

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

tamkt 2

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

nguyentuyen6 130

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

thiep 365

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

TokyoNhat 16

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

nguyentuyen6 130

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

thiep 365

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

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

tamkt 2

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

KS.PhanThanhTu 76

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

tamkt 2