Chuyển đến nội dung
Diễn đàn CADViet
Duong Nhat Duy

Chia sẻ một số hàm con hữu ích

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

Chào cả nhà,

Mình có sưu tầm được một số các hàm con hữu ích từ khá nhiều nguồn: của bác Lee Mac, AfraLisp, Forum của Autodesk, ...

Mình muốn chia sẻ cho các bạn newbie mình, bên cạnh đó cũng mong muốn các bạn đã có nhiều kinh nghiệm về Lisp góp ý.

Hàm thì mình đã chú thích ở trên đầu rồi, muốn rõ hơn các bạn để ý thêm phần tên tham số là hiểu ngay hàm đó làm cái gì.

Chúc các bạn một ngày tốt lành !

;---------- ATTRIBUTE ----------;

;THONG KE ATT
(defun att_get (ent)
  (if ent
    (mapcar '(lambda (att) (cons (vla-get-tagstring att) (vla-get-textstring att)))
	    (vlax-invoke (vlax-ename->vla-object ent) 'getattributes)
	    )
    )
  )

;EDIT ATT THEO TAG
(defun att_set (ent tag val)
  (setq tag (strcase tag))
  (vl-some
    '(lambda (att)
       (if (= tag (strcase (vla-get-tagstring att)))
	 (progn (vla-put-textstring att val) val)
	 )
       )
    (vlax-invoke (vlax-ename->vla-object ent) 'getattributes)
    )
  )

;EDIT ATT THEO LIST
(defun att_lst (ent lst / itm)
  (foreach att (vlax-invoke (vlax-ename->vla-object ent) 'getattributes)
    (if (setq itm (assoc (vla-get-tagstring att) lst))
      (vla-put-textstring att (cdr itm))
      )
    )
  )

;---------- ATTRIBUTE ----------;

;-----

;---------- DYNAMIC ----------;

;THONG KE DYN
(defun dyn_get (ent)
  (mapcar '(lambda (dyn) (cons (vla-get-propertyname dyn) (vlax-get dyn 'value)))
	  (vlax-invoke (vlax-ename->vla-object ent) 'getdynamicblockproperties)
	  )
  )

;EDIT DYN THEO PROPERTIES
(defun dyn_set (ent prp val)
  (setq prp (strcase prp))
  (vl-some
    '(lambda ( x )
       (if (= prp (strcase (vla-get-propertyname x)))
	 (progn
	   (vla-put-value x (vlax-make-variant val (vlax-variant-type (vla-get-value x))))
	   (cond (val) (t))
	   )
	 )
       )
    (vlax-invoke (vlax-ename->vla-object ent) 'getdynamicblockproperties)
    )
  )

;EDIT DYN THEO LIST
(defun dyn_lst (ent lst / itm)
  (setq lst (mapcar '(lambda (x) (cons (strcase (car x)) (cdr x))) lst))
  (foreach x (vlax-invoke (vlax-ename->vla-object ent) 'getdynamicblockproperties)
    (if (setq itm (assoc (strcase (vla-get-propertyname x)) lst))
      (vla-put-value x (vlax-make-variant (cdr itm) (vlax-variant-type (vla-get-value x))))
      )
    )
  )

;---------- DYNAMIC ----------;

;-----

;---------- XU LY LIST ----------;

;MULTIPLE ASSOC (UNG DUNG KHI LAY TAT CA CAC DINH CUA 1 POLYLINE)
(defun massoc (key lst / lst1 lst2)
  (while (setq lst1 (assoc key lst))
    (setq lst2 (cons (cdr lst1) lst2))
    (setq lst (cdr (member lst1 lst)))
    )
  (reverse lst2)
  )

;XOA PHAN TU TRUNG
(defun unique (lst)
  (if lst (cons (car lst) (unique (vl-remove (car lst) (cdr lst)))))
  )

;XOA PHAN TU TRUNG (UNG DUNG DE XOA CAC DIEM TRUNG NHAU THEO SAI SO NHAT DINH)
(defun unique_fuzz (lst fuzz / x lst1)
  (while lst
    (setq x (car lst)
	  lst (vl-remove-if (function (lambda (y) (equal x y fuzz))) (cdr lst))
	  lst1 (cons x lst1)
	  )
    )
  (reverse lst1)
  )

;---------- XU LY LIST ----------;

;-----

;---------- NHAP LIEU ----------;

;NHAP SO THUC
(defun get_real (default promp / str)
  (while (not str)
    (setq str (getstring (strcat "\n" promp " <" (rtos (float default) 2 (getvar "DIMDEC")) "> ")))
    (if (= (substr str 1 1) ".") (setq str (strcat "0" str)))
    (setq str (cond
		((= str "") (float default))
		((numberp (read str)) (atof str))
		(t nil)
		))
    )
  )

;NHAP SO NGUYEN
(defun get_int (default promp / str)
  (while (not str)
    (setq str (getstring (strcat "\n" promp " <" (itoa default) "> ")))
    (setq str (cond
		((= (substr str 1 1) ".") 0)
		((= str "") (fix default))
		((numberp (read str)) (atoi str))
		(t nil)
		))
    )
  )

;NHAP XAU
(defun get_str (default promp / str)
  (if (= (setq str (getstring (strcat "\n" promp " <" default "> "))) "")
    default
    str
    )
  )

;CHON DOI TUONG
;CU PHAP: (ent_pick "LINE" "Chon Line") hoac (ent_pick (list "LINE" "ARC" "CIRCLE") "Chon doi tuong")
(defun ent_pick (typ promp / ent)
  (if (not (listp typ)) (setq typ (list typ)))
  (setq typ (mapcar 'list typ))
  (while (not ent)
    (while (not (setq ent (car (entsel (strcat "\n" promp))))))
    (if (not (assoc (cdr (assoc 0 (entget ent))) typ)) (setq ent nil))
    )
  ent
  )

;NHAP KEYWORD
;CU PHAP: (keyword (list "Yes" "No" "Maybe") "Yes" "Are you sure ?")
(defun keyword (key default promp / str1 str2 str3 str4)
  (setq str1 (apply 'strcat (mapcar (function (lambda (x) (strcat x " "))) key)))
  (setq str2 (apply 'strcat (mapcar (function (lambda (x) (strcat x "/"))) key)))
  (setq str1 (substr str1 1 (1- (strlen str1))))
  (setq str2 (substr str2 1 (1- (strlen str2))))
  (initget str1)
  (setq str3 (strcat "\n" promp " [" str2 "] <" default "> "))
  (if (not (setq str4 (getkword str3)))
    default
    str4
    )
  )

;CHON ATT TRONG BLOCK CHUA NHIEU ATT - HAM CON: KEYWORD
(defun att_pick (ent promp / lst def)
  (setq lst (mapcar 'car (att_get ent)))
  (setq def (car lst))
  (if (> (length lst) 1)
    (keyword lst def promp)
    def
    )
  )

;CHON ATT TRONG BLOCK CHUA NHIEU ATT (CO GIA TRI MAC DINH) - HAM CON: KEYWORD)
(defun att_pick_def (ent def promp / lst)
  (setq lst (mapcar 'car (att_get ent)))
  (if (> (length lst) 1)
    (keyword lst def promp)
    def
    )
  )

;---------- NHAP LIEU ----------;

 

  • Like 3

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 29/10/2018 tại 15:10, Duong Nhat Duy đã nói:

Chào cả nhà,

Mình có sưu tầm được một số các hàm con hữu ích từ khá nhiều nguồn: của bác Lee Mac, AfraLisp, Forum của Autodesk, ...

Mình muốn chia sẻ cho các bạn newbie mình, bên cạnh đó cũng mong muốn các bạn đã có nhiều kinh nghiệm về Lisp góp ý.

Hàm thì mình đã chú thích ở trên đầu rồi, muốn rõ hơn các bạn để ý thêm phần tên tham số là hiểu ngay hàm đó làm cái gì.

Chúc các bạn một ngày tốt lành !

  • cadvietlisp.lsp
    lisp help
  •  

;---------- ATTRIBUTE ----------;

;THONG KE ATT
(defun att_get (ent)
  (if ent
    (mapcar '(lambda (att) (cons (vla-get-tagstring att) (vla-get-textstring att)))
	    (vlax-invoke (vlax-ename->vla-object ent) 'getattributes)
	    )
    )
  )

;EDIT ATT THEO TAG
(defun att_set (ent tag val)
  (setq tag (strcase tag))
  (vl-some
    '(lambda (att)
       (if (= tag (strcase (vla-get-tagstring att)))
	 (progn (vla-put-textstring att val) val)
	 )
       )
    (vlax-invoke (vlax-ename->vla-object ent) 'getattributes)
    )
  )

;EDIT ATT THEO LIST
(defun att_lst (ent lst / itm)
  (foreach att (vlax-invoke (vlax-ename->vla-object ent) 'getattributes)
    (if (setq itm (assoc (vla-get-tagstring att) lst))
      (vla-put-textstring att (cdr itm))
      )
    )
  )

;---------- ATTRIBUTE ----------;

;-----

;---------- DYNAMIC ----------;

;THONG KE DYN
(defun dyn_get (ent)
  (mapcar '(lambda (dyn) (cons (vla-get-propertyname dyn) (vlax-get dyn 'value)))
	  (vlax-invoke (vlax-ename->vla-object ent) 'getdynamicblockproperties)
	  )
  )

;EDIT DYN THEO PROPERTIES
(defun dyn_set (ent prp val)
  (setq prp (strcase prp))
  (vl-some
    '(lambda ( x )
       (if (= prp (strcase (vla-get-propertyname x)))
	 (progn
	   (vla-put-value x (vlax-make-variant val (vlax-variant-type (vla-get-value x))))
	   (cond (val) (t))
	   )
	 )
       )
    (vlax-invoke (vlax-ename->vla-object ent) 'getdynamicblockproperties)
    )
  )

;EDIT DYN THEO LIST
(defun dyn_lst (ent lst / itm)
  (setq lst (mapcar '(lambda (x) (cons (strcase (car x)) (cdr x))) lst))
  (foreach x (vlax-invoke (vlax-ename->vla-object ent) 'getdynamicblockproperties)
    (if (setq itm (assoc (strcase (vla-get-propertyname x)) lst))
      (vla-put-value x (vlax-make-variant (cdr itm) (vlax-variant-type (vla-get-value x))))
      )
    )
  )

;---------- DYNAMIC ----------;

;-----

;---------- XU LY LIST ----------;

;MULTIPLE ASSOC (UNG DUNG KHI LAY TAT CA CAC DINH CUA 1 POLYLINE)
(defun massoc (key lst / lst1 lst2)
  (while (setq lst1 (assoc key lst))
    (setq lst2 (cons (cdr lst1) lst2))
    (setq lst (cdr (member lst1 lst)))
    )
  (reverse lst2)
  )

;XOA PHAN TU TRUNG
(defun unique (lst)
  (if lst (cons (car lst) (unique (vl-remove (car lst) (cdr lst)))))
  )

;XOA PHAN TU TRUNG (UNG DUNG DE XOA CAC DIEM TRUNG NHAU THEO SAI SO NHAT DINH)
(defun unique_fuzz (lst fuzz / x lst1)
  (while lst
    (setq x (car lst)
	  lst (vl-remove-if (function (lambda (y) (equal x y fuzz))) (cdr lst))
	  lst1 (cons x lst1)
	  )
    )
  (reverse lst1)
  )

;---------- XU LY LIST ----------;

;-----

;---------- NHAP LIEU ----------;

;NHAP SO THUC
(defun get_real (default promp / str)
  (while (not str)
    (setq str (getstring (strcat "\n" promp " <" (rtos (float default) 2 (getvar "DIMDEC")) "> ")))
    (if (= (substr str 1 1) ".") (setq str (strcat "0" str)))
    (setq str (cond
		((= str "") (float default))
		((numberp (read str)) (atof str))
		(t nil)
		))
    )
  )

;NHAP SO NGUYEN
(defun get_int (default promp / str)
  (while (not str)
    (setq str (getstring (strcat "\n" promp " <" (itoa default) "> ")))
    (setq str (cond
		((= (substr str 1 1) ".") 0)
		((= str "") (fix default))
		((numberp (read str)) (atoi str))
		(t nil)
		))
    )
  )

;NHAP XAU
(defun get_str (default promp / str)
  (if (= (setq str (getstring (strcat "\n" promp " <" default "> "))) "")
    default
    str
    )
  )

;CHON DOI TUONG
;CU PHAP: (ent_pick "LINE" "Chon Line") hoac (ent_pick (list "LINE" "ARC" "CIRCLE") "Chon doi tuong")
(defun ent_pick (typ promp / ent)
  (if (not (listp typ)) (setq typ (list typ)))
  (setq typ (mapcar 'list typ))
  (while (not ent)
    (while (not (setq ent (car (entsel (strcat "\n" promp))))))
    (if (not (assoc (cdr (assoc 0 (entget ent))) typ)) (setq ent nil))
    )
  ent
  )

;NHAP KEYWORD
;CU PHAP: (keyword (list "Yes" "No" "Maybe") "Yes" "Are you sure ?")
(defun keyword (key default promp / str1 str2 str3 str4)
  (setq str1 (apply 'strcat (mapcar (function (lambda (x) (strcat x " "))) key)))
  (setq str2 (apply 'strcat (mapcar (function (lambda (x) (strcat x "/"))) key)))
  (setq str1 (substr str1 1 (1- (strlen str1))))
  (setq str2 (substr str2 1 (1- (strlen str2))))
  (initget str1)
  (setq str3 (strcat "\n" promp " [" str2 "] <" default "> "))
  (if (not (setq str4 (getkword str3)))
    default
    str4
    )
  )

;CHON ATT TRONG BLOCK CHUA NHIEU ATT - HAM CON: KEYWORD
(defun att_pick (ent promp / lst def)
  (setq lst (mapcar 'car (att_get ent)))
  (setq def (car lst))
  (if (> (length lst) 1)
    (keyword lst def promp)
    def
    )
  )

;CHON ATT TRONG BLOCK CHUA NHIEU ATT (CO GIA TRI MAC DINH) - HAM CON: KEYWORD)
(defun att_pick_def (ent def promp / lst)
  (setq lst (mapcar 'car (att_get ent)))
  (if (> (length lst) 1)
    (keyword lst def promp)
    def
    )
  )

;---------- NHAP LIEU ----------;

 

E chào bác! Bác cho e hỏi chút, về hàm để hiện dòng nhắc lệnh, trong lisp dưới đây, e muốn thay vị trí xuất hiện dòng nhắc "Chon Block mau:"  từ command lên vị trí con trỏ chuột thì phải làm thế nào bác nhỉ...

(defun c:bn (/ rn ssblk blkName)(vl-load-com)
(prompt "\nChon Block mau :")
(setq   rn (lambda(x)(vla-get-EffectiveName (vlax-ename->vla-object x)))
 blkName (rn (ssname (ssget ":S" (list (cons 0 "INSERT"))) 0)))
(prompt "\nChon khu vuc chua Block :")
(setq ssBlk (ssget (list (cons 0 "INSERT")(cons 2 (strcat "`*U*," blkName)))))
(mapcar '(lambda(x)(if (not (eq (rn x) blkName))(ssdel x ssblk)))
(mapcar 'cadr (vl-remove-if '(lambda(x)(listp (cadr x))) (ssnamex ssBlk)))) 
(sssetfirst nil ssBlk)
)

 

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
1 giờ} trướ}c, Doan Nguyen Van đã nói:

E chào bác! Bác cho e hỏi chút, về hàm để hiện dòng nhắc lệnh, trong lisp dưới đây, e muốn thay vị trí xuất hiện dòng nhắc "Chon Block mau:"  từ command lên vị trí con trỏ chuột thì phải làm thế nào bác nhỉ...

(defun c:bn (/ rn ssblk blkName)(vl-load-com)
(prompt "\nChon Block mau :")
(setq   rn (lambda(x)(vla-get-EffectiveName (vlax-ename->vla-object x)))
 blkName (rn (ssname (ssget ":S" (list (cons 0 "INSERT"))) 0)))
(prompt "\nChon khu vuc chua Block :")
(setq ssBlk (ssget (list (cons 0 "INSERT")(cons 2 (strcat "`*U*," blkName)))))
(mapcar '(lambda(x)(if (not (eq (rn x) blkName))(ssdel x ssblk)))
(mapcar 'cadr (vl-remove-if '(lambda(x)(listp (cadr x))) (ssnamex ssBlk)))) 
(sssetfirst nil ssBlk)
)

 

Hàm ssget chỉ có 1 thông báo default là "Select objects: ", và không thể thay đổi được nó (theo những gì mình biết là như vậy). Chỉ có cách chống đối là tạo thêm 1 thông báo trước nó như trong lisp của bạn thôi.

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

Bạn tham khảo hàm này của Lee nhé

;; ssget  -  Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments
;ex:(LM:ssget "\nSelect objects (TEXT,MTEXT,LEADER,Block att): " '(   "_:L"((-4 . "<OR")(0 . "TEXT,MTEXT,LEADER")(-4 . "<AND")(00 . "INSERT")(66 . 1)(-4 . "AND>")(-4 . "OR>")))) 
(defun LM:ssget ( msg arg / sel )
    (princ msg)
    (setvar 'nomutt 1)
    (setq sel (vl-catch-all-apply 'ssget arg))
    (setvar 'nomutt 0)
    (if (not (vl-catch-all-error-p sel)) sel)
)

 

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
1 giờ} trướ}c, tien2005 đã nói:

Bạn tham khảo hàm này của Lee nhé

  • cadvietlisp.lsp
    lisp help
  •  

;; ssget  -  Lee Mac
; A wrapper for the ssget function to permit the use of a custom selection prompt
; msg - [str] selection prompt
; arg - [lst] list of ssget arguments
;ex:(LM:ssget "\nSelect objects (TEXT,MTEXT,LEADER,Block att): " '(   "_:L"((-4 . "<OR")(0 . "TEXT,MTEXT,LEADER")(-4 . "<AND")(00 . "INSERT")(66 . 1)(-4 . "AND>")(-4 . "OR>")))) 
(defun LM:ssget ( msg arg / sel )
    (princ msg)
    (setvar 'nomutt 1)
    (setq sel (vl-catch-all-apply 'ssget arg))
    (setvar 'nomutt 0)
    (if (not (vl-catch-all-error-p sel)) sel)
)

 

Em có xem qua nhưng chưa biết cách thay hàm vào lisp trên của em, mong bác giúp đỡ 

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
21 giờ trước, Doan Nguyen Van đã nói:

Em có xem qua nhưng chưa biết cách thay hàm vào lisp trên của em, mong bác giúp đỡ 

Bạn thay vào những chỗ có ssget, sửa thành LM:ssget, chú ý cú pháp hàm.

Tuy nhiên hàm trên cũng không hiện hẳn dòng thông báo lên bên cạnh con trỏ chuột đâu, nó chỉ hiện dưới dòng command thôi.

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 1/11/2018 tại 09:29, Duong Nhat Duy đã nói:

Bạn thay vào những chỗ có ssget, sửa thành LM:ssget, chú ý cú pháp hàm.

Tuy nhiên hàm trên cũng không hiện hẳn dòng thông báo lên bên cạnh con trỏ chuột đâu, nó chỉ hiện dưới dòng command thôi.

 

Bác Duy ơi, bác có thể xem qua đoạn mã trên giúp em với ạ 

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

Cái biến nomutt của autoCAD chỉ tắt chữ Select object trên command text thôi. Còn không ảnh hưởng gì trên con trỏ chuột.

(Dùng (setvar 'nomutt 1) là tắt hiện text mới trên command text.

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

×