Đến nội dung


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

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


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

#2261 thiep

thiep

    biết dimbaseline

  • Members
  • PipPipPipPipPip
  • 369 Bài viết
Điểm đánh giá: 260 (khá)

Đã gửi 16 October 2010 - 01:48 PM

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.
  • 1

#2262 TokyoNhat

TokyoNhat

    biết vẽ spline

  • Members
  • PipPip
  • 94 Bài viết
Điểm đánh giá: 16 (tàm tạm)

Đã gửi 16 October 2010 - 01:52 PM

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:
  • 1
  • Quá khứ là lịch sử, tương lai là màu nhiệm, còn hiện tại là món quà của cuộc sống...
  • Cuộc sống vốn không công bằng - Hãy tập quen dần với điều đó

#2263 nguyentuyen6

nguyentuyen6

    biết lệnh chamfer

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

Đã gửi 16 October 2010 - 01:57 PM

@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.
  • 0

Lisp In bản vẽ hàng loạt:
http://www.cadviet.c...ndpost&p=139860


#2264 gia_bach

gia_bach

    biết lệnh adcenter

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

Đã gửi 16 October 2010 - 01:58 PM

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

  • 2

#2265 thiep

thiep

    biết dimbaseline

  • Members
  • PipPipPipPipPip
  • 369 Bài viết
Điểm đánh giá: 260 (khá)

Đã gửi 16 October 2010 - 02:21 PM

@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.
  • 1

#2266 w1nDream

w1nDream

    biết lệnh ddedit

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

Đã gửi 16 October 2010 - 02:35 PM

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.c...5__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.
  • 0
__Tâm tựa lưu thủY__
Vi nhân nan

#2267 phamngoctukts

phamngoctukts

    biết lệnh adcenter

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

Đã gửi 16 October 2010 - 03:52 PM

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 :
Hình đã gửi
Đó 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
)

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

#2268 tamkt

tamkt

    biết vẽ ellipse

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

Đã gửi 16 October 2010 - 08:49 PM

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="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
* 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="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="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
* Àâòîð: Âëàäèìèð Àçàðêî 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.
  • 0

#2269 KS.PhanThanhTu

KS.PhanThanhTu

    biết vẽ point

  • Members
  • PipPip
  • 97 Bài viết
Điểm đánh giá: 76 (tàm tạm)

Đã gửi 16 October 2010 - 09:32 PM

Bạn TamKt có thể gửi 1 file dwg của bạn cần xuất ra txt đc ko :lol:
  • 0
KS Phan Thanh Tú.Email: Vansulich@yahoo.com

#2270 tamkt

tamkt

    biết vẽ ellipse

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

Đã gửi 16 October 2010 - 09:57 PM

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

Hình đã gửi

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

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

#2271 KS.PhanThanhTu

KS.PhanThanhTu

    biết vẽ point

  • Members
  • PipPip
  • 97 Bài viết
Điểm đánh giá: 76 (tàm tạm)

Đã gửi 16 October 2010 - 11:52 PM

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)

Hình đã gửi

Đâ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...zvrqjm8vwipvaxb
  • 1
KS Phan Thanh Tú.Email: Vansulich@yahoo.com

#2272 KS.PhanThanhTu

KS.PhanThanhTu

    biết vẽ point

  • Members
  • PipPip
  • 97 Bài viết
Điểm đánh giá: 76 (tàm tạm)

Đã gửi 17 October 2010 - 12:31 AM

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

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

Kết quả trả về dưới file txt cho bạn
  • 0
KS Phan Thanh Tú.Email: Vansulich@yahoo.com

#2273 Tue_NV

Tue_NV

    KS Võ Quang Tuệ

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

Đã gửi 17 October 2010 - 07:23 AM

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
)

Hình đã gửi

Chào bạn PhamngocTukts
Bị lỗi trong trường hợp này, bạn nè :
Hình đã gửi
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
  • 0

#2274 tamkt

tamkt

    biết vẽ ellipse

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

Đã gửi 17 October 2010 - 01:13 PM

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...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...8stz8i1gmxc7ibd
  • 0

#2275 phamngoctukts

phamngoctukts

    biết lệnh adcenter

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

Đã gửi 17 October 2010 - 01:42 PM

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.c...5__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))
)
)
)

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

#2276 phamngoctukts

phamngoctukts

    biết lệnh adcenter

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

Đã gửi 17 October 2010 - 02:20 PM

Chào bạn PhamngocTukts
Bị lỗi trong trường hợp này, bạn nè :
Hình đã gửi
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.
  • 0
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!

#2277 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

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

Đã gửi 17 October 2010 - 03:16 PM

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.c...5__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 (< i n)
(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 (< 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.c.../3/windream.jpg
Và đây là file cad đã chạy lisp. Rất tiếc trang upload của diễn đàn bị l64i kh6ng upload file được, mình sẽ up sau nếu cần đối chứng.
http://www.cadviet.c...m15__km16_2.dwg
Chúc bạn vui.

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
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#2278 phamngoctukts

phamngoctukts

    biết lệnh adcenter

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

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

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.c.../3/windream.jpg
Và đây là file cad đã chạy lisp. Rất tiếc trang upload của diễn đàn bị l64i kh6ng upload file được, mình sẽ up sau nếu cần đối chứng.
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é.
  • 0
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!

#2279 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

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

Đã gửi 17 October 2010 - 06:35 PM

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ề....
  • 1
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#2280 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

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

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

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

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.
  • 1
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.