Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

[Ar_Chanwoo 39]

Có 2 cách để giải quyết vấn đề trên.

 

Cách 1: Bạn bỏ dòng lệnh (setvar "osmode" 0) đi, lúc này lệnh cu sẽ thực hiện sai với một số trường hợp (do bắt nhầm điểm).

 

Cách 2: Nếu bạn muốn giữ dòng lệnh (setvar "osmode" 0) để cu thực hiện đúng trong mọi trường hợp, bạn phải thêm đoạn mã lưu biến osmode gốc tại khởi đầu của lệnh cu:

(setq old_osmode (getvar "osmode")

old_autosnap (getvar "autosnap")

)

Và trước khi kết thúc lệnh, bạn thêm vào đoạn mã trả về giá trị osmode ban đầu:

(if old_osmode (setvar "osmode" old_osmode))

(if old_autosnap (setvar "autosnap" old_autosnap))

Như vậy, đoạn mã lệnh của bạn sẽ trở thành:

(defun c:cu()
[color="#0000FF"](setq old_osmode (getvar "osmode")
       old_autosnap (getvar "autosnap")
)[/color]
(setvar "osmode" 512 )
(setq p1 (getpoint "\nfirst point :"))
(if (= nil p1)(sdor)(odor))
[color="#0000FF"](if old_osmode (setvar "osmode" old_osmode))
(if old_autosnap (setvar "autosnap" old_autosnap))
[/color]
)
(defun odor ()
(setq p2 (getpoint p1 "\nsecond point width open :"))
(setvar "osmode" 128 )
(setq p3 (getpoint p2 "\npick in wall :")
p31 (polar p1 (angle p2 p3) (distance p2 p3))
)
(setvar "osmode" 0 )
(command "line" p1 p31 "")
(setq s1 (entlast));de copy ve do cua so
(command "line" p2 p3 "" "trim" "c" p3 p1 ""
(polar p1 (angle p1 p2) (/ (distance p1 p2) 2))
(polar p31 (angle p1 p2) (/ (distance p1 p2) 2)) ""
)
(setq sel (strcase (getstring "\nWin Open <Dor> :")))
(cond ((= sel "W")(openwin))
((= sel "")(opendor))
(T (princ))
)
(princ)
)
(defun sdor ()
(setvar "osmode" 1 )
(setq p1 (getpoint "\nfirst point :"))
(setq p2 (getpoint p1 "\nsecond point width open :"))
(setvar "osmode" 128 )
(setq p3 (getpoint p2 "\npick in wall :")
p31 (polar p1 (angle p2 p3) (distance p2 p3))
)
(setvar "osmode" 0 )
(command "line" p1 p31 "")
(setq s1 (entlast)) ;de copy ve do cua so
(setq sel (strcase (getstring "\nWin Open <Dor> :")))
(cond ((= sel "W")(openwin))
((= sel "")(opendor))
(T (princ))
)
(princ)
)
;-----------
(defun opendor ()
(setq ang (getangle (polar p1 (angle p1 p2) (/ (distance p1 p2) 2)) "\ndirection open :")
nsegdor (getint "\nnumber seg dor 2 4 <1> :")
)
(cond ((= nsegdor 2)(dor2 p1 p2 ang))
((= nsegdor 4)(dor4 p1 p2 ang))
(T (dor p1 p2 ang))
)
)
;----------
(defun dor4 (p1 p2 ang)
(setq p12 (polar p1 (angle p1 p2) (/ (distance p1 p2) 2)))
(setq p112 (polar p1 (angle p1 p12) (/ (distance p1 p12) 2)))
(setq p122 (polar p12 (angle p1 p12) (/ (distance p1 p12) 2)))
(dor p1 p112 ang)(dor p112 p12 ang)(dor p2 p122 ang)(dor p122 p12 ang)
)
;----------
(defun dor2 (p1 p2 ang)
(setq p12 (polar p1 (angle p1 p2) (/ (distance p1 p2) 2)))
(dor p1 p12 ang)(dor p2 p12 ang)
)
;----------
(defun dor (p1 p2 ang)
(setq ps1 (polar p1 (angle p1 p2) 0.5)
ps2 (polar ps1 ang (distance p1 p2))
ps3 (polar ps2 (angle p2 p1) 0.5)
)
(command "pline" ps3 ps2 ps1 p1 ps3 ps2 "a" p2 "" )
)
;----------
(defun openwin ()
(command "line" p1 p2 "" "line" p31 p3 ""
"line" (polar p1 (angle p2 p3) (/ (distance p2 p3) 2))
(polar p2 (angle p2 p3) (/ (distance p2 p3) 2)) ""
)
(setq nsegwin (getint "\nnumber seg win :")
disseg (/ (distance p1 p2) nsegwin)
)
(setq lispoiseg nil)
(repeat (- nsegwin 1)
(setq lispoiseg (append lispoiseg (list (polar p1 (angle p1 p2) (* (- nsegwin 1) disseg))))
nsegwin (- nsegwin 1)
)
)
(command "copy" s1 "" "m" p1)
(foreach p lispoiseg (command p))
(command "")
)
(PRINC) 

 

Vấn đề mà bạn nêu ra rất điển hình, mọi chương trình lisp sử dụng hàm command và tác động vào điểm của AutoCAD luôn gặp phải. Đoạn mã theo cách 2 trên được thực hiện trong hầu hết các lisp để giải quyết khó khăn này.

 

 

 

 

E đã dùng thử lisp trên và thấy là vẫn bị lỗi mất bắt điẻm, ko biết có phải là do e dùng sai hay ko nữa. Nhân tiện e có mấy cái lisp vẽ cửa rất đẹp e đã dùng rồi nhưng giờ sao lại không dùng đc nữa, hoặc có cái thì mẫt bắt điwmr như trên. Mong a e xem hộ e !!

 

http://www.cadviet.com/upfiles/Loi.rar

[duy782006 1.544]

Nhờ mọi người giúp tôi các việc sau với: biết rằng cái này có nói rồi nhưng tôi vẫn chưa hiểu mong các bác thông cảm giúp thêm lần nửa nhe1

-Tôi có chuổi giatrisld muốn làm hai việc:

+Lấy ra chuổi giatri chính là giatrisld bỏ đi 3 ký tự sau cùng.

+Lấy ra chuổi giatridau chính là giatrisld bỏ đi 3 ký tự đầu tiên.

 

-Có cách nào lấy đường dẩn đến 1 thư mục (không phải file) bằng lisp không? Chỉ giúp tôi với.

[Ar_Chanwoo 39]

Ai có thế sử dụng Lisp thuvien này thì giúp mình với ! Cứ mỗi lần mở ra Cad lại bị đơ!

http://www.cadviet.com/upfiles/New_Folder_2.rar

[Ar_Chanwoo 39]

Ai có thế sử dụng Lisp thuvien này thì giúp mình với ! Cứ mỗi lần mở ra Cad lại bị đơ!

http://www.cadviet.com/upfiles/New_Folder_2.rar

Ko ai có ý kiến gì ah !

[vndesperados 254]

???????????????

 

 

Vấn đề không nằm ở file LISP mà nằm ở file xdtf.INI

Có một ký tự bất thường

 

*0*Caymb*C:\Thuvien\Thuvien\caymb

*1*DÇm*C:\Thuvien\Thuvien\Dam <-- tại dòng này

*2*Khung*C:\Thuvien\Thuvien\Khung

*3*Lanhto*C:\Thuvien\Thuvien\Lanhto

*7*LinhTinh*C:\ThuVien\Thuvien\Linhtinh

Fix lại cái này đi nha.

[Ar_Chanwoo 39]

Vấn đề không nằm ở file LISP mà nằm ở file xdtf.INI

Có một ký tự bất thường

 

*0*Caymb*C:\Thuvien\Thuvien\caymb

*1*DÇm*C:\Thuvien\Thuvien\Dam <-- tại dòng này

*2*Khung*C:\Thuvien\Thuvien\Khung

*3*Lanhto*C:\Thuvien\Thuvien\Lanhto

*7*LinhTinh*C:\ThuVien\Thuvien\Linhtinh

Fix lại cái này đi nha.

Cảm ơn bạn đã quan tâm! Mình Fix lại rồi nhưng không đc ! Bạn đọc lisp rồi chỉ chỗ sai cho mình với ! Mà hình như tên gốc của file INI không phải là xdtf.INI thì phải ! Mình lấy từ đâu về dùng bây giờ thấy ko dùng đc ! Vẫn mở đc giao diên của hộp thoại nhưng sau đó cad bị đơ luôn ! Còn lỗi bạn nói là do bị Font chữ ! Mong bạn giúp đỡ!

[h2c 1]

Mình vừa viết xong lisp này để copy đối tượng align theo đường thẳng cho trước với khoảng cách xác định theo phương đứng . Nhưng mà có cái gì đó sai trong dòng command copy .

(defun c:FG()
 (setq
	OBJ (entsel "\nSelect object :")
	LI (entget (car (entsel "\nSelect line :")))
P1 (cdr(assoc 10 LI))
	P2 (cdr(assoc 11 LI))
x1 (car P1)
y1 (cadr P1)
x2 (car P2)
y2 (cadr P2)
	goc (atan (- y2 y1) (- x2 x1))
	BP (getpoint "\nBase point :")
DI (getreal "\nVertical distance : ")
SB (getint "\nNumber of step :")
	n 0
)
 (while (< n SB)
(setq BP1 (polar BP goc (/ DI (cos goc))))
(command "copy" OBJ BP BP BP1 "")
(setq BP BP1)
(setq OBJ entlast)
(setq n (+ n 1))
 )
(princ)
)

Cám ơn mọi người .

[ssg 1.102]

Mình vừa viết xong lisp này để copy đối tượng align theo đường thẳng cho trước với khoảng cách xác định theo phương đứng . Nhưng mà có cái gì đó sai trong dòng command copy .

 

(defun c:FG()

(setq

OBJ (entsel "\nSelect object :")

LI (entget (car (entsel "\nSelect line :")))

P1 (cdr(assoc 10 LI))

P2 (cdr(assoc 11 LI))

x1 (car P1)

y1 (cadr P1)

x2 (car P2)

y2 (cadr P2)

goc (atan (- y2 y1) (- x2 x1))

BP (getpoint "\nBase point :")

DI (getreal "\nVertical distance : ")

SB (getint "\nNumber of step :")

n 0

)

(while (< n SB)

(setq BP1 (polar BP goc (/ DI (cos goc))))

(command "copy" OBJ BP BP BP1 "")

(setq BP BP1)

(setq OBJ entlast)

(setq n (+ n 1))

)

(princ)

)

 

Cám ơn mọi người .

A- Lỗi ở những chỗ đánh dấu đỏ

 

B- Chương trình đã sửa, giữ nguyên cấu trúc và thuật giải của bạn:

;;;-----------------------------------------------
(defun c:FG()
(setq
   OBJ (entsel "\nSelect object :")
   LI (entget (car (entsel "\nSelect line :")))
   P1 (cdr (assoc 10 LI))
   P2 (cdr (assoc 11 LI))
   x1 (car P1)
   y1 (cadr P1)
   x2 (car P2)
   y2 (cadr P2)
   goc (atan (- y2 y1) (- x2 x1))
   BP (getpoint "\nBase point :")
   DI (getreal "\nVertical distance : ")
   SB (getint "\nNumber of step :")
   n 0
   oldos (getvar "osmode")
)
(setvar "osmode" 0)
(while (< n SB)
   (setq BP1 (polar BP goc (/ DI (sin goc))))
   (command "copy" OBJ "" BP BP1 "")
   (setq BP BP1)
   (setq OBJ (entlast))
   (setq n (+ n 1))
)
(setvar "osmode" oldos)
(princ)
)
;;;-----------------------------------------------

 

C- Chương trình lập theo ý ssg để bạn tham khảo:

;;;-----------------------------------------------
(defun c:FG2( / obj Li Di Sb P1 p2 goc n oldos P3)
(setq
   OBJ (ssget)
   LI (entget (car (entsel "\nSelect line :")))
   DI (getreal "\nVertical distance : ")
   SB (getint "\nNumber of step :")
   P1 (cdr (assoc 10 LI))
   P2 (cdr (assoc 11 LI))
   goc (angle P1 P2)
   n 1
   oldos (getvar "osmode")
)
(if (> goc pi) (setq goc (- goc pi)))
(setvar "osmode" 0)
(repeat SB
   (setq P3 (polar P1 goc (* (/ DI (sin goc)) n)))
   (command "copy" OBJ "" P1 P3 "")
   (setq n (1+ n))
)
(setvar "osmode" oldos)
(princ)
)
;;;-----------------------------------------------

Những khác biệt và góp ý thêm:

1) OBJ dùng ssget, bạn có thể chọn được nhiều đối tượng nếu cần. Các đối tượng được highlight, user dễ nhìn hơn (dùng entsel cũng có hightlight nhưng bạn phải thêm hàm redraw)

2) Dùng angle lấy góc đơn giản hơn, chỉ cần bổ sung thêm tình huống nếu goc > 180 độ

3) Khi số lần lặp đã xác định trước, dùng repeat nói chung là hay hơn while

4) Yêu cầu nhập Base point là không cần thiết

5) Đừng bao giờ quên disable osmode trước khi gọi các command liên quan đến thao tác vẽ

6) Tập thói quen thiết lập Local Variables như là programmer chuyên nghiệp

7) Nên thận trọng hơn trong thao tác, đừng để những lỗi cú pháp không đáng có. Một biện pháp hữu hiệu giảm thiểu lỗi là hãy viết thật rõ ràng, mạch lạc, những chỗ ra vô đầu dòng tuân theo trật tự nhất quán. Bạn có thể dùng Visual Lisp Editor để hỗ trợ

từ viết chương trình, check lỗi đến chạy thử.

[h2c 1]

Cám ơn ssg . Nhưng cho mình hỏi là tại sao phải tạo local variable . Khi mình thử del dòng khai báo variable đi thì nó vẫn chạy tốt mà ( đây mới là chỗ mình khó hiểu ) ? Nên trước giờ mình ít khi nào khai báo như thế lắm , mong bạn giải thích thêm . Thanks .

[ssg 1.102]

Cám ơn ssg . Nhưng cho mình hỏi là tại sao phải tạo local variable . Khi mình thử del dòng khai báo variable đi thì nó vẫn chạy tốt mà ( đây mới là chỗ mình khó hiểu ) ? Nên trước giờ mình ít khi nào khai báo như thế lắm , mong bạn giải thích thêm . Thanks .

Bạn xem ở đây, trong bài 2 mình có phân tích khá kỹ về cái này:

http://www.cadviet.com/forum/Huong-dan-lap...Lisp-t2480.html

 

Một thử nghiệm nhỏ: chạy chương trình trên của bạn không khai báo local variables. Khi kết thúc, bạn nhập dòng sau vào Command: (setq X SB) -> kết quả trả về là SB mà bạn vừa chạy chương trình. Điều đó nghĩa là, chương trình của bạn đã kết thúc nhưng bạn vẫn chiếm dụng memory của máy tính, bắt nó phải tốn chỗ để nhớ cái giá trị không còn cần thiết cho ai nữa.

Nếu khai báo local variable, khi thực hiện xong function đó, memory được giải phóng khỏi tất cả các biến mà bạn đã khai báo sau dấu /

Ngoài ra, khi bạn lập một chương trình lớn, số lượng variables rất nhiều, chính bạn cũng không thể nhớ hết và không kiểm soát nổi chúng. Có khả năng chúng sẽ làm sai lệch kết quả chạy chương trình mà bạn không hề hay biết, đặc biệt là trong các biểu thức điều kiện trong vòng while hoặc if.

Ví dụ, sau biểu thức trên, bạn nhập tiếp: (if SB (alert "Do you need me now?")). May mà nó hỏi, còn nó im lặng làm những trò gì dại dột thì bạn lãnh đủ!

[proconeng86 7]

cho em hỏi cái này. Em có 1 lisp nhưng không hiểu ý nghĩa của nó. Bác nào giải đáp giúp em với :

 

(defun C:ECO ()
      (start_timer)
      (create_layer_table)
      (if (= explode_plines? "Y")
          (explode_plines))
      (economize_by_layer)
      (if (= compress? "Y")
          (compress_by_layer))
      (restore_layers)
      (if (= compress? "Y")
          (explode_1segment_plines))
      (stop_timer))

(defun start_timer ()
      (setq deleted 0
            c_date (getvar "cdate")
            s_date (getvar "tdusrtimer")
            dwg (getvar "dwgname")
            explode_plines? (strcase (userstr (if explode_plines? explode_plines? "Y")
                                              "Explode polylines before beginning?"))
            compress? (strcase (userstr (if compress? compress? "Y")
                                        "Join touching lines into multi-segment polylines?")))
      (princ (strcat "\nStarting to process drawing " dwg " on " (parse_time c_date))))
(defun stop_timer ()
      (setq e_date (getvar "tdusrtimer")
            t_secs (* 86400.0 (- e_date s_date))
            hrs (fix (/ t_secs 3600.0))
            mns (fix (/ (- t_secs (* hrs 3600.0)) 60.0))
            secs (- t_secs (+ (* hrs 3600.0) (* mns 60.0))))
      (if (null (setq fil (open (strcat dwg ".eco") "a")))
          (progn (princ (strcat "\nCouldn't open " dwg ".eco for writing.
Writing to current directory instead."))
                 (setq fil (open (strcat dwg ".eco") "a"))))
      (princ "\nECONOMIZE active for ")
      (princ (strcat "\nStarted processing drawing " dwg " on " (parse_time c_date)) fil)
      (princ "\nECONOMIZE v. 2.1 active for " fil)
      (if (> hrs 0.0)
          (princ (strcat (itoa hrs) " hour" (if (> hrs 1) "s" "") ", ") fil))
      (if (> mns 0.0)
          (princ (strcat (itoa mns) " minute" (if (> mns 1) "s" "") ", ") fil))
      (princ (strcat (rtos secs 2 3) " seconds.") fil)
      (princ (strcat "\nFile: " dwg ": Deleted a total of " (itoa deleted) " redundant lines.") fil)
      (princ "\n--------" fil)
      (close fil)
      (if (> hrs 0.0)
          (princ (strcat (itoa hrs) " hour" (if (> hrs 1) "s" "") ", ")))
      (if (> mns 0.0)
          (princ (strcat (itoa mns) " minute" (if (> mns 1) "s" "") ", ")))
      (princ (strcat (rtos secs 2 3) " seconds."))
      (princ (strcat "\nFile: " dwg ": Deleted a total of " (itoa deleted) " redundant lines."))
      (princ))

(defun economize_by_layer ()
      (setq c_lay (getvar "clayer"))
;       (setvar "regenmode" 0)
      (setvar "cmdecho" 0)
      (setvar "blipmode" 0)
      (setvar "osmode" 0)
      (foreach lyr (mapcar 'car lyrs)
               (if (and (setq lines (ssget "x" (list (cons 0 "LINE")
                                              (cons 8 lyr)))
                              *lines* lines)
                         (setq lines_l (sslength lines)))
                   (process_lines lyr)))
       (command "layer" "t" "*" "on" "*" "s" c_lay ""))

(defun create_layer_table ()
      (setq c_lay (getvar"clayer")
            lyr_data (tblnext "layer" t)
            lyr_nm (cdr (assoc 2 lyr_data))
            lyr_thawed? (cdr (assoc 70 lyr_data))
            lyr_on? (cdr (assoc 62 lyr_data))
            lyrs (list (list lyr_nm lyr_thawed? lyr_thawed?)))
      (while (setq lyr_data (tblnext "layer"))
             (setq lyr_nm (cdr (assoc 2 lyr_data))
                   lyr_thawed? (cdr (assoc 70 lyr_data))
                   lyr_on? (cdr (assoc 62 lyr_data))
                   lyrs (cons (list lyr_nm lyr_thawed? lyr_on?) lyrs))))

(defun freeze_all_but (layr)
      (command "layer" "t" layr "on" layr "s" layr)   ;; Thaw working layer
      (foreach l (aux_remove layr (mapcar 'car lyrs)) ;; Freeze all others
               (command "f" l))
      (command ""))

; (70 . 64) thawed
; (70 . 65) frozen
; (62 . 7)  on 
; (62 . -7) off 

(defun restore_layers ()
      (command "layer")
      (setq c_lay_data (assoc c_lay lyrs)
            lyr_thawed? (cadr c_lay_data)
            lyr_on? (caddr c_lay_data))
      (if (= lyr_thawed? 65)
          (command "f" c_lay)
          (command "t" c_lay))
      (if (> lyr_on? 0)
          (command "on" c_lay)
          (command "off" c_lay))
      (command "s" c_lay)
      (foreach lr (aux_remove c_lay_data lyrs);; read layer data 
               (setq lyr_nm (car lr)          ;; from layer property table
                     lyr_thawed? (cadr lr)
                     lyr_on? (caddr lr))
               (if (= lyr_thawed? 65)
                   (command "f" lyr_nm)
                   (command "t" lyr_nm))
               (if (> lyr_on? 0)
                   (command "on" lyr_nm)
                   (command "off" lyr_nm)))
      (command ""))

(defun process_lines (layr / incr)
      (freeze_all_but layr)
      (if lines (progn (terpri)
                       (setq incr 0
                             ssl (sslength lines)
                             l_deleted 0)
                       (repeat ssl
                               (setq ln (ssname lines incr))
                               (princ (strcat "\rProcessing line "
                                              (itoa (1+ incr)) " of "
                                              (itoa lines_l)
                                              " on layer " layr))
                               (if (and ln (ssmemb ln *lines*))
                                   (compile ln))
                               (setq incr (1+ incr)))))
      (princ (strcat "\t\tDeleted " (itoa l_deleted) " redundant lines.")))

(defun compile (lin / ld *lin_ss ptlst ext_pts i sl)
      (if lin
          (progn (setq lin* lin
                       ld (get_line_data lin)
                       lin_ss (ssget "c" *p1* *p2*)
                       *lin_ss* (ss2enamlist lin_ss)
                       *lin_ss (filter_non-colinear_segments lin *lin_ss*)
                       ptlst (create_ptlst *lin_ss))
                 (if (and *lin_ss
                          (> (sslength *lin_ss) 1))
                     (progn (setq ext_pts (extreme_pts ptlst)
                                  lin1 (ssname *lin_ss 0)
                                  *lin1 (entget lin1)
                                  lyr (cdr (assoc 8 *lin1)))
                            (if (and *lin_ss 
                                     (setq *ssl (sslength *lin_ss)))   
                                (progn (setq deleted (+ deleted *ssl)
                                             l_deleted (+ l_deleted *ssl))
                                       (command "erase" *lin_ss "")
                                       (command "layer" "m" lyr "")
                                       (command "line" (car ext_pts)
                                                       (cadr ext_pts) ""))) 
                            T)))))

(defun create_ptlst (ss / i sl l1 *l1 n1 n2 pts)
      (cond ((null ss) nil)
            ((/= (type ss) 'PICKSET) nil)
            ((< (setq sl (sslength ss)) 2) nil)
            (T (setq i 1
                     sl (sslength ss)
                     l1 (ssname ss 0)
                     *l1 (entget l1)
                     n1 (cdr (assoc 10 *l1))
                     n2 (cdr (assoc 11 *l1))
                     pts (list n1 n2))
               (repeat (1- sl)
                       (setq l1 (ssname ss i)
                             *l1 (entget l1)
                             n1 (cdr (assoc 10 *l1))
                             n2 (cdr (assoc 11 *l1)))
                       (if (null (member n1 pts))
                           (setq pts (append pts (list n1))))
                       (if (null (member n2 pts))
                           (setq pts (append pts (list n2))))
                       (setq i (1+ i)))
               pts)))

(defun filter_non-colinear_segments (lin enamlst / l sl)
      (cond ((or (null enamlst)
                 (null lin)) nil)
            (T (foreach l enamlst
                        (if (and l  ;; if line isn't parallel to test line, 
                                 (not (colinear lin l))) ;; delete it from set
                            (ssdel l lin_ss)    ;; of lines to be processed
                            (ssdel l *lines*))) ;; else, assume it will be erased.
      lin_ss)))

(defun extreme_pts (pt_list)
      (cond ((or (null pt_list)
                 (< (length pt_list) 2)) nil) ;; termination condition
            ((= (length pt_list) 2) pt_list)  ;; only 2 pts in list
            (T (setq n1 (car pt_list)         ;; find extreme points
                     n2 (cadr pt_list))
               (cond ((v-orient n1 n2)
                      (setq plst (mapcar 'xy pt_list)
                            rev_p (mapcar 'reverse plst)
                            y_coords (mapcar 'car rev_p)
                            min_y (apply 'min y_coords)
                            max_y (apply 'max y_coords)
                            _n1 (assoc min_y rev_p)
                            _n2 (assoc max_y rev_p)
                            *n1 (reverse _n1)
                            *n2 (reverse _n2)))
                     ((h-orient n1 n2)
                      (setq plst (mapcar 'xy pt_list)
                            x_coords (mapcar 'car plst)
                            min_x (apply 'min x_coords)
                            max_x (apply 'max x_coords)
                            *n1 (assoc min_x plst)
                            *n2 (assoc max_x plst)))
                     ((setq direct (diagonal n1 n2))
                      (setq plst (mapcar 'xy pt_list)
                            rev_p (mapcar 'reverse plst)
                            x_coords (mapcar 'car plst)
                            y_coords (mapcar 'car rev_p)
                            min_x (apply 'min x_coords)
                            max_x (apply 'max x_coords)
                            min_y (apply 'min y_coords)
                            max_y (apply 'max y_coords))
                      (if (= direct 'LLUR) ; if we got this far, DIRECT is non-nil
                          (setq  *n1 (list min_x min_y)
                                 *n2 (list max_x max_y))
                          (setq  *n1 (list max_x min_y)  
                                 *n2 (list min_x max_y)))))
                    (list *n1 *n2))))

(defun get_line_data (line)
      (setq elist (entget line)
            *p1* (cdr (assoc 10 elist))
            *p2* (cdr (assoc 11 elist))
            *ang1* (angle *p1* *p2*)
            h_pi* (/ pi 2.0)))

(defun colinear (lin1 lin2 / line1 line2)
      (if (and lin1 lin2
               (setq line1 (entget lin1))
               (setq line2 (entget lin2))
               (setq l1p1 (cdr (assoc 10 line1)))
               (setq l1p2 (cdr (assoc 11 line1)))
               (setq l2p1 (cdr (assoc 10 line2)))
               (setq l2p2 (cdr (assoc 11 line2)))
               (setq ang1 (rad2deg (angle l1p1 l1p2)))
               (setq ang2a (rad2deg (angle l2p1 l2p2)))
               (setq ang2b (rad2deg (angle l2p2 l2p1))))
          (progn (if (not (equal l1p1 l2p1))
                     (setq ang3 (rad2deg (angle l1p1 l2p1)))
                     (setq ang3 nil))
                 (if (not (equal l1p1 l2p2))
                     (setq ang4 (rad2deg (angle l1p1 l2p2)))
                     (setq ang3 nil))
                 (and (or (= ang1 ang2a) ; pass the test for parallelism
                          (= ang1 ang2b))
                      (or (= ang2a ang3) ; pass the test that one point
                          (= ang2b ang3) ; on the segment is colinear with
                          (= ang2a ang4) ; the test segment
                          (= ang2b ang4))))))

(defun ~= (actual_value test_value tolerance)  ;;fuzzy equality
      (if (and actual_value test_value tolerance)
          (<= (abs (- actual_value test_value)) tolerance)))

(defun DEG2RAD (ang)
      (* pi (/ ang 180.000000)))

(defun RAD2DEG (ang)
      (* ang (/ 360 (* pi 2.000000))))

(defun pos-in-list (item lst)
       (if (null (member item lst))
           nil
           (- (length lst) (length (cdr (member item lst))))))

(defun 2D-TO-3D (pt elev)   ;; Construct 3D point with elev as Z coordinate
      (if pt (append (xy pt) (list elev))
             (append (getpoint "\nFirst point: ") (list elev))))

(defun XY (pt) ;; convert 3D point to 2D
      (list (car pt) (cadr pt)))

;; find closest point in node list "nodes" to point "pt"'
(defun closest (pt nodes)
      (nth
         (1- (pos-in-list
                (apply 'min (mapcar '(lambda (node) (distance pt node)) nodes))
                            (mapcar '(lambda (node) (distance pt node)) nodes)))
       nodes))

(defun v-orient (p1 p2) ;;are two points in a basically vertical relationship?
       (> (abs (- (cadr p1) (cadr p2))) 
          (abs (- (car p1) (car p2))))) 

(defun vertical (p1 p2)
      (= (car p1) (car p2)))

(defun horizontal (p1 p2)
      (= (cadr p1) (cadr p2)))

(defun h-orient (p1 p2) ;;are two points in a horizontal relationship?
       (< (abs (- (cadr p1) (cadr p2))) 
          (abs (- (car p1) (car p2))))) 

(defun diagonal (p1 p2 / ang1)
      (setq ang1 (rad2deg (angle p1 p2)))
      (cond ((or (= ang1 45.0)
                 (= ang1 225.0)) 'LLUR)  ;; return direction of vector
            ((or (= ang1 135.0)
                 (= ang1 315.0)) 'LRUL)  ;; return direction of vector
            (T nil)))                    ;; else, nil

(defun left-to-right (p1 p2) ;;is vector P1 P2 pointing to right?
         (and (h-orient p1 p2)
              (<= (car p1) (car p2))))

(defun right-to-left (p1 p2)  ;;is vector P1 P2 pointing to left?
         (and (h-orient p1 p2)
              (> (car p1) (car p2))))

(defun top-to-bottom (p1 p2) ;;is vector P1 P2 pointing down?
         (and (v-orient p1 p2)
              (> (cadr p1) (cadr p2))))

(defun bottom-to-top (p1 p2)  ;;is vector P1 P2 pointing up?
         (and (v-orient p1 p2)
              (<= (cadr p1) (cadr p2))))

;; convert a selection set to a list of entity lists
(defun ss2enamlist (ss / entlist ctr)
      (if ss (progn
          (setq ctr 0)
          (repeat (sslength ss)
                  (progn (setq entlist (cons (ssname ss ctr) entlist))
                         (setq ctr (1+ ctr)))))) (if entlist entlist))

;(defun ~= (actual_value test_value tolerance)  ;;fuzzy equality
;       (and (<= actual_value (+ test_value tolerance))
;            (>= actual_value (- test_value tolerance))))

(defun aux_remove (atm lst) 
      (cond ((null lst) nil) 
            ((null (member atm lst)) lst)
            ((equal atm (car lst)) (cdr lst))
            (t (append (reverse (cdr (member atm (reverse lst))))
                       (cdr (member atm lst))))))

(defun parse_time (cdate / date_str year month day hour min secs date)
      (if cdate
          (setq date_str (rtos cdate 2 6)
                year (substr date_str 3 2)
                month (substr date_str 5 2) 
                day (substr date_str 7 2)
                hour (substr date_str 10 2)
                min (substr date_str 12 2)
                secs (substr date_str 14 2)
                date (strcat month "/" day "/" year "  " hour ":" min ":" secs))))

(defun explode (str / firstchr *str*)  ;; iterative text explosion
     (if (null str) nil
         (repeat (strlen str)
                 (progn
                     (setq *str* (cons (setq firstchr (substr str 1 1)) *str*))
                     (setq str (substr str 2))))) (reverse *str*))

(defun concat (lst / str)
      (if (or (null lst)
              (/= (type lst) 'LIST)) nil
          (apply 'strcat lst)))

;;;  Compresser v. 2.0

(defun explode_plines ()
      (setvar "cmdecho" 0)
      (setq plns (ssget "x" '((0 . "POLYLINE"))))
      (if plns (progn (setq lngth (sslength plns)
                            i 0)
                      (terpri)
                      (repeat lngth
                              (setq pln (ssname plns i))
                              (princ (strcat "\rExploding polyline "
                                     (itoa (1+ i))
                                     " of " (itoa lngth)))
                              (command "explode" pln)
                              (setq i (1+ i)))))
      (princ))

(defun explode_1segment_plines ()
      (setvar "cmdecho" 0)
      (setq plns (ssget "x" '((0 . "POLYLINE"))))
      (if plns (progn (setq lngth (sslength plns)
                            i 0)
                      (terpri)
                      (repeat lngth
                              (setq pln (ssname plns i))
                              (princ (strcat "\rAnalyzing polyline "
                                     (itoa (1+ i))
                                     " of " (itoa lngth)))
                              (setq num_verts (length (collect_vertices pln)))
                              (if (< num_verts 3)
                                  (progn (princ "\rExploding")
                                         (command "explode" pln)))
                              (setq i (1+ i)))))
      (princ))

(defun compress_by_layer ()
      (foreach lyr (mapcar 'car lyrs)
               (if (and (setq lines (ssget "x" (list (cons 0 "LINE")
                                              (cons 8 lyr)))
                              *lines* lines)
                         (setq lines_l (sslength lines)))
                   (compress_lines lyr))))

(defun compress_lines (layr)
      (freeze_all_but layr)
      (princ (strcat "\nCompiling lines on layer " layr "\n"))
      (while (and (setq lines (ssget "x" (list (cons 0 "LINE") (cons 8 layr))))
                  (> (setq ssl (sslength lines)) 0)
                  (setq line1 (ssname lines 0)))
              (princ "\rProcessing ")
              (princ line1)
              (command "pedit" line1 "y" "j" lines "" "x")))

(defun collect_vertices (ent / *ent* pt pts)
      (if (= (cdr (assoc 0 (setq *ent* (entget ent)))) "POLYLINE")
          (progn (setq ent (entnext ent))
                 (while (setq *ent* (entget ent) pt (cdr (assoc 10 *ent*)))
                        (setq pts (cons pt pts)
                              ent (entnext ent))))
          (princ "\ncollect_vertices: not a POLYLINE."))
      (if pts pts))

(defun userstr (dflt prmpt / var) ;;DFLT and PRMPT are strings
      (setq var (getstring (if (and dflt (/= dflt ""))
                               (strcat prmpt " <" dflt ">: ")
                               (strcat prmpt ": "))))
      (cond ((/= var "") var)
            ((and dflt (= var "")) dflt)
            (T (*error* "no default given"))))

[proconeng86 7]

sao lisp của em mặc dù lệnh đó vẫn thực hiện được nhưng xong nó vẫn hiện lên :" Unknown command "TS". Press F1 for help "

[duy782006 1.544]

(defun c:f0 ()

(setq bkflcu (getvar "filletrad"))

(setvar "filletrad" 0)

(command ".fillet" )

(setvar "filletrad" bkflcu)

(Princ))

 

 

Cho mình hỏi sao cái lisp của mình như vầy không chạy được. Nếu bỏ dòng màu đỏ đi thì được nhưng không đúng ý muốn.

Mục đích muốn dùng lệnh FILLET với tham số bán kính bằng 0 sau đó trả lại tham số bán kính chi lệnh FILLET.

Mong mọi người giúp !!!!!!!!!!!!

[ssg 1.102]

(defun c:f0 ()

(setq bkflcu (getvar "filletrad"))

(setvar "filletrad" 0)

(command ".fillet" )

(setvar "filletrad" bkflcu)

(Princ))

 

 

Cho mình hỏi sao cái lisp của mình như vầy không chạy được. Nếu bỏ dòng màu đỏ đi thì được nhưng không đúng ý muốn.

Mục đích muốn dùng lệnh FILLET với tham số bán kính bằng 0 sau đó trả lại tham số bán kính chi lệnh FILLET.

Mong mọi người giúp !!!!!!!!!!!!

Lý do: (command "fillet" ...) chưa hoàn thành vì chưa đủ các arguments cần thiết. Khi đó, Acad sẽ tiếp tục thực hiện các biểu thức lisp tiếp theo, tương tự như phương thức transparent (mình đã từng phân tích cái này ở đâu đó rồi không nhớ nữa). Đây là tính năng rất hay, cho phép bạn thực hiện command lặp lại, với số lần lặp chưa xác định trước chỉ với vài dòng code đơn giản. Bạn tìm lại một số chương trình anh Hoành đã post lên, ví dụ như trình vẽ các bậc thang sẽ thấy rõ hơn.

Quay lại trường hợp của bạn, khi chưa hoàn thành command fillet, các biểu thức lisp sau đó vẫn tiếp tục được thực hiện, trong đó có (setvar "filletrad" bkflcu). Đến khi kết thúc, trình lisp trả điều khiển lại cho Acad, nó sẽ làm tiếp lệnh fillet đang dở dang, và tất nhiên là với bán kính bkflcu như hồi đầu.

Tóm lại, chương trình của bạn được thực thi hoàn toàn đúng, chỉ có điều là không đúng với mục đích của bạn. Với cách này là không được rồi, bạn có thể dùng cách sau (hoặc tự nghĩ ra những cách khác phù hợp với mục đích sử dụng của bạn):

 

(defun c:f0 ( / oldfill oldos)
(setq
   oldfill (getvar "filletrad")
   oldos (getvar "osmode")
)
(setvar "filletrad" 0)
(setvar "osmode" 512)
(command "fillet" 
   (getpoint "\nPick at first object:")
   (getpoint "\nPick at second object:")
)
(setvar "filletrad" oldfill)
(setvar "osmode" oldos)
(princ)
)

[smilingman82 2]

cho tớ hỏi mã dxf về chiều dài length của line ,pline là gì nhỉ . Trong sách líp chỉ thống kê chung chung , ko ghi rõ code lengthen ....ván đề là tớ mún gán length của các line được chọn là 1 biến ,,,,cậu có thể trả lời hộ tớ kô

[Nguyen Hoanh 4.663]

cho tớ hỏi mã dxf về chiều dài length của line ,pline là gì nhỉ . Trong sách líp chỉ thống kê chung chung , ko ghi rõ code lengthen ....ván đề là tớ mún gán length của các line được chọn là 1 biến ,,,,cậu có thể trả lời hộ tớ kô

Không có mã dxf về chiều dài của line và pline.

 

mã Lisp tính chiều dài line và pline, bạn hãy xem ở đây: http://www.cadviet.com/forum/tinh-tong-chi...uong-t2020.html

[missone's 6]

Mọi người cho em hỏi chút- là khi em áp dụng lệnh ND- copy đối tượng và khi paste thì nó đè lên đối tượng (text) khác- em đã appload thành công- gõ lệnh ND thì nó hiện thông báo sau:

- Command: nd

Chon chu muon chinh.

Select objects: 1 found

1 was filtered out.

Select objects:

Em chọn đối tượng mà không được!

Lisp này em thấy post đã lâu- but giờ em mới dùng đến- em tìm lại bài viết đó mà ko thấy! Em xin post lại đoạn Code cho các bác được rõ: Em xin cam on!

 

(defun c:ND (/ Ename Elist Msg Oldtext Oldlist Newtext Newlist)

(defun ss2ent (ss / sodt index lstent)

(setq

sodt (cond

(ss (sslength ss))

(t 0)

)

index 0

)

(repeat sodt

(setq ent (ssname ss index)

index (1+ index)

lstent (cons ent lstent)

)

)

(reverse lstent)

)

 

(prompt "\nChon chu muon chinh.")

(setq ssEname (ssget '((0 . "TEXT"))))

(if (not ssEname)

(prompt "\nChua chon duoc doi tuong.")

(progn

(prompt "\nChon chu lam chuan.")

(setq lstEname (ss2ent ssEname))

(setq Newtext (car (entsel)))

(setq Newtext (entget Newtext))

(setq Newtext (assoc 1 Newtext))

(setq Newtext (cdr Newtext))

(setq Newlist (cons '1 Newtext))

 

(foreach Ename lstEname

(setq Elist (entget Ename))

(setq Oldlist (assoc 1 Elist))

(setq Oldtext (cdr Oldlist))

(setq Elist (subst Newlist Oldlist Elist))

(entmod Elist)

)

) ; end progn

) ; end if

(princ)

)

[ssg 1.102]

Mọi người cho em hỏi chút- là khi em áp dụng lệnh ND- copy đối tượng và khi paste thì nó đè lên đối tượng (text) khác- em đã appload thành công- gõ lệnh ND thì nó hiện thông báo sau:

- Command: nd

Chon chu muon chinh.

Select objects: 1 found

1 was filtered out.

Select objects:

Em chọn đối tượng mà không được!

Lisp này em thấy post đã lâu- but giờ em mới dùng đến- em tìm lại bài viết đó mà ko thấy! Em xin post lại đoạn Code cho các bác được rõ: Em xin cam on!

 

(defun c:ND (/ Ename Elist Msg Oldtext Oldlist Newtext Newlist)

(defun ss2ent (ss / sodt index lstent)

(setq

sodt (cond

(ss (sslength ss))

(t 0)

)

index 0

)

(repeat sodt

(setq ent (ssname ss index)

index (1+ index)

lstent (cons ent lstent)

)

)

(reverse lstent)

)

 

(prompt "\nChon chu muon chinh.")

(setq ssEname (ssget '((0 . "TEXT"))))

(if (not ssEname)

(prompt "\nChua chon duoc doi tuong.")

(progn

(prompt "\nChon chu lam chuan.")

(setq lstEname (ss2ent ssEname))

(setq Newtext (car (entsel)))

(setq Newtext (entget Newtext))

(setq Newtext (assoc 1 Newtext))

(setq Newtext (cdr Newtext))

(setq Newlist (cons '1 Newtext))

 

(foreach Ename lstEname

(setq Elist (entget Ename))

(setq Oldlist (assoc 1 Elist))

(setq Oldtext (cdr Oldlist))

(setq Elist (subst Newlist Oldlist Elist))

(entmod Elist)

)

) ; end progn

) ; end if

(princ)

)

 

Bạn sửa dòng tô đỏ trên như sau và thử lại:

(setq ssEname (ssget '((0 . "TEXT,MTEXT"))))

[missone's 6]

Bạn sửa dòng tô đỏ trên như sau và thử lại:

(setq ssEname (ssget '((0 . "TEXT,MTEXT"))))

Em đã làm như bác và đã thành công- hehee. Thanks bác nhiều nha!

[smilingman82 2]

Không có mã dxf về chiều dài của line và pline.

 

mã Lisp tính chiều dài line và pline, bạn hãy xem ở đây: http://www.cadviet.com/forum/tinh-tong-chi...uong-t2020.html

thank bác ......bác cho hỏi thêm nhá : bi h mún chỉnh sửa lệnh cuả CAD đc k , các lệnh CAD có lưu trong thư mục nào k, có edit để hiệu chỉnh như một lisp d ko ...cám ơn bác tr nhá ...VD CAD có lệnh line >>>> mình sửa nội dung của lệnh đó được không , cái này m hỏi chỉ để hiểu sâu thêm thôi .thank

[nguyenthuan 0]

xin chào mọi người!

Thấy mấy huynh nói về lisp hay quá nên kẻ hèn này đọc sách mấy hôm nay để học cho biết với mọi người.Ngay từ khi viết thử code này để học hỏi thôi (vì viết theo sách) nhưng cũng không chạy được ,mặc dù mình thấy nó rất bình thường .Không biết hỏi ai để bắt đầu từ những cái sai cơ bản này nên mạo mụi nhờ các huynh chỉ giúp .

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

(defun c:drawline (/pt1 pt2)
 (setq pt1 (getpoint "\nCho diem dau cua line")
pt2 (getpoint pt1 "\nCho diem thu 2 cua line")
)
 (if (and pt1 pt2)
   (command "_.line" pt1 pt2"")
   (princ "\nInvalid or missing points!")
   )
   (princ)
   )

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

không hiểu sao khi chạy nó báo lỗi này

; error: too few arguments

Mong nhận được giải đáp nhanh chóng để có thể tìm hiểu tiếp về cái này.

[nguyenthuan 0]

À quên nhân đây nhờ các huynh chỉ giúp

 (setq pt1 (getpoint "\nCho diem dau cua line")
pt2 (getpoint pt1 "\nCho diem thu 2 cua line")
)

tại sao getpoint hàng trên thì không cần pt1 ,nhưng getpoint hàng tiếp theo lại có pt1 .2 cái này khác nhau như thế nào ạ

[h2c 1]

À quên nhân đây nhờ các huynh chỉ giúp

 (setq pt1 (getpoint "\nCho diem dau cua line")
pt2 (getpoint pt1 "\nCho diem thu 2 cua line")
)

tại sao getpoint hàng trên thì không cần pt1 ,nhưng getpoint hàng tiếp theo lại có pt1 .2 cái này khác nhau như thế nào ạ

Khi có pt1 ở dòng 2 thì cad sẽ có 1 đường nối từ pt1 đến cursor của bạn trong quá trình bạn chọn điểm thứ 2 , cái này để trực quan hơn thôi .

[ssg 1.102]

xin chào mọi người!

Thấy mấy huynh nói về lisp hay quá nên kẻ hèn này đọc sách mấy hôm nay để học cho biết với mọi người.Ngay từ khi viết thử code này để học hỏi thôi (vì viết theo sách) nhưng cũng không chạy được ,mặc dù mình thấy nó rất bình thường .Không biết hỏi ai để bắt đầu từ những cái sai cơ bản này nên mạo mụi nhờ các huynh chỉ giúp .

 

(defun c:drawline (/pt1 pt2)

(setq pt1 (getpoint "\nCho diem dau cua line")

pt2 (getpoint pt1 "\nCho diem thu 2 cua line")

)

(if (and pt1 pt2)

(command "_.line" pt1 pt2"")

(princ "\nInvalid or missing points!")

)

(princ)

)

 

không hiểu sao khi chạy nó báo lỗi này

; error: too few arguments

Mong nhận được giải đáp nhanh chóng để có thể tìm hiểu tiếp về cái này.

Lỗi ở các chỗ màu đỏ. Bạn thiếu 2 dấu cách (space). Góp ý:

1) Bạn mới bắt đầu, hãy tập thói quen thận trọng và chuẩn xác khi coding. Với kiểu lỗi này, khi bạn lập 1 chương trình tương đối dài sẽ không kiểm nổi đâu!

2) Những chỗ ra vô đầu dòng nhất quán theo một quy luật rõ ràng sẽ giúp bạn giảm thiểu nhiều lỗi không đáng có. Ví dụ như sau:

 

(defun c:drawline (/ pt1 pt2)
(setq
   pt1 (getpoint "\nFirst point: ")
   pt2 (getpoint pt1 "\nSecond point: ")
)
(if (and pt1 pt2)
   (command "_.line" pt1 pt2 "")
   (princ "\nInvalid or missing points!")
)
(princ)
)

 

Cái "à quên" của bạn, h2c đã giải đáp chính xác.

[ssg 1.102]

thank bác ......bác cho hỏi thêm nhá : bi h mún chỉnh sửa lệnh cuả CAD đc k , các lệnh CAD có lưu trong thư mục nào k, có edit để hiệu chỉnh như một lisp d ko ...cám ơn bác tr nhá ...VD CAD có lệnh line >>>> mình sửa nội dung của lệnh đó được không , cái này m hỏi chỉ để hiểu sâu thêm thôi .thank

1) Nội dung lệnh CAD nằm trong file acad.exe. Không ai chỉnh sửa được trừ... AutoDesk!

2) Bạn có thể sửa tên lệnh (bằng S::STARTUP) hoặc tên lệnh tắt của CAD (trong file acad.pgp). Tuy nhiên, theo ssg, việc này không khuyến khích vì nó chẳng mang lại lợi ích gì ngoài việc làm rối tung mọi thứ lên!