Chuyển đến nội dung
Diễn đàn CADViet
Đăng nhập để thực hiện theo  
790312

[Yêu cầu] Lisp chỉ đúng khi sử dụng lần đâu

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

Chào các bác, 

E có 1 lisp để vẽ mũi tên hai đầu đoạn thẳng của bác kietxu. Khi đánh lệnh sử dụng lần đầu thì OK, nhưng đánh lệnh lần hai để vẽ đoạn thẳng khác thì nó chỉ vẽ mũi tên cho một đầu đoạn thẳng. Mong các bác sửa lỗi này giúp. Cảm ơn rất nhiều.

(defun c:sq (/ p1 p2 lstPnt)   
  (setq lstPnt '())
  (if (not asize) (setq asize 550))      
  (if (not PThk)  (setq PThk 0))                 
  (defun GETR (val msg / tm)
    (setq tm (getreal (strcat msg " <" (rtos val 2 4) ">: ")))
    (cond ((= (type tm) 'REAL) (eval tm))
          ((= tm nil) (eval val))
          (t (princ "\007 *error* Wrong Input Start Point") (eval val)) ) )
  (defun loop ()
    (cond ((and(setq p2 (getpoint p1 "\nNext Point : "))(setq lstPnt (append (list p2) lstPnt))) (command p2) 
                                     (setq p0 p1) (setq p1 p2) (loop))
          ( t (command "u" (polar p1 (angle p1 p0) asize)
                       "w" (/ asize 3) 0.0 p1 ""))))
  (setq asize (getr asize "\nArrowheads Size :"))
  (setq PThk  (getr PThk "\n PLine Width :"))
  (setq p1 (getpoint "\nStart Point : "))
  (setq lstPnt (append (list p1) lstPnt))
  (command "layer" "m" "S04. REMARK" "c" "6" """")
  (command "pline" p1 "w" 0.0 0.0)
  (setq p2 (getpoint p1 "\nNext Point : "))
  (setq lstPnt (append (list p2) lstPnt))
  (command "w" 0.0 (/ asize 3) (polar p1 (angle p1 p2) asize) 
           "w" PThk PThk p2)
  (setq p1 p2)
  (loop)
(if  (ST:Geo-ListLinear lstPnt)
    (foreach pt (cdr (vl-remove (last lstPnt) lstPnt)) (ST:Entmake-Circle pt 125))
)
  (eval "Done")
)
(defun ST:Geo-Linear ( p1 p2 p3 fuzz)
  (
    (lambda ( a b c )
      (or
        (equal (+ a B) c fuzz)
        (equal (+ b c) a fuzz)
        (equal (+ c a) b fuzz)
      )
    )
    (distance p1 p2) (distance p2 p3) (distance p1 p3)
  )
)
(defun ST:Geo-ListLinear (lst / tmp)
(setq i 2)
(cond ((and (= (length lst) 3)(ST:Geo-Linear(car lst)(cadr lst)(caddr lst) 1e-8))(setq tmp T))
        (T (while (and (< i (1- (length lst)))
                (setq tmp (ST:Geo-Linear (nth 0 lst)(nth 1 lst) (nth (setq i (1+ i)) lst) 1e-8)))
                tmp
            )
        )
)
tmp
)
(defun ST:Entmake-Circle ( Pt Rad )(entmakex (list '(0 . "CIRCLE") (cons 10 pt)(cons 40 Rad))))

 

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

( command "layer" "m" "SO4. Remark" "c" "6" """) có vấn đề.

Bạn thử thay 3 dấu nháy kép """ thành 2 dấu nháy kép "" xem :)))

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
59 phút trước, Danh Cong đã nói:

( command "layer" "m" "SO4. Remark" "c" "6" """) có vấn đề.

Bạn thử thay 3 dấu nháy kép """ thành 2 dấu nháy kép "" xem :)))

Mình thay như bạn nói thì lisp nó k chạy luôn.

(command "layer" "m" "S04. REMARK" "c" "6" "")

 

Lisp gốc trong link bên dưới, bài thứ 12 điếm từ trên xuống cũng bị lỗi như vậy, vẽ vài lần đầu ok, sau khi sử dụng qua lệnh khác rồi quay lại thì nó chỉ vẽ mũi tên tại một đầu. Mong các bác tìm lỗi giúp. Thanks.

 

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
13 phút trước, alisp đã nói:

Lisp gốc xài ok mà, sao lại sửa lung tung để rồi bị lỗi?

Lisp gốc cũng bị lỗi nhé. Thử vẽ xong rồi move, zoom màn hình.... rồi đánh lệnh vẽ lại thì sẽ bị lỗi nhé.

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

 

Vào lúc 12/2/2020 tại 05:55, 790312 đã nói:

Cảm ơn bác đã bỏ thời gian check. Nhưng bác sử dụng lisp này vẽ mũi tên xong, sau đó bác zoom nhỏ hình lại và vẽ đoạn thẳng khác dài hơn thì nó sẽ bị lỗi là chỉ vẽ mũi tên ở một đầu thôi bác ah. E gửi bác lisp e down ở bài 12 từ trên xuống của chính chủ, bác check như e nói xem. Cảm ơn bác nhiều. 

 


;; free lisp from cadviet.com
;; this lisp was downloaded from https://www.cadviet.com/forum/topic/47541-%C4%91%C3%A3-xong-lisp-v%E1%BA%BD-pline-m%C5%A9i-t%C3%AAn-2-%C4%91%E1%BA%A7u/
(defun c:sline (/ loop p1 p2 lstPnt)   
 (grtext -1 "Free from Cadviet.com @Ketxu")
 (setq lstPnt '())
 (if (not asize) (setq asize 1))      
 (if (not PThk)  (setq PThk 0.01))                 
 (defun GETR (val msg / tm)
   (setq tm (getreal (strcat msg " <" (rtos val 2 4) ">: ")))
   (cond ((= (type tm) 'REAL) (eval tm))
         ((= tm nil) (eval val))
         (t (princ "\007 *error* Nh\U+1EADp sai lo\U+1EA1i d\U+1EEF li\U+1EC7u") (eval val)) ) )
 (defun loop ()
   (cond ((and(setq p2 (getpoint p1 "\n\U+0110i\U+1EC3m ti\U+1EBFp theo : "))(setq lstPnt (append (list p2) lstPnt))) (command p2) 
                                    (setq p0 p1) (setq p1 p2) (loop))
         ( t (command "u" (polar p1 (angle p1 p0) asize)
                      "w" (/ asize 3) 0.0 p1 ""))))
 (setq asize (getr asize "\nK\U+00EDch th\U+01B0\U+1EDBc m\U+0169i t\U+00EAn :"))
 (setq PThk  (getr PThk "\n B\U+1EC1 r\U+1ED9ng PLine :"))
 (setq p1 (getpoint "\n\U+0110i\U+1EC3m b\U+1EAFt \U+0111\U+1EA7u : "))
 (setq lstPnt (append (list p1) lstPnt))
 (command "pline" p1 "w" 0.0 0.0)
 (setq p2 (getpoint p1 "\n\U+0110i\U+1EC3m ti\U+1EBFp theo : "))
 (setq lstPnt (append (list p2) lstPnt))
 (command "w" 0.0 (/ asize 3) (polar p1 (angle p1 p2) asize) 
          "w" PThk PThk p2)
 (setq p1 p2)
 (loop)
(if  (ST:Geo-ListLinear lstPnt)
(foreach pt (cdr (vl-remove (last lstPnt) lstPnt)) (ST:Entmake-Circle pt 50))
)
 (eval "Done")
)
(defun ST:Geo-Linear ( p1 p2 p3 fuzz)
 (
   (lambda ( a b c )
     (or
       (equal (+ a B) c fuzz)
       (equal (+ b c) a fuzz)
       (equal (+ c a) b fuzz)
     )
   )
   (distance p1 p2) (distance p2 p3) (distance p1 p3)
 )
)
(defun ST:Geo-ListLinear (lst / tmp)
(setq i 2)
(cond ((and (= (length lst) 3)(ST:Geo-Linear(car lst)(cadr lst)(caddr lst) 1e-8))(setq tmp T))
	(T (while (and (< i (1- (length lst)))
			(setq tmp (ST:Geo-Linear (nth 0 lst)(nth 1 lst) (nth (setq i (1+ i)) lst) 1e-8)))
			tmp
		)
	)
)
tmp
)
(defun ST:Entmake-Circle ( Pt Rad )(entmakex (list '(0 . "CIRCLE") (cons 10 pt)(cons 40 Rad))))

 

Test thử thì thấy có tình trạng như trên

Có lẽ lỗi do bắt điểm nhưng xem code thì không hiểu tại sao. Sửa thế này và test nhiều lần nhưng chưa  thấy lỗi xảy ra

Tìm đến đoạn này và thêm như sau:

( t (command "u" (polar p1 (angle p1 p0) asize)
                      "w" (/ asize 3) 0.0 "none" p1 ""))

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
6 phút trước, ndtnv đã nói:

 

Test thử thì thấy có tình trạng như trên

Có lẽ lỗi do bắt điểm nhưng xem code thì không hiểu tại sao. Sửa thế này và test nhiều lần nhưng chưa  thấy lỗi xảy ra

Tìm đến đoạn này và thêm như sau:

( t (command "u" (polar p1 (angle p1 p0) asize)
                      "w" (/ asize 3) 0.0 "none" p1 ""))

Hi bác ndtnv, Thiep đọc lisp này thấy nó dư ra nhiều đoạn mã so với yêu cầu. Theo tôi, nếu thấy lỗi đoạn này thì có thể bỏ bớt đi đoạn yêu cầu người dùng về chiều dày lwpolyline cũng được.

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Vào lúc 12/2/2020 tại 05:55, 790312 đã nói:

Cảm ơn bác đã bỏ thời gian check. Nhưng bác sử dụng lisp này vẽ mũi tên xong, sau đó bác zoom nhỏ hình lại và vẽ đoạn thẳng khác dài hơn thì nó sẽ bị lỗi là chỉ vẽ mũi tên ở một đầu thôi bác ah. E gửi bác lisp e down ở bài 12 từ trên xuống của chính chủ, bác check như e nói xem. Cảm ơn bác nhiều.


;; free lisp from cadviet.com
;; this lisp was downloaded from https://www.cadviet.com/forum/topic/47541-%C4%91%C3%A3-xong-lisp-v%E1%BA%BD-pline-m%C5%A9i-t%C3%AAn-2-%C4%91%E1%BA%A7u/
(defun c:sline (/ loop p1 p2 lstPnt)   
 (grtext -1 "Free from Cadviet.com @Ketxu")
 (setq lstPnt '())
 (if (not asize) (setq asize 1))      
 (if (not PThk)  (setq PThk 0.01))                 
 (defun GETR (val msg / tm)
   (setq tm (getreal (strcat msg " <" (rtos val 2 4) ">: ")))
   (cond ((= (type tm) 'REAL) (eval tm))
         ((= tm nil) (eval val))
         (t (princ "\007 *error* Nh\U+1EADp sai lo\U+1EA1i d\U+1EEF li\U+1EC7u") (eval val)) ) )
 (defun loop ()
   (cond ((and(setq p2 (getpoint p1 "\n\U+0110i\U+1EC3m ti\U+1EBFp theo : "))(setq lstPnt (append (list p2) lstPnt))) (command p2) 
                                    (setq p0 p1) (setq p1 p2) (loop))
         ( t (command "u" (polar p1 (angle p1 p0) asize)
                      "w" (/ asize 3) 0.0 p1 ""))))
 (setq asize (getr asize "\nK\U+00EDch th\U+01B0\U+1EDBc m\U+0169i t\U+00EAn :"))
 (setq PThk  (getr PThk "\n B\U+1EC1 r\U+1ED9ng PLine :"))
 (setq p1 (getpoint "\n\U+0110i\U+1EC3m b\U+1EAFt \U+0111\U+1EA7u : "))
 (setq lstPnt (append (list p1) lstPnt))
 (command "pline" p1 "w" 0.0 0.0)
 (setq p2 (getpoint p1 "\n\U+0110i\U+1EC3m ti\U+1EBFp theo : "))
 (setq lstPnt (append (list p2) lstPnt))
 (command "w" 0.0 (/ asize 3) (polar p1 (angle p1 p2) asize) 
          "w" PThk PThk p2)
 (setq p1 p2)
 (loop)
(if  (ST:Geo-ListLinear lstPnt)
(foreach pt (cdr (vl-remove (last lstPnt) lstPnt)) (ST:Entmake-Circle pt 50))
)
 (eval "Done")
)
(defun ST:Geo-Linear ( p1 p2 p3 fuzz)
 (
   (lambda ( a b c )
     (or
       (equal (+ a B) c fuzz)
       (equal (+ b c) a fuzz)
       (equal (+ c a) b fuzz)
     )
   )
   (distance p1 p2) (distance p2 p3) (distance p1 p3)
 )
)
(defun ST:Geo-ListLinear (lst / tmp)
(setq i 2)
(cond ((and (= (length lst) 3)(ST:Geo-Linear(car lst)(cadr lst)(caddr lst) 1e-8))(setq tmp T))
	(T (while (and (< i (1- (length lst)))
			(setq tmp (ST:Geo-Linear (nth 0 lst)(nth 1 lst) (nth (setq i (1+ i)) lst) 1e-8)))
			tmp
		)
	)
)
tmp
)
(defun ST:Entmake-Circle ( Pt Rad )(entmakex (list '(0 . "CIRCLE") (cons 10 pt)(cons 40 Rad))))

Đúng là có lúc lisp lỗi thật, đúng như bác NTDNV nói trên. Lỗi thì do anh KetXu chưa xử lý chế độ bắt điểm khi viết lisp thôi.

Tôi sửa thêm 1 số chỗ về bắt điểm nữa, bạn có thể tải về kiểm tra:



;; free lisp from cadviet.com
;; this lisp was downloaded from https://www.cadviet.com/forum/topic/47541-đã-xong-lisp-vẽ-pline-mũi-tên-2-đầu/
(defun c:sline (/ loop p1 p2 lstPnt)   
 (grtext -1 "Free from Cadviet.com @Ketxu")
 (setq lstPnt '())
 (if (not asize) (setq asize 1))      
 (if (not PThk)  (setq PThk 0.01))                 
 (defun GETR (val msg / tm)
   (setq tm (getreal (strcat msg " <" (rtos val 2 4) ">: ")))
   (cond ((= (type tm) 'REAL) (eval tm))
         ((= tm nil) (eval val))
         (t (princ "\007 *error* Nh\U+1EADp sai lo\U+1EA1i d\U+1EEF li\U+1EC7u") (eval val)) ) )
 (defun loop ()
   (cond ((and(setq p2 (getpoint p1 "\n\U+0110i\U+1EC3m ti\U+1EBFp theo : "))(setq lstPnt (append (list p2) lstPnt))) (command "non" p2) 
                                    (setq p0 p1) (setq p1 p2) (loop))
         ( t (command "u" (polar p1 (angle p1 p0) asize)
                      "w" (/ asize 3) 0.0 "non" p1 ""))))
 (setq asize (getr asize "\nK\U+00EDch th\U+01B0\U+1EDBc m\U+0169i t\U+00EAn :"))
 (setq PThk  (getr PThk "\n B\U+1EC1 r\U+1ED9ng PLine :"))
 (setq p1 (getpoint "\n\U+0110i\U+1EC3m b\U+1EAFt \U+0111\U+1EA7u : "))
 (setq lstPnt (append (list p1) lstPnt))
 (command "pline" "non" p1 "w" 0.0 0.0)
 (setq p2 (getpoint p1 "\n\U+0110i\U+1EC3m ti\U+1EBFp theo : "))
 (setq lstPnt (append (list p2) lstPnt))
 (command "w" 0.0 (/ asize 3) (polar p1 (angle p1 p2) asize) 
          "w" PThk PThk "non" p2)
 (setq p1 p2)
 (loop)
(if  (ST:Geo-ListLinear lstPnt)
(foreach pt (cdr (vl-remove (last lstPnt) lstPnt)) (ST:Entmake-Circle pt 50))
)
 (eval "Done")
)
(defun ST:Geo-Linear ( p1 p2 p3 fuzz)
 (
   (lambda ( a b c )
     (or
       (equal (+ a B) c fuzz)
       (equal (+ b c) a fuzz)
       (equal (+ c a) b fuzz)
     )
   )
   (distance p1 p2) (distance p2 p3) (distance p1 p3)
 )
)
(defun ST:Geo-ListLinear (lst / tmp)
(setq i 2)
(cond ((and (= (length lst) 3)(ST:Geo-Linear(car lst)(cadr lst)(caddr lst) 1e-8))(setq tmp T))
    (T (while (and (< i (1- (length lst)))
            (setq tmp (ST:Geo-Linear (nth 0 lst)(nth 1 lst) (nth (setq i (1+ i)) lst) 1e-8)))
            tmp
        )
    )
)
tmp
)
(defun ST:Entmake-Circle ( Pt Rad )(entmakex (list '(0 . "CIRCLE") (cons 10 pt)(cons 40 Rad))))v

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
9 giờ trước, Danh Cong đã nói:

Đúng là có lúc lisp lỗi thật, đúng như bác NTDNV nói trên. Lỗi thì do anh KetXu chưa xử lý chế độ bắt điểm khi viết lisp thôi.

Tôi sửa thêm 1 số chỗ về bắt điểm nữa, bạn có thể tải về kiểm tra:

 





;; free lisp from cadviet.com
;; this lisp was downloaded from https://www.cadviet.com/forum/topic/47541-đã-xong-lisp-vẽ-pline-mũi-tên-2-đầu/
	(defun c:sline (/ loop p1 p2 lstPnt)   
	 (grtext -1 "Free from Cadviet.com @Ketxu")
	 (setq lstPnt '())
	 (if (not asize) (setq asize 1))      
	 (if (not PThk)  (setq PThk 0.01))                 
	 (defun GETR (val msg / tm)
	   (setq tm (getreal (strcat msg " <" (rtos val 2 4) ">: ")))
	   (cond ((= (type tm) 'REAL) (eval tm))
	         ((= tm nil) (eval val))
	         (t (princ "\007 *error* Nh\U+1EADp sai lo\U+1EA1i d\U+1EEF li\U+1EC7u") (eval val)) ) )
	 (defun loop ()
	   (cond ((and(setq p2 (getpoint p1 "\n\U+0110i\U+1EC3m ti\U+1EBFp theo : "))(setq lstPnt (append (list p2) lstPnt))) (command "non" p2) 
	                                    (setq p0 p1) (setq p1 p2) (loop))
	         ( t (command "u" (polar p1 (angle p1 p0) asize)
	                      "w" (/ asize 3) 0.0 "non" p1 ""))))
	 (setq asize (getr asize "\nK\U+00EDch th\U+01B0\U+1EDBc m\U+0169i t\U+00EAn :"))
	 (setq PThk  (getr PThk "\n B\U+1EC1 r\U+1ED9ng PLine :"))
	 (setq p1 (getpoint "\n\U+0110i\U+1EC3m b\U+1EAFt \U+0111\U+1EA7u : "))
	 (setq lstPnt (append (list p1) lstPnt))
	 (command "pline" "non" p1 "w" 0.0 0.0)
	 (setq p2 (getpoint p1 "\n\U+0110i\U+1EC3m ti\U+1EBFp theo : "))
	 (setq lstPnt (append (list p2) lstPnt))
	 (command "w" 0.0 (/ asize 3) (polar p1 (angle p1 p2) asize) 
	          "w" PThk PThk "non" p2)
	 (setq p1 p2)
	 (loop)
	(if  (ST:Geo-ListLinear lstPnt)
	(foreach pt (cdr (vl-remove (last lstPnt) lstPnt)) (ST:Entmake-Circle pt 50))
	)
	 (eval "Done")
	)
	(defun ST:Geo-Linear ( p1 p2 p3 fuzz)
	 (
	   (lambda ( a b c )
	     (or
	       (equal (+ a B) c fuzz)
	       (equal (+ b c) a fuzz)
	       (equal (+ c a) b fuzz)
	     )
	   )
	   (distance p1 p2) (distance p2 p3) (distance p1 p3)
	 )
	)
	(defun ST:Geo-ListLinear (lst / tmp)
	(setq i 2)
	(cond ((and (= (length lst) 3)(ST:Geo-Linear(car lst)(cadr lst)(caddr lst) 1e-8))(setq tmp T))
	    (T (while (and (< i (1- (length lst)))
	            (setq tmp (ST:Geo-Linear (nth 0 lst)(nth 1 lst) (nth (setq i (1+ i)) lst) 1e-8)))
	            tmp
	        )
	    )
	)
	tmp
	)
	(defun ST:Entmake-Circle ( Pt Rad )(entmakex (list '(0 . "CIRCLE") (cons 10 pt)(cons 40 Rad))))v

Cảm ơn bác nhiều. Lisp chạy ok, nhưng nếu để nó là một file thì OK, còn nếu mình đưa nó vào chung file với một lisp khác thì nó k chạy. Mong các bác bỏ tí thời gian check giùm mình với.

;; ===========SAP XEP DIM CACH DEU NHAU==============================

(defun c:sd ()
  (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)
  )
  (defun hoanh_newerror	(msg)
    (if	(and (/= msg "Function cancelled")
	     (/= msg "quit / exit abort")
	)
      (princ (strcat "\n" msg))
    )
    (done)
  )
  ;;----------
  (defun init ()
    (setq
      HOANH_CMD	     (getvar "CMDECHO")
      HOANH_OLDERROR *error*
      *error*	     hoanh_newerror

    )
    (setvar "CMDECHO" 0)
    (command ".undo" "BE")
  )
  ;;----------
  (defun done ()
    (command ".redraw")
    (command ".undo" "E")
    (if	HOANH_CMD
      (setvar "CMDECHO" HOANH_CMD)
    )
    (if	HOANH_OLDERROR
      (setq *error* HOANH_OLDERROR)
    )
    (princ)
  )
  ;;----------

  (defun cdim (entdt	pchan	 pduong	  /	   tt	    old10
	       old13	old14	 new10	  new13	   new14    p10n
	       p13n	p14n	 p10o	  p13o	   p14o	    gocduong
	       gocchan	pchanb	 pduongb  loaidim
	      )
    (defun chanvuonggoc	(ph p1 p2 / ptemp pkq goc)
      (setq
	goc   (+ (angle p1 p2) (/ pi 2.0))
	ptemp (polar ph goc 1000.0)
	pkq   (inters ph ptemp p1 p2 nil)
      )
      pkq
    )
    (setq
      tt       (entget entdt)
      old10    (assoc '10 tt)
      old13    (assoc '13 tt)
      old14    (assoc '14 tt)
      p10o     (cdr old10)
      p13o     (cdr old13)
      p14o     (cdr old14)
      loaidim  (logand (cdr (assoc '70 tt)) 7)
      gocduong (cond
		 ((= loaidim 1) (angle p13o p14o))
		 ((= loaidim 0) (cdr (assoc '50 tt)))
		 (t nil)
	       )
      pchan    (cond
		 (pchan (list (car pchan) (cadr pchan) 0.0))
		 (t pchan)
	       )
      pduong   (cond
		 (pduong (list (car pduong) (cadr pduong) 0.0))
		 (t pduong)
	       )

    )
    (if	gocduong
      (progn
	(if pchan
	  (setq
	    pchanb (polar pchan gocduong 1000.0)
	    p13n   (chanvuonggoc
		     (list (car p13o) (cadr p13o) 0.0)
		     pchan
		     pchanb
		   )
	    p14n   (chanvuonggoc
		     (list (car p14o) (cadr p14o) 0.0)
		     pchan
		     pchanb
		   )
	    new13  (cons 13 p13n)
	    new14  (cons 14 p14n)
	    tt	   (subst new13 old13 tt)
	    tt	   (subst new14 old14 tt)
	  )
	)
	(if pduong
	  (setq
	    pduongb (polar pduong gocduong 1000.0)
	    p10n    (chanvuonggoc
		      (list (car p10o) (cadr p10o) 0.0)
		      pduong
		      pduongb
		    )
	    new10   (cons 10 p10n)
	    tt	    (subst new10 old10 tt)
	  )
	)
	(entmod tt)
      )
    )
    gocduong
  )

  (defun textdimheight (ent / tmp)
    (command ".copy" ent "" (list 0.0 0.0 0.0) "@")
    (command ".explode" (entlast) "")
    (setq tmp (cdr (assoc 40 (entget (entlast)))))
    (command ".erase" "p" "")
    tmp
  )
  (defun phia (p1 p2 p3 / x1 y1 z1 x2 y2 z2 x3 y3 z3)
    (setq
      x1  (car p1)
      y1  (cadr p1)
      z1  (caddr p1)
      x2  (car p2)
      y2  (cadr p2)
      z2  (caddr p2)
      x3  (car p3)
      y3  (cadr p3)
      z3  (caddr p3)
      tmp (+ (* (- x1 x2) x3)
	     (* (- y1 y2) y3)
	     (* (- z1 z2) z3)
	  )
    )
    (cond
      ((= tmp 0.0) 0.0)
      (t (/ tmp (abs tmp)))
    )
  )
  (defun khoangcachdim (p1 ent goc / tt p2 A B D)
    (setq tt (entget ent)
	  p2 (cdr (assoc 10 tt))
	  B  (cdr (assoc 50 tt))
	  A  (angle p1 p2)
	  D  (distance p1 p2)
    )
    (* (* D (sin (- A B))) (phia p1 (polar p1 goc 1.0) p2))
  )

  (defun phanloai (ent)
    (setq
      kc   (khoangcachdim pgoc ent goc)
      loai (fix (/ kc heightdimgoc 0.93))
    )
    (cons loai ent)
  )

  (init)
  (princ "\nSap xep dim © CADViet.com")
  (while (not (setq entgoc (car (entsel "\nSelect orginal dimension: "))))
  )
  (setq
    ttgoc	 (entget entgoc)
    p13goc	 (cdr (assoc 13 ttgoc))
    pgoc	 (cdr (assoc 10 ttgoc))
    goc		 (cdr (assoc 50 ttgoc))
    heightdimgoc (textdimheight entgoc)
    ssd		 (ssget	(list
			  (cons 0 "DIMENSION")
			  (cons -4 "<OR")
			  (cons 70 32)
			  (cons 70 64)
			  (cons 70 96)
			  (cons 70 128)
			  (cons 70 160)
			  (cons 70 196)
			  (cons 70 224)
			  (cons -4 "OR>")
			  (cons -4 "<OR")
			  (cons 50 goc)
			  (cons 50 (+ goc pi))
			  (cons 50 (- goc pi))
			  (cons -4 "OR>")
			)
		 )
    lstd	 (ss2ent ssd)
    lstd	 (mapcar 'phanloai lstd)
    lstlevel	 nil
  )
  (foreach pp lstd
    (if	(not (member (car pp) lstlevel))
      (setq lstlevel (append lstlevel (list (car pp))))
    )
  )
  (setq	lstlevel    (vl-sort lstlevel '(lambda (x1 x2) (< x1 x2)))
	lstam	    nil
	lstduong    nil
	lstamtmp    nil
	lstduongtmp nil
  )
  (foreach pp lstlevel
    (if	(< pp 0.0)
      (setq lstam (append lstam (list pp)))
    )
    (if	(> pp 0.0)
      (setq lstduong (append lstduong (list pp)))
    )
  )
  (setq index 0)
  (foreach pp (reverse lstam)
    (setq
      index    (1+ index)
      lstamtmp (append lstamtmp (list (cons pp index)))
    )
  )
  (setq
    lstam lstamtmp
    index 0
  )
  (foreach pp lstduong
    (setq
      index	  (1+ index)
      lstduongtmp (append lstduongtmp (list (cons pp index)))
    )
  )
  (setq lstduong lstduongtmp)
  (setq lstlevel (append lstduong lstam (list (cons 0.0 0))))

  (setq kcdimstandard (* 2.8 heightdimgoc))
  (foreach pp lstd
    (setq plht (car pp))
    (progn
      (setq
	kcdimht	   (khoangcachdim pgoc (cdr pp) goc)
	duongthu   (cdr (assoc plht lstlevel))
	heso	   (cond
		     ((/= 0 kcdimht)
		      (abs (* (/ kcdimstandard kcdimht) duongthu))
		     )
		     (t 0.0)
		   )
	diemchenht (cdr (assoc 10 (entget (cdr pp))))
	pmoi	   (polar pgoc
			  (angle pgoc diemchenht)
			  (* heso (distance pgoc diemchenht))
		   )
      )

      (cdim (cdr pp) p13goc pmoi)
    )
  )
  (done)
)
(princ)
)

;; free lisp from cadviet.com
;; this lisp was downloaded from https://www.cadviet.com/forum/topic/47541-đã-xong-lisp-vẽ-pline-mũi-tên-2-đầu/
	(defun c:sline (/ loop p1 p2 lstPnt)   
	 (grtext -1 "Free from Cadviet.com @Ketxu")
	 (setq lstPnt '())
	 (if (not asize) (setq asize 1))      
	 (if (not PThk)  (setq PThk 0.01))                 
	 (defun GETR (val msg / tm)
	   (setq tm (getreal (strcat msg " <" (rtos val 2 4) ">: ")))
	   (cond ((= (type tm) 'REAL) (eval tm))
	         ((= tm nil) (eval val))
	         (t (princ "\007 *error* Nh\U+1EADp sai lo\U+1EA1i d\U+1EEF li\U+1EC7u") (eval val)) ) )
	 (defun loop ()
	   (cond ((and(setq p2 (getpoint p1 "\n\U+0110i\U+1EC3m ti\U+1EBFp theo : "))(setq lstPnt (append (list p2) lstPnt))) (command "non" p2) 
	                                    (setq p0 p1) (setq p1 p2) (loop))
	         ( t (command "u" (polar p1 (angle p1 p0) asize)
	                      "w" (/ asize 3) 0.0 "non" p1 ""))))
	 (setq asize (getr asize "\nK\U+00EDch th\U+01B0\U+1EDBc m\U+0169i t\U+00EAn :"))
	 (setq PThk  (getr PThk "\n B\U+1EC1 r\U+1ED9ng PLine :"))
	 (setq p1 (getpoint "\n\U+0110i\U+1EC3m b\U+1EAFt \U+0111\U+1EA7u : "))
	 (setq lstPnt (append (list p1) lstPnt))
	 (command "pline" "non" p1 "w" 0.0 0.0)
	 (setq p2 (getpoint p1 "\n\U+0110i\U+1EC3m ti\U+1EBFp theo : "))
	 (setq lstPnt (append (list p2) lstPnt))
	 (command "w" 0.0 (/ asize 3) (polar p1 (angle p1 p2) asize) 
	          "w" PThk PThk "non" p2)
	 (setq p1 p2)
	 (loop)
	(if  (ST:Geo-ListLinear lstPnt)
	(foreach pt (cdr (vl-remove (last lstPnt) lstPnt)) (ST:Entmake-Circle pt 50))
	)
	 (eval "Done")
	)
	(defun ST:Geo-Linear ( p1 p2 p3 fuzz)
	 (
	   (lambda ( a b c )
	     (or
	       (equal (+ a B) c fuzz)
	       (equal (+ b c) a fuzz)
	       (equal (+ c a) b fuzz)
	     )
	   )
	   (distance p1 p2) (distance p2 p3) (distance p1 p3)
	 )
	)
	(defun ST:Geo-ListLinear (lst / tmp)
	(setq i 2)
	(cond ((and (= (length lst) 3)(ST:Geo-Linear(car lst)(cadr lst)(caddr lst) 1e-8))(setq tmp T))
	    (T (while (and (< i (1- (length lst)))
	            (setq tmp (ST:Geo-Linear (nth 0 lst)(nth 1 lst) (nth (setq i (1+ i)) lst) 1e-8)))
	            tmp
	        )
	    )
	)
	tmp
	)
	(defun ST:Entmake-Circle ( Pt Rad )(entmakex (list '(0 . "CIRCLE") (cons 10 pt)(cons 40 Rad))))

 

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
11 giờ trước, 790312 đã nói:

Cảm ơn bác nhiều. Lisp chạy ok, nhưng nếu để nó là một file thì OK, còn nếu mình đưa nó vào chung file với một lisp khác thì nó k chạy. Mong các bác bỏ tí thời gian check giùm mình với.


;; ===========SAP XEP DIM CACH DEU NHAU==============================

(defun c:sd ()
  (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)
  )
  (defun hoanh_newerror	(msg)
    (if	(and (/= msg "Function cancelled")
	     (/= msg "quit / exit abort")
	)
      (princ (strcat "\n" msg))
    )
    (done)
  )
  ;;----------
  (defun init ()
    (setq
      HOANH_CMD	     (getvar "CMDECHO")
      HOANH_OLDERROR *error*
      *error*	     hoanh_newerror

    )
    (setvar "CMDECHO" 0)
    (command ".undo" "BE")
  )
  ;;----------
  (defun done ()
    (command ".redraw")
    (command ".undo" "E")
    (if	HOANH_CMD
      (setvar "CMDECHO" HOANH_CMD)
    )
    (if	HOANH_OLDERROR
      (setq *error* HOANH_OLDERROR)
    )
    (princ)
  )
  ;;----------

  (defun cdim (entdt	pchan	 pduong	  /	   tt	    old10
	       old13	old14	 new10	  new13	   new14    p10n
	       p13n	p14n	 p10o	  p13o	   p14o	    gocduong
	       gocchan	pchanb	 pduongb  loaidim
	      )
    (defun chanvuonggoc	(ph p1 p2 / ptemp pkq goc)
      (setq
	goc   (+ (angle p1 p2) (/ pi 2.0))
	ptemp (polar ph goc 1000.0)
	pkq   (inters ph ptemp p1 p2 nil)
      )
      pkq
    )
    (setq
      tt       (entget entdt)
      old10    (assoc '10 tt)
      old13    (assoc '13 tt)
      old14    (assoc '14 tt)
      p10o     (cdr old10)
      p13o     (cdr old13)
      p14o     (cdr old14)
      loaidim  (logand (cdr (assoc '70 tt)) 7)
      gocduong (cond
		 ((= loaidim 1) (angle p13o p14o))
		 ((= loaidim 0) (cdr (assoc '50 tt)))
		 (t nil)
	       )
      pchan    (cond
		 (pchan (list (car pchan) (cadr pchan) 0.0))
		 (t pchan)
	       )
      pduong   (cond
		 (pduong (list (car pduong) (cadr pduong) 0.0))
		 (t pduong)
	       )

    )
    (if	gocduong
      (progn
	(if pchan
	  (setq
	    pchanb (polar pchan gocduong 1000.0)
	    p13n   (chanvuonggoc
		     (list (car p13o) (cadr p13o) 0.0)
		     pchan
		     pchanb
		   )
	    p14n   (chanvuonggoc
		     (list (car p14o) (cadr p14o) 0.0)
		     pchan
		     pchanb
		   )
	    new13  (cons 13 p13n)
	    new14  (cons 14 p14n)
	    tt	   (subst new13 old13 tt)
	    tt	   (subst new14 old14 tt)
	  )
	)
	(if pduong
	  (setq
	    pduongb (polar pduong gocduong 1000.0)
	    p10n    (chanvuonggoc
		      (list (car p10o) (cadr p10o) 0.0)
		      pduong
		      pduongb
		    )
	    new10   (cons 10 p10n)
	    tt	    (subst new10 old10 tt)
	  )
	)
	(entmod tt)
      )
    )
    gocduong
  )

  (defun textdimheight (ent / tmp)
    (command ".copy" ent "" (list 0.0 0.0 0.0) "@")
    (command ".explode" (entlast) "")
    (setq tmp (cdr (assoc 40 (entget (entlast)))))
    (command ".erase" "p" "")
    tmp
  )
  (defun phia (p1 p2 p3 / x1 y1 z1 x2 y2 z2 x3 y3 z3)
    (setq
      x1  (car p1)
      y1  (cadr p1)
      z1  (caddr p1)
      x2  (car p2)
      y2  (cadr p2)
      z2  (caddr p2)
      x3  (car p3)
      y3  (cadr p3)
      z3  (caddr p3)
      tmp (+ (* (- x1 x2) x3)
	     (* (- y1 y2) y3)
	     (* (- z1 z2) z3)
	  )
    )
    (cond
      ((= tmp 0.0) 0.0)
      (t (/ tmp (abs tmp)))
    )
  )
  (defun khoangcachdim (p1 ent goc / tt p2 A B D)
    (setq tt (entget ent)
	  p2 (cdr (assoc 10 tt))
	  B  (cdr (assoc 50 tt))
	  A  (angle p1 p2)
	  D  (distance p1 p2)
    )
    (* (* D (sin (- A B))) (phia p1 (polar p1 goc 1.0) p2))
  )

  (defun phanloai (ent)
    (setq
      kc   (khoangcachdim pgoc ent goc)
      loai (fix (/ kc heightdimgoc 0.93))
    )
    (cons loai ent)
  )

  (init)
  (princ "\nSap xep dim © CADViet.com")
  (while (not (setq entgoc (car (entsel "\nSelect orginal dimension: "))))
  )
  (setq
    ttgoc	 (entget entgoc)
    p13goc	 (cdr (assoc 13 ttgoc))
    pgoc	 (cdr (assoc 10 ttgoc))
    goc		 (cdr (assoc 50 ttgoc))
    heightdimgoc (textdimheight entgoc)
    ssd		 (ssget	(list
			  (cons 0 "DIMENSION")
			  (cons -4 "<OR")
			  (cons 70 32)
			  (cons 70 64)
			  (cons 70 96)
			  (cons 70 128)
			  (cons 70 160)
			  (cons 70 196)
			  (cons 70 224)
			  (cons -4 "OR>")
			  (cons -4 "<OR")
			  (cons 50 goc)
			  (cons 50 (+ goc pi))
			  (cons 50 (- goc pi))
			  (cons -4 "OR>")
			)
		 )
    lstd	 (ss2ent ssd)
    lstd	 (mapcar 'phanloai lstd)
    lstlevel	 nil
  )
  (foreach pp lstd
    (if	(not (member (car pp) lstlevel))
      (setq lstlevel (append lstlevel (list (car pp))))
    )
  )
  (setq	lstlevel    (vl-sort lstlevel '(lambda (x1 x2) (< x1 x2)))
	lstam	    nil
	lstduong    nil
	lstamtmp    nil
	lstduongtmp nil
  )
  (foreach pp lstlevel
    (if	(< pp 0.0)
      (setq lstam (append lstam (list pp)))
    )
    (if	(> pp 0.0)
      (setq lstduong (append lstduong (list pp)))
    )
  )
  (setq index 0)
  (foreach pp (reverse lstam)
    (setq
      index    (1+ index)
      lstamtmp (append lstamtmp (list (cons pp index)))
    )
  )
  (setq
    lstam lstamtmp
    index 0
  )
  (foreach pp lstduong
    (setq
      index	  (1+ index)
      lstduongtmp (append lstduongtmp (list (cons pp index)))
    )
  )
  (setq lstduong lstduongtmp)
  (setq lstlevel (append lstduong lstam (list (cons 0.0 0))))

  (setq kcdimstandard (* 2.8 heightdimgoc))
  (foreach pp lstd
    (setq plht (car pp))
    (progn
      (setq
	kcdimht	   (khoangcachdim pgoc (cdr pp) goc)
	duongthu   (cdr (assoc plht lstlevel))
	heso	   (cond
		     ((/= 0 kcdimht)
		      (abs (* (/ kcdimstandard kcdimht) duongthu))
		     )
		     (t 0.0)
		   )
	diemchenht (cdr (assoc 10 (entget (cdr pp))))
	pmoi	   (polar pgoc
			  (angle pgoc diemchenht)
			  (* heso (distance pgoc diemchenht))
		   )
      )

      (cdim (cdr pp) p13goc pmoi)
    )
  )
  (done)
)
(princ)
)

;; free lisp from cadviet.com
; this lisp was downloaded from https://www.cadviet.com/forum/topic/47541-đã-xong-lisp-vẽ-pline-mũi-tên-2-đầu/
	(defun c:sline (/ loop p1 p2 lstPnt)   
	 (grtext -1 "Free from Cadviet.com @Ketxu")
	 (setq lstPnt '())
	 (if (not asize) (setq asize 1))      
	 (if (not PThk)  (setq PThk 0.01))                 
	 (defun GETR (val msg / tm)
	   (setq tm (getreal (strcat msg " <" (rtos val 2 4) ">: ")))
	   (cond ((= (type tm) 'REAL) (eval tm))
	         ((= tm nil) (eval val))
	         (t (princ "\007 *error* Nh\U+1EADp sai lo\U+1EA1i d\U+1EEF li\U+1EC7u") (eval val)) ) )
	 (defun loop ()
	   (cond ((and(setq p2 (getpoint p1 "\n\U+0110i\U+1EC3m ti\U+1EBFp theo : "))(setq lstPnt (append (list p2) lstPnt))) (command "non" p2) 
	                                    (setq p0 p1) (setq p1 p2) (loop))
	         ( t (command "u" (polar p1 (angle p1 p0) asize)
	                      "w" (/ asize 3) 0.0 "non" p1 ""))))
	 (setq asize (getr asize "\nK\U+00EDch th\U+01B0\U+1EDBc m\U+0169i t\U+00EAn :"))
	 (setq PThk  (getr PThk "\n B\U+1EC1 r\U+1ED9ng PLine :"))
	 (setq p1 (getpoint "\n\U+0110i\U+1EC3m b\U+1EAFt \U+0111\U+1EA7u : "))
	 (setq lstPnt (append (list p1) lstPnt))
	 (command "pline" "non" p1 "w" 0.0 0.0)
	 (setq p2 (getpoint p1 "\n\U+0110i\U+1EC3m ti\U+1EBFp theo : "))
	 (setq lstPnt (append (list p2) lstPnt))
	 (command "w" 0.0 (/ asize 3) (polar p1 (angle p1 p2) asize) 
	          "w" PThk PThk "non" p2)
	 (setq p1 p2)
	 (loop)
	(if  (ST:Geo-ListLinear lstPnt)
	(foreach pt (cdr (vl-remove (last lstPnt) lstPnt)) (ST:Entmake-Circle pt 50))
	)
	 (eval "Done")
	)
	(defun ST:Geo-Linear ( p1 p2 p3 fuzz)
	 (
	   (lambda ( a b c )
	     (or
	       (equal (+ a B) c fuzz)
	       (equal (+ b c) a fuzz)
	       (equal (+ c a) b fuzz)
	     )
	   )
	   (distance p1 p2) (distance p2 p3) (distance p1 p3)
	 )
	)
	(defun ST:Geo-ListLinear (lst / tmp)
	(setq i 2)
	(cond ((and (= (length lst) 3)(ST:Geo-Linear(car lst)(cadr lst)(caddr lst) 1e-8))(setq tmp T))
	    (T (while (and (< i (1- (length lst)))
	            (setq tmp (ST:Geo-Linear (nth 0 lst)(nth 1 lst) (nth (setq i (1+ i)) lst) 1e-8)))
	            tmp
	        )
	    )
	)
	tmp
	)
	(defun ST:Entmake-Circle ( Pt Rad )(entmakex (list '(0 . "CIRCLE") (cons 10 pt)(cons 40 Rad))))

Lisp SD lỗi.

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Một hướng khác tạo Lwpolyline có 2 mũi tên ở 2 đầu, không dùng "command":

Quote

;====LISP TAO LWPOLYLINE CO 2 MUI TEN O 2 DÂU===================================|;
(defun arrpoint    (po / PntArr x y)
  (setq    PntArr (vlax-make-safearray
         vlax-vbDouble
         (cons 0 1)
           )
  )
  (vlax-safearray-fill PntArr po)
)
(defun GETR (val msg / tm)
    (setq tm (getreal (strcat msg " <" (rtos val 2 4) ">: ")))
    (cond ((= (type tm) 'REAL) (eval tm))
          ((= tm nil) (eval val))
          (t
           (princ "\007 *error* Nh\U+1EADp sai lo\U+1EA1i d\U+1EEF li\U+1EC7u")
           (eval val)
          )
    )
)
(defun C:cwp (/ Lpo p1 p2 color obj  entCUR Lencur n pn doan)
    (setq Lpo nil
          n   0
    )
    (setq color (getvar 'CECOLOR))
    (if (eq color "BYCOLOR")
        (setq color 256)
        (setq color (atoi color))
    )
    (setq p1 (getpoint "\nStart Point : "))
    (setq Lpo (append Lpo (LIST p1)))
    (while (setq p2 (getpoint p1 "\nNext Point : "))
        (setq Lpo (append Lpo (LIST p2)))
        (GRDRAW p1 p2 color 2)
        (setq p1 p2
              n  (1+ n)
        )
    )
    (ACET-LWPLINE-MAKE (list Lpo))
    (setq entCUR (entlast))
    (setq obj (vlax-ename->vla-object entCUR))
    
    
    (if (null warrow)
        (setq warrow 20)
    )
    (setq warrow  
          (getr warrow "\nArrowheads Size :")
    )
    (setq dis (* 2 warrow))
    (setq po1 (nth 0 Lpo)
          po2 (nth 1 Lpo)
          po3 (nth (- n 1) Lpo)
          po4 p1
    )
    (setq dis1 (distance po1 po2)
          dis2 (distance po3 po4))
    (setq Lencur (vlax-curve-getDistAtPoint entCUR po4))
    (If (<= dis dis1)
        (progn (setq po (vlax-curve-getPointAtDist obj dis))
               (setq po (list (car po) (cadr po)))
               (vla-AddVertex obj 1 (arrpoint po))
               (vla-setWidth obj 0 0 warrow)      ;SetWidth SegmentIndex, StartWidth, EndWidth
        )
        (alert "\n\U+0110o\U+1EA1n th\U+1EE9 1 c\U+1EE7a Lwpolyline quá ng\U+1EAFn so v\U+1EDBi kích th\U+01B0\U+1EDBc arrow")
    )
    (setq doan (1+ n))
    (If (<= dis dis2)
        (progn (setq dis (- Lencur dis))
               (setq po (vlax-curve-getPointAtDist obj dis))
               (setq po (list (car po) (cadr po)))
               (vla-AddVertex obj doan (arrpoint po))
               (vla-setWidth obj doan warrow 0)
        )
        (alert
            (strcat
                "\n\U+0110o\U+1EA1n th\U+1EE9 "
                (itoa doan)
                " c\U+1EE7a Lwpolyline quá ng\U+1EAFn so v\U+1EDBi kích th\U+01B0\U+1EDBc arrow"
            )
        )
    )
    (redraw)
    (princ)
)

 

arrow_LWP(CWP).LSP

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Vào lúc 15/2/2020 tại 11:54, Danh Cong đã nói:

Lisp SD lỗi.

Lỗi có thể là do trùng biến đó.

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Tạo một tài khoản hoặc đăng nhập để nhận xét

Bạn cần phải là một thành viên để lại một bình luận

Tạo tài khoản

Đăng ký một tài khoản mới trong cộng đồng của chúng tôi. Điều đó dễ mà.

Đăng ký tài khoản mới

Đăng nhập

Bạn có sẵn sàng để tạo một tài khoản ? Đăng nhập tại đây.

Đăng nhập ngay
Đăng nhập để thực hiện theo  

×