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

Tháng 6 19, 2020

6 phút trước, Doan Van Ha đã nói:

Câu hỏi hời hợt quá. Các xi/yi/zi ở đâu ra? Các Text(i) ở đâu ra? Bản vẽ 2007 post lên đi, cái này dễ

Em gửi bác bản vẽ ví dụ ạ!

vidu.dwg

Tháng 6 19, 2020


(defun C:HA(/ lst ds td)
 (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "text")))))))
 (setq lst (mapcar '(lambda(e) (setq ds (entget e) td (cdr (assoc 10 ds))) (list (cdr (assoc 1 ds)) (car td) (cadr td) (caddr td))) lst))
 (vl-sort lst '(lambda(x y) (< (cadr x) (cadr y)))))

Tháng 6 19, 2020

1 giờ} trướ}c, Doan Van Ha đã nói:


(defun C:HA(/ lst ds td)
 (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "text")))))))
 (setq lst (mapcar '(lambda(e) (setq ds (entget e) td (cdr (assoc 10 ds))) (list (cdr (assoc 1 ds)) (car td) (cadr td) (caddr td))) lst))
 (vl-sort lst '(lambda(x y) (< (cadr x) (cadr y)))))

Quá chuẩn rồi ạ. Em cảm ơn bác!

Tháng 6 22, 2020

Các bác cho em hỏi đoạn code sau:

(sssetfirst nil (ssget (list (cons 0 "INSERT") (cons 2 "blockname1,blockname2,blockname3"))))

Nếu vùng chọn không có các block có tên trong list trên thì bỏ qua để thực hiện các lệnh tiếp theo thì bổ sung code như thế nào ạ.

Em cảm ơn ạ!

Tháng 6 22, 2020

19 phút trước, naturooo đã nói:
Các bác cho em hỏi đoạn code sau:
cadvietlisp.lsp

[✎]
(sssetfirst nil (ssget (list (cons 0 "INSERT") (cons 2 "blockname1,blockname2,blockname3"))))
Nếu vùng chọn không có các block có tên trong list trên thì bỏ qua để thực hiện các lệnh tiếp theo thì bổ sung code như thế nào ạ.

Em cảm ơn ạ!

(if (setq ss (ssget (list (cons 0 "INSERT") (cons 2 "blockname1,blockname2,blockname3"))))
(sssetfirst nil ss)
)

đây bạn

Tháng 6 22, 2020

1 giờ trước, Biet ve CAD đã nói:
cadvietlisp.lsp

[✎]
(if (setq ss (ssget (list (cons 0 "INSERT") (cons 2 "blockname1,blockname2,blockname3"))))
(sssetfirst nil ss)
)
đây bạn

Em thêm vào như đoạn code bên dưới nhưng vẫn phải ấn enter nó mới chạy tiếp được anh ạ!

 ......
      (vpsel "W")
      (if (setq ss (ssget (list (cons 0 "INSERT") (cons 2 "DDOC,DDOC1,CD,CD1,CD2,CD3,MC0"))))
      (progn      
      (sssetfirst nil ss)
      (c:BUP)
      )
......

Tháng 6 22, 2020

4 phút trước, naturooo đã nói:
Em thêm vào như đoạn code bên dưới nhưng vẫn phải ấn enter nó mới chạy tiếp được anh ạ!
cadvietlisp.lsp

[✎]
 ......
      (vpsel "W")
      (if (setq ss (ssget (list (cons 0 "INSERT") (cons 2 "DDOC,DDOC1,CD,CD1,CD2,CD3,MC0"))))
      (progn      
      (sssetfirst nil ss)
      (c:BUP)
      )

Do lệnh (C:BUP) của bạn chắc có hàm ssget và chọn luôn cái ss kia nên phải enter

Tháng 6 22, 2020

47 phút trước, Biet ve CAD đã nói:

Do lệnh (C:BUP) của bạn chắc có hàm ssget và chọn luôn cái ss kia nên phải enter

Em muốn nếu k có các block trên thì không thực hiện lệnh BUP thì sửa lại sạo ạ?

Tháng 6 22, 2020

13 phút trước, naturooo đã nói:

Em muốn nếu k có các block trên thì không thực hiện lệnh BUP thì sửa lại sạo ạ?

(if (setq ss (ssget (list (cons 0 "INSERT") (cons 2 "DDOC,DDOC1,CD,CD1,CD2,CD3,MC0"))))
  (progn
    ;thuc hien khi co block
    (sssetfirst nil ss)
    (c:BUP)
    )
  (progn
    ;thuc hien khi khong co block
    (princ "\nKhong tim thay block")
    )
  )

Tháng 6 22, 2020

Bạn phải xem lại trong lệnh BUP có hàm ssget đó hay không, nếu có thì bỏ ra. Còn không được thì đưa lệnh BUP lên đây

Tháng 6 22, 2020

42 phút trước, Biet ve CAD đã nói:

cadvietlisp.lsp
[✎]


(if (setq ss (ssget (list (cons 0 "INSERT") (cons 2 "DDOC,DDOC1,CD,CD1,CD2,CD3,MC0"))))
  (progn
    ;thuc hien khi co block
    (sssetfirst nil ss)
    (c:BUP)
    )
  (progn
    ;thuc hien khi khong co block
    (princ "\nKhong tim thay block")
    )
  )

Em thử như vậy rồi nó vẫn bắt enter để qua viewport tiếp theo anh ạ!

;;===============UP DIM, UP TEXT, UPBLOCK THEO VIEWPORT=======================================
(defun c:SUP( / oldCmdEcho listVPorts itemVPort ss ssl temp ed old new )
(vl-load-com)
(setq oldCmdEcho (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq currentLayout (getvar "ctab"))
(setvar "CTAB" "Model")
(command "_.ucs" "w");Ve lai Model va dat lai UCS ve World
(foreach lay (layoutlist) (setvar "CTAB" lay)

(if (/= (getvar "CTAB") "Model")
 (progn
  (setq listVPorts (vl-sort (vports) '(lambda(v1 v2) (< (car v1) (car v2)))))
  (if (> (length listVPorts) 1)
   (progn
    (command "_MSPACE")
    (foreach itemVPort (cdr listVPorts)
     (setvar "CVPORT" (car itemVPort))
      (vpsel "W")
      (setq ent (vlax-vla-object->ename
                    (vla-get-activepviewport
                      (vla-get-activedocument (vlax-get-acad-object)))))
      (setq cvscale (vla-get-customscale (vlax-ename->vla-object ent)))
      (setvar "dimscale" (/ 1 cvscale))
      (vpsel "W")
	(if (setq ss (ssget (list (cons 0 "INSERT") (cons 2 "DDOC,DDOC1,CD,CD1,CD2,CD3,MC0"))))
  	   (progn
    	   ;thuc hien khi co block
    		(sssetfirst nil ss)
    		(c:BUP)
           )
  	   (progn
    	   ;thuc hien khi khong co block
    		(princ "\nKhong tim thay block")
    	   )
       );end if
;      (vpsel "C")
;     (getkword "\nPress <ENTER> to go to next viewport")
    )
    (command "_PSPACE")
   )
   (prompt "\nThere are no viewports defined in this Layout!")
  )
 )
 (prompt "\nThis routine works only in Layout!")
)
);END foreach
(setvar "CMDECHO" oldCmdEcho)
(setvar "CTAB" currentLayout)
(princ)
)
;=====================================================================================
;https://lispbox.wordpress.com/2015/05/05/selecting-objects-within-viewport-and-copy-it-to-clipboard-by-selecting-a-ps-viewport/
;;; vpsel.lsp
;;; By Jimmy Bergmark
;;; Copyright (C) 1997-2006 JTB World, All Rights Reserved
;;; Website: http://www.jtbworld.com (http://www.jtbworld.com)
;;; E-mail: info@jtbworld.com
;;; 2000-04-14 - First release
;;; Tested on AutoCAD 2000
;;; DESCRIPTION
;;; Select all visible objects in selected or active paperspace viewport Works transparently when in modelspace and for polygonal viewports too
;;; Example1: ERASE ALL R 'VPC >>> Erase all in model except what is visible
;;; Example2: (command "erase" "all" "r" (c:vpc) "")
;;; Example3: VPC ERASE >>> VPC is run previous the command and the objects are also in previous selection set
;;; c:vpc - select all visible objects with crossing in viewport
;;; c:vpw - select all visible objects with window in viewport
;;; Phai dua UCS ve World ******************************************************************************************************************************************
(defun vpsel (typ / ad ss ent vpno ok vpbl vpur msbl msur msul mslr ss1 pl nlist x n)
 (vl-load-com)
 (setq ok t)
 (if (= (getvar "tilemode") 0)
  (progn
   (setq ad (vla-get-activedocument (vlax-get-acad-object)))
   (if (= (getvar "cvport") 1)
    (if (and (= (getvar "cmdactive") 0) (/= (setq ss (ssget ":E:S" '((0 . "VIEWPORT")))) nil))
     (progn
      (setq ent (ssname ss 0))
      (setq vpno (dxf 69 (entget ent)))
      (vla-Display (vla-get-activepviewport ad) :vlax-true)
      (vla-put-mspace ad :vlax-true)
      (setvar "cvport" vpno))
     (progn
      (setq ok nil)
      (princ)))
  (setq ent (vlax-vla-object->ename (vla-get-activepviewport ad))))
(if (and ok (/= 1 (logand 1 (dxf 90 (setq ed (entget ent))))))
(progn
(if (= (vla-get-clipped (vlax-ename->vla-object ent)) :vlax-false)
(progn
(vla-getboundingbox
(vla-get-activepviewport ad) 'vpbl 'vpur)
(setq msbl (trans (vlax-safearray->list vpbl) 3 2))
(setq msur (trans (vlax-safearray->list vpur) 3 2))
(setq msul (list (car msbl) (cadr msur)))
(setq mslr (list (car msur) (cadr msbl)))
(setq ss1
(ssget (strcat typ "P") (list msbl msul msur mslr))))
(progn
(setq pl (entget (dxf 340 (entget ent))))
(setq nlist nil)
(foreach x pl
(if (eq 10 (car x))
(setq nlist (cons (trans (cdr x) 3 2) nlist))))
(setq ss1 (ssget (strcat typ "P") nlist))))
(sssetfirst nil ss1)
(if ss1
(setq n (sslength ss1))
(setq n 0))
(princ n)
(princ " found ")
(if (and ss1 (= (getvar "cmdactive") 1))
ss1
(princ)))
(princ)))
(princ)))
;=====================================================================================
;--------------------------------------------------------------------------------
(defun DXF (code elist)
  (cdr (assoc code elist))
)
(defun b_ssget ( / ssl  nsset temp ed )
  (setq sset (ssget))
  (setq ssl (sslength sset) 
        nsset (ssadd)
  )
  (print ssl)
  (princ "entities found. ")  
  (princ "\nVerifying the selected entities -- please wait. ")
  (while (> ssl 0)
    (progn
      (setq temp (ssname sset (setq ssl (1- ssl))))
      (setq ed (entget temp))
      (if (= (DXF 0 ed) "INSERT") (ssadd temp nsset))
    )
  )
  (setq ssl (sslength nsset)
        sset nsset
  )
  (print ssl)
  (princ "INSERT entities found. ")
  (princ)
);defun b_ssget
;---------------------------------------------------------------------
(defun c:BUP( / sset ssl temp ed old new )
(setvar "cmdecho" 0)
(setvar "REGENMODE" 0)
  (setq SCALE (getvar "dimscale"))
(b_ssget)
(if (= scale nil) (setq scale (getreal "\nInput current scale: ")))
 
(setq ssl (sslength sset))
  (while (> ssl 0)
    (progn
      (setq temp (ssname sset (setq ssl (1- ssl)))
            ed (entget temp)
            basept (dxf 10 ed)
            oldscale (dxf 41 ed)
            old (cons 41 (DXF 41 ed))
            new (cons 41 scale)
            ed (subst new old ed)

            old (cons 42 (DXF 42 ed))
            new (cons 42 scale)
            ed (subst new old ed)

            old (cons 43 (DXF 43 ed))
            new (cons 43 scale)
            ed (subst new old ed)
      )
      (entmod ed)  
      (setq temp (entnext temp))

      (if (/= temp nil)
         (progn
           (setq ed (entget temp)
                 pt1 (dxf 10 ed)
                 pt2 (dxf 11 ed)
                 old (cons 40 (DXF 40 ed))
                 new (cons 40 (* scale 2))
                 ed (subst new old ed)
                 ratio (/ scale oldscale)
                 pt1 (list (+ (car basept) (* (- (car pt1) (car basept)) ratio))
                           (+ (cadr basept) (* (- (cadr pt1) (cadr basept)) ratio))
                           (+ (caddr basept) (* (- (caddr pt1) (caddr basept)) ratio))
                     )
                 pt2 (list (+ (car basept) (* (- (car pt2) (car basept)) ratio))
                           (+ (cadr basept) (* (- (cadr pt2) (cadr basept)) ratio))
                           (+ (caddr basept) (* (- (caddr pt2) (caddr basept)) ratio))
                     )
                 old (cons 10 (DXF 10 ed))
                 new (cons 10 pt1)
                 ed (subst new old ed)

                 old (cons 11 (DXF 11 ed))
                 new (cons 11 pt2)
                 ed (subst new old ed)
           )
           (entmod ed)  
         )
      )
    )
  )
(command "regen")
 (princ)
);defun

Anh xem lại giúp em ạ!

test.dwg

Tháng 6 22, 2020

13 phút trước, tien2005 đã nói:

Bạn phải xem lại trong lệnh BUP có hàm ssget đó hay không, nếu có thì bỏ ra. Còn không được thì đưa lệnh BUP lên đây

Em tưởng k có thì nó bỏ qua được chứ nhỉ. Những viewport có thì nó chạy được. Đến viewport không có block thì nó dừng lại bắt enter ạ!

Tháng 6 22, 2020

Bạn có hàm (b_ssget) trong lệnh BUP

Tháng 6 22, 2020

17 phút trước, tien2005 đã nói:

Bạn có hàm (b_ssget) trong lệnh BUP

Chỗ này em k hiểu lắm. Như đoạn code của anh Biet Ve CAD thì nó thực hiện khối lệnh thứ 2 của hàm if thì em tưởng nó sẽ bỏ qua hàm BUP chứ ạ?

Tháng 6 22, 2020

@naturooo khi hàm if thỏa điều kiện [ có (setq ss (ssget (list (cons 0 "INSERT") (cons 2 "DDOC,DDOC1,CD,CD1,CD2,CD3,MC0"))))] thì nó thực hiện khối lệnh 1 là (sssetfirst nil ss) và (c:BUP), nếu không thỏa thì nó thực hiện khối lệnh 2 là (princ "\nKhong tim thay block").

Tháng 6 22, 2020

8 phút trước, tien2005 đã nói:

@naturooo khi hàm if thỏa điều kiện [ có (setq ss (ssget (list (cons 0 "INSERT") (cons 2 "DDOC,DDOC1,CD,CD1,CD2,CD3,MC0"))))] thì nó thực hiện khối lệnh 1 là (sssetfirst nil ss) và (c:BUP), nếu không thỏa thì nó thực hiện khối lệnh 2 là (princ "\nKhong tim thay block").

Em cũng hiểu như vậy. Vậy khi chạy đến viewport không chưa block mà nó vẫn đòi chọn đối tượng em nghĩ không phải do hàm BUP chứ ạ.

Tháng 6 22, 2020

32 phút trước, naturooo đã nói:

Em cũng hiểu như vậy. Vậy khi chạy đến viewport không chưa block mà nó vẫn đòi chọn đối tượng em nghĩ không phải do hàm BUP chứ ạ.

Sau 1 hồi bỏng mắt đọc code của bác thì cũng hiểu sơ:

Bác sửa điều kiện (setq ss (ssget thành

(if (and ss1
		 (> (sslength ss1) 0)
	  (setq ss (ssget  (list (cons 0 "INSERT") (cons 2 "DDOC,DDOC1,CD,CD1,CD2,CD3,MC0"))))
		 )
  	   (progn
    		(sssetfirst nil ss)
    		(c:BUP)
           )
  	   (progn
    	   ;thuc hien khi khong co block
    		(princ "\nKhong tim thay block")
    	   )
       )

Tháng 6 22, 2020

@Doan Nguyen Van Code em toàn xào nấu từ các đoạn code nhỏ lại với nhau nên rất lủng củng ^^!. Như bác sửa nó chạy qua được viewport không chứa block nhưng viewport chúa block nó lại k BUP được ạ :((

Tháng 6 22, 2020

29 phút trước, naturooo đã nói:

@Doan Nguyen Van Code em toàn xào nấu từ các đoạn code nhỏ lại với nhau nên rất lủng củng ^^!. Như bác sửa nó chạy qua được viewport không chứa block nhưng viewport chúa block nó lại k BUP được ạ :((

Sửa lại cho bạn đây

;;===============UP DIM, UP TEXT, UPBLOCK THEO VIEWPORT=======================================
(defun c:SUP( / oldCmdEcho listVPorts itemVPort ss ssl temp ed old new )
(vl-load-com)
(setq oldCmdEcho (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq currentLayout (getvar "ctab"))
(setvar "CTAB" "Model")
(command "_.ucs" "w");Ve lai Model va dat lai UCS ve World
(foreach lay (layoutlist) (setvar "CTAB" lay)

(if (/= (getvar "CTAB") "Model")
 (progn
  (setq listVPorts (vl-sort (vports) '(lambda(v1 v2) (< (car v1) (car v2)))))
  (if (> (length listVPorts) 1)
   (progn
    (command "_MSPACE")
    (foreach itemVPort (cdr listVPorts)
     (setvar "CVPORT" (car itemVPort))
      (vpsel "W")
      (setq ent (vlax-vla-object->ename
                    (vla-get-activepviewport
                      (vla-get-activedocument (vlax-get-acad-object)))))
      (setq cvscale (vla-get-customscale (vlax-ename->vla-object ent)))
      (setvar "dimscale" (/ 1 cvscale))
      (vpsel "W")
	(if (and ss1
		 (> (sslength ss1) 0)
	  (setq ss (acet-list-to-ss
		(vl-remove-if-not '(lambda (X) (and (wcmatch (cdr (assoc 0 (entget x))) "INSERT")
						    (wcmatch (strcase (cdr (assoc 2 (entget x))) nil) "DDOC,DDOC1,CD,CD1,CD2,CD3,MC0"))
				     ) (acet-ss-to-list ss1))))
		 )
  	   (progn
    		(sssetfirst nil ss)
    		(c:BUP)
           )
  	   (progn
    	   ;thuc hien khi khong co block
    		(princ "\nKhong tim thay block")
    	   )
       );end if
;      (vpsel "C")
;     (getkword "\nPress <ENTER> to go to next viewport")
    )
    (command "_PSPACE")
   )
   (prompt "\nThere are no viewports defined in this Layout!")
  )
 )
 (prompt "\nThis routine works only in Layout!")
)
);END foreach
(setvar "CMDECHO" oldCmdEcho)
(setvar "CTAB" currentLayout)
(princ)
)
;=====================================================================================
;https://lispbox.wordpress.com/2015/05/05/selecting-objects-within-viewport-and-copy-it-to-clipboard-by-selecting-a-ps-viewport/
;;; vpsel.lsp
;; By Jimmy Bergmark
;; Copyright (C) 1997-2006 JTB World, All Rights Reserved
;; Website: http://www.jtbworld.com (http://www.jtbworld.com)
;; E-mail: info@jtbworld.com
;; 2000-04-14 - First release
;; Tested on AutoCAD 2000
;; DESCRIPTION
;; Select all visible objects in selected or active paperspace viewport Works transparently when in modelspace and for polygonal viewports too
;; Example1: ERASE ALL R 'VPC >>> Erase all in model except what is visible
;; Example2: (command "erase" "all" "r" (c:vpc) "")
;; Example3: VPC ERASE >>> VPC is run previous the command and the objects are also in previous selection set
;; c:vpc - select all visible objects with crossing in viewport
;; c:vpw - select all visible objects with window in viewport
;; Phai dua UCS ve World ******************************************************************************************************************************************
(defun vpsel (typ / ad ss ent vpno ok vpbl vpur msbl msur msul mslr pl nlist x n)
 (vl-load-com)
 (setq ok t)
 (if (= (getvar "tilemode") 0)
  (progn
   (setq ad (vla-get-activedocument (vlax-get-acad-object)))
   (if (= (getvar "cvport") 1)
    (if (and (= (getvar "cmdactive") 0) (/= (setq ss (ssget ":E:S" '((0 . "VIEWPORT")))) nil))
     (progn
      (setq ent (ssname ss 0))
      (setq vpno (dxf 69 (entget ent)))
      (vla-Display (vla-get-activepviewport ad) :vlax-true)
      (vla-put-mspace ad :vlax-true)
      (setvar "cvport" vpno))
     (progn
      (setq ok nil)
      (princ)))
  (setq ent (vlax-vla-object->ename (vla-get-activepviewport ad))))
(if (and ok (/= 1 (logand 1 (dxf 90 (setq ed (entget ent))))))
(progn
(if (= (vla-get-clipped (vlax-ename->vla-object ent)) :vlax-false)
(progn
(vla-getboundingbox
(vla-get-activepviewport ad) 'vpbl 'vpur)
(setq msbl (trans (vlax-safearray->list vpbl) 3 2))
(setq msur (trans (vlax-safearray->list vpur) 3 2))
(setq msul (list (car msbl) (cadr msur)))
(setq mslr (list (car msur) (cadr msbl)))
(setq ss1
(ssget (strcat typ "P") (list msbl msul msur mslr))))
(progn
(setq pl (entget (dxf 340 (entget ent))))
(setq nlist nil)
(foreach x pl
(if (eq 10 (car x))
(setq nlist (cons (trans (cdr x) 3 2) nlist))))
(setq ss1 (ssget (strcat typ "P") nlist))))
(sssetfirst nil ss1)
(if ss1
(setq n (sslength ss1))
(setq n 0))
(princ n)
(princ " found ")
(if (and ss1 (= (getvar "cmdactive") 1))
ss1
(princ)))
(princ)))
(princ)))
;=====================================================================================
;--------------------------------------------------------------------------------
(defun DXF (code elist)
  (cdr (assoc code elist))
)
(defun b_ssget (/ ssl  nsset temp ed )
  (setq sset (ssget))
  (setq ssl (sslength sset) 
        nsset (ssadd)
  )
  (print ssl)
  (princ "entities found. ")  
  (princ "\nVerifying the selected entities -- please wait. ")
  (while (> ssl 0)
    (progn
      (setq temp (ssname sset (setq ssl (1- ssl))))
      (setq ed (entget temp))
      (if (= (DXF 0 ed) "INSERT") (ssadd temp nsset))
    )
  )
  (setq ssl (sslength nsset)
        sset nsset
  )
  (print ssl)
  (princ "INSERT entities found. ")
  (princ)
);defun b_ssget
;---------------------------------------------------------------------
(defun c:BUP( / sset ssl temp ed old new )
(setvar "cmdecho" 0)
(setvar "REGENMODE" 0)
  (setq SCALE (getvar "dimscale"))
(b_ssget)
(if (= scale nil) (setq scale (getreal "\nInput current scale: ")))
 ;(setq scale (getreal "\nInput current scale: "))
(setq ssl (sslength sset))
  (while (> ssl 0)
    (progn
      (setq temp (ssname sset (setq ssl (1- ssl)))
            ed (entget temp)
            basept (dxf 10 ed)
            oldscale (dxf 41 ed)
            old (cons 41 (DXF 41 ed))
            new (cons 41 scale)
            ed (subst new old ed)

            old (cons 42 (DXF 42 ed))
            new (cons 42 scale)
            ed (subst new old ed)

            old (cons 43 (DXF 43 ed))
            new (cons 43 scale)
            ed (subst new old ed)
      )
      (entmod ed)  
      (setq temp (entnext temp))

      (if (/= temp nil)
         (progn
           (setq ed (entget temp)
                 pt1 (dxf 10 ed)
                 pt2 (dxf 11 ed)
                 old (cons 40 (DXF 40 ed))
                 new (cons 40 (* scale 2))
                 ed (subst new old ed)
                 ratio (/ scale oldscale)
                 pt1 (list (+ (car basept) (* (- (car pt1) (car basept)) ratio))
                           (+ (cadr basept) (* (- (cadr pt1) (cadr basept)) ratio))
                           (+ (caddr basept) (* (- (caddr pt1) (caddr basept)) ratio))
                     )
                 pt2 (list (+ (car basept) (* (- (car pt2) (car basept)) ratio))
                           (+ (cadr basept) (* (- (cadr pt2) (cadr basept)) ratio))
                           (+ (caddr basept) (* (- (caddr pt2) (caddr basept)) ratio))
                     )
                 old (cons 10 (DXF 10 ed))
                 new (cons 10 pt1)
                 ed (subst new old ed)

                 old (cons 11 (DXF 11 ed))
                 new (cons 11 pt2)
                 ed (subst new old ed)
           )
           (entmod ed)  
         )
      )
    )
  )
(command "regen")
 (princ)
);defun

Tháng 6 22, 2020

29 phút trước, Doan Nguyen Van đã nói:

Sửa lại cho bạn đây

sup_bup.lsp
[✎]


;;===============UP DIM, UP TEXT, UPBLOCK THEO VIEWPORT=======================================
(defun c:SUP( / oldCmdEcho listVPorts itemVPort ss ssl temp ed old new )
(vl-load-com)
(setq oldCmdEcho (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq currentLayout (getvar "ctab"))
(setvar "CTAB" "Model")
(command "_.ucs" "w");Ve lai Model va dat lai UCS ve World
(foreach lay (layoutlist) (setvar "CTAB" lay)

(if (/= (getvar "CTAB") "Model")
 (progn
  (setq listVPorts (vl-sort (vports) '(lambda(v1 v2) (< (car v1) (car v2)))))
  (if (> (length listVPorts) 1)
   (progn
    (command "_MSPACE")
    (foreach itemVPort (cdr listVPorts)
     (setvar "CVPORT" (car itemVPort))
      (vpsel "W")
      (setq ent (vlax-vla-object->ename
                    (vla-get-activepviewport
                      (vla-get-activedocument (vlax-get-acad-object)))))
      (setq cvscale (vla-get-customscale (vlax-ename->vla-object ent)))
      (setvar "dimscale" (/ 1 cvscale))
      (vpsel "W")
	(if (and ss1
		 (> (sslength ss1) 0)
	  (setq ss (acet-list-to-ss
		(vl-remove-if-not '(lambda (X) (and (wcmatch (cdr (assoc 0 (entget x))) "INSERT")
						    (wcmatch (strcase (cdr (assoc 2 (entget x))) nil) "DDOC,DDOC1,CD,CD1,CD2,CD3,MC0"))
				     ) (acet-ss-to-list ss1))))
		 )
  	   (progn
    		(sssetfirst nil ss)
    		(c:BUP)
           )
  	   (progn
    	   ;thuc hien khi khong co block
    		(princ "\nKhong tim thay block")
    	   )
       );end if
;      (vpsel "C")
;     (getkword "\nPress <ENTER> to go to next viewport")
    )
    (command "_PSPACE")
   )
   (prompt "\nThere are no viewports defined in this Layout!")
  )
 )
 (prompt "\nThis routine works only in Layout!")
)
);END foreach
(setvar "CMDECHO" oldCmdEcho)
(setvar "CTAB" currentLayout)
(princ)
)
;=====================================================================================
;https://lispbox.wordpress.com/2015/05/05/selecting-objects-within-viewport-and-copy-it-to-clipboard-by-selecting-a-ps-viewport/
;;; vpsel.lsp
; By Jimmy Bergmark
; Copyright (C) 1997-2006 JTB World, All Rights Reserved
; Website: http://www.jtbworld.com (http://www.jtbworld.com)
; E-mail: info@jtbworld.com
; 2000-04-14 - First release
; Tested on AutoCAD 2000
; DESCRIPTION
; Select all visible objects in selected or active paperspace viewport Works transparently when in modelspace and for polygonal viewports too
; Example1: ERASE ALL R 'VPC >>> Erase all in model except what is visible
; Example2: (command "erase" "all" "r" (c:vpc) "")
; Example3: VPC ERASE >>> VPC is run previous the command and the objects are also in previous selection set
; c:vpc - select all visible objects with crossing in viewport
; c:vpw - select all visible objects with window in viewport
; Phai dua UCS ve World ******************************************************************************************************************************************
(defun vpsel (typ / ad ss ent vpno ok vpbl vpur msbl msur msul mslr pl nlist x n)
 (vl-load-com)
 (setq ok t)
 (if (= (getvar "tilemode") 0)
  (progn
   (setq ad (vla-get-activedocument (vlax-get-acad-object)))
   (if (= (getvar "cvport") 1)
    (if (and (= (getvar "cmdactive") 0) (/= (setq ss (ssget ":E:S" '((0 . "VIEWPORT")))) nil))
     (progn
      (setq ent (ssname ss 0))
      (setq vpno (dxf 69 (entget ent)))
      (vla-Display (vla-get-activepviewport ad) :vlax-true)
      (vla-put-mspace ad :vlax-true)
      (setvar "cvport" vpno))
     (progn
      (setq ok nil)
      (princ)))
  (setq ent (vlax-vla-object->ename (vla-get-activepviewport ad))))
(if (and ok (/= 1 (logand 1 (dxf 90 (setq ed (entget ent))))))
(progn
(if (= (vla-get-clipped (vlax-ename->vla-object ent)) :vlax-false)
(progn
(vla-getboundingbox
(vla-get-activepviewport ad) 'vpbl 'vpur)
(setq msbl (trans (vlax-safearray->list vpbl) 3 2))
(setq msur (trans (vlax-safearray->list vpur) 3 2))
(setq msul (list (car msbl) (cadr msur)))
(setq mslr (list (car msur) (cadr msbl)))
(setq ss1
(ssget (strcat typ "P") (list msbl msul msur mslr))))
(progn
(setq pl (entget (dxf 340 (entget ent))))
(setq nlist nil)
(foreach x pl
(if (eq 10 (car x))
(setq nlist (cons (trans (cdr x) 3 2) nlist))))
(setq ss1 (ssget (strcat typ "P") nlist))))
(sssetfirst nil ss1)
(if ss1
(setq n (sslength ss1))
(setq n 0))
(princ n)
(princ " found ")
(if (and ss1 (= (getvar "cmdactive") 1))
ss1
(princ)))
(princ)))
(princ)))
;=====================================================================================
;--------------------------------------------------------------------------------
(defun DXF (code elist)
  (cdr (assoc code elist))
)
(defun b_ssget (/ ssl  nsset temp ed )
  (setq sset (ssget))
  (setq ssl (sslength sset) 
        nsset (ssadd)
  )
  (print ssl)
  (princ "entities found. ")  
  (princ "\nVerifying the selected entities -- please wait. ")
  (while (> ssl 0)
    (progn
      (setq temp (ssname sset (setq ssl (1- ssl))))
      (setq ed (entget temp))
      (if (= (DXF 0 ed) "INSERT") (ssadd temp nsset))
    )
  )
  (setq ssl (sslength nsset)
        sset nsset
  )
  (print ssl)
  (princ "INSERT entities found. ")
  (princ)
);defun b_ssget
;---------------------------------------------------------------------
(defun c:BUP( / sset ssl temp ed old new )
(setvar "cmdecho" 0)
(setvar "REGENMODE" 0)
  (setq SCALE (getvar "dimscale"))
(b_ssget)
(if (= scale nil) (setq scale (getreal "\nInput current scale: ")))
 ;(setq scale (getreal "\nInput current scale: "))
(setq ssl (sslength sset))
  (while (> ssl 0)
    (progn
      (setq temp (ssname sset (setq ssl (1- ssl)))
            ed (entget temp)
            basept (dxf 10 ed)
            oldscale (dxf 41 ed)
            old (cons 41 (DXF 41 ed))
            new (cons 41 scale)
            ed (subst new old ed)

            old (cons 42 (DXF 42 ed))
            new (cons 42 scale)
            ed (subst new old ed)

            old (cons 43 (DXF 43 ed))
            new (cons 43 scale)
            ed (subst new old ed)
      )
      (entmod ed)  
      (setq temp (entnext temp))

      (if (/= temp nil)
         (progn
           (setq ed (entget temp)
                 pt1 (dxf 10 ed)
                 pt2 (dxf 11 ed)
                 old (cons 40 (DXF 40 ed))
                 new (cons 40 (* scale 2))
                 ed (subst new old ed)
                 ratio (/ scale oldscale)
                 pt1 (list (+ (car basept) (* (- (car pt1) (car basept)) ratio))
                           (+ (cadr basept) (* (- (cadr pt1) (cadr basept)) ratio))
                           (+ (caddr basept) (* (- (caddr pt1) (caddr basept)) ratio))
                     )
                 pt2 (list (+ (car basept) (* (- (car pt2) (car basept)) ratio))
                           (+ (cadr basept) (* (- (cadr pt2) (cadr basept)) ratio))
                           (+ (caddr basept) (* (- (caddr pt2) (caddr basept)) ratio))
                     )
                 old (cons 10 (DXF 10 ed))
                 new (cons 10 pt1)
                 ed (subst new old ed)

                 old (cons 11 (DXF 11 ed))
                 new (cons 11 pt2)
                 ed (subst new old ed)
           )
           (entmod ed)  
         )
      )
    )
  )
(command "regen")
 (princ)
);defun

Chạy ngon lành rồi ạ. Cảm ơn bác rất nhiều!

Tháng 6 24, 2020

Tôi có lisp bo viền 1 khung tên, nhưng mỗi lần chỉ được 1 khung tên

(defun c:ii (/ eName mn mx)
 (vl-load-com)
 (COMMAND "LAYER" "M" "Khung Viewport" "C" "1" "" "L" "CONTINUOUS" "" "LW" "0.13" "" "P" "N" "" "")
 (if (setq eName (car (entsel "\n  >>  Select Object  >> ")))
   (progn
     (vla-getboundingbox (vlax-ename->vla-object eName) 'mn 'mx)
     (vl-cmdf "._rectang" (vlax-safearray->list mn) (vlax-safearray->list mx))))
 (princ))

Nhờ các bác tư vấn hộ có cách nào chọn 1 loạt khung tên để nó bo viền 1 loạt không. Cám ơn rất nhiều.

Tháng 6 25, 2020

21 giờ trước, nhimret đã nói:
Tôi có lisp bo viền 1 khung tên, nhưng mỗi lần chỉ được 1 khung tên
ii.lsp

[✎]
(defun c:ii (/ eName mn mx)
 (vl-load-com)
 (COMMAND "LAYER" "M" "Khung Viewport" "C" "1" "" "L" "CONTINUOUS" "" "LW" "0.13" "" "P" "N" "" "")
 (if (setq eName (car (entsel "\n  >>  Select Object  >> ")))
   (progn
     (vla-getboundingbox (vlax-ename->vla-object eName) 'mn 'mx)
     (vl-cmdf "._rectang" (vlax-safearray->list mn) (vlax-safearray->list mx))))
 (princ))
Nhờ các bác tư vấn hộ có cách nào chọn 1 loạt khung tên để nó bo viền 1 loạt không. Cám ơn rất nhiều.

Chỉnh lại cho bạn nó hoàn thiện hơn

(defun c:ii (/ lstdt mn mx cur_lay oldos Box)
 (vl-load-com)
(setq cur_lay (getvar "clayer" ))
(setq oldos (getvar "OSMODE"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
 (if (not (tblsearch "layer" "Khung Viewport"))
 (COMMAND "LAYER" "M" "Khung Viewport" "C" "1" "" "L" "CONTINUOUS" "" "LW" "0.13" "" "P" "N" "" "")
 )
(setvar "clayer" "Khung Viewport")
(prompt "\nChon doi tuong:")
(setq lstdt (acet-ss-to-list (ssget '((0 . "LWPOLYLINE")))))
(foreach ent lstdt
(vla-getboundingbox (vlax-ename->vla-object ent) 'mn 'mx)
(vl-cmdf "._rectang" (vlax-safearray->list mn) (vlax-safearray->list mx))
(setq Box (vlax-ename->vla-object (entlast)))
(vl-catch-all-apply 'vla-put-ConstantWidth (list Box 0.5))
)
(setvar "clayer" cur_lay)
(setvar "osmode" oldos)
(setvar "CMDECHO" 1)
 (princ)
)

Tháng 6 25, 2020

7 giờ trước, huunhantvxdts đã nói:

Chỉnh lại cho bạn nó hoàn thiện hơn

ii.lsp
[✎]


(defun c:ii (/ lstdt mn mx cur_lay oldos Box)
 (vl-load-com)
(setq cur_lay (getvar "clayer" ))
(setq oldos (getvar "OSMODE"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
 (if (not (tblsearch "layer" "Khung Viewport"))
 (COMMAND "LAYER" "M" "Khung Viewport" "C" "1" "" "L" "CONTINUOUS" "" "LW" "0.13" "" "P" "N" "" "")
 )
(setvar "clayer" "Khung Viewport")
(prompt "\nChon doi tuong:")
(setq lstdt (acet-ss-to-list (ssget '((0 . "LWPOLYLINE")))))
(foreach ent lstdt
(vla-getboundingbox (vlax-ename->vla-object ent) 'mn 'mx)
(vl-cmdf "._rectang" (vlax-safearray->list mn) (vlax-safearray->list mx))
(setq Box (vlax-ename->vla-object (entlast)))
(vl-catch-all-apply 'vla-put-ConstantWidth (list Box 0.5))
)
(setvar "clayer" cur_lay)
(setvar "osmode" oldos)
(setvar "CMDECHO" 1)
 (princ)
)

cám ơn bác đã bỏ thời gian. Mục đích của lisp là để bo viền khung tên (hoặc 1 block chữ nhật), sau đó dùng các lisp xuất các rectang đó mỗi một rectang là một layout (hiện giờ các lisp free trên cadviet hay là lisp bán đều chỉ áp dụng được với khung chữ nhật

Do đó bác sửa lisp tuy quét hàng loạt được rồi nhưng lại không chọn được block :(

Nếu được bác sửa lại hộ chọn được cả block thì tốt quá.

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

Tháng 6 25, 2020

4 giờ trước, nhimret đã nói:

cám ơn bác đã bỏ thời gian. Mục đích của lisp là để bo viền khung tên (hoặc 1 block chữ nhật), sau đó dùng các lisp xuất các rectang đó mỗi một rectang là một layout (hiện giờ các lisp free trên cadviet hay là lisp bán đều chỉ áp dụng được với khung chữ nhật

Do đó bác sửa lisp tuy quét hàng loạt được rồi nhưng lại không chọn được block :(

Nếu được bác sửa lại hộ chọn được cả block thì tốt quá.

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

Sửa lại cho bạn thêm block

(defun c:ii (/ lstdt mn mx cur_lay oldos Box)
 (vl-load-com)
(setq cur_lay (getvar "clayer" ))
(setq oldos (getvar "OSMODE"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
 (if (not (tblsearch "layer" "Khung Viewport"))
 (COMMAND "LAYER" "M" "Khung Viewport" "C" "1" "" "L" "CONTINUOUS" "" "LW" "0.13" "" "P" "N" "" "")
 )
(setvar "clayer" "Khung Viewport")
(prompt "\nChon doi tuong:")
(setq lstdt (acet-ss-to-list (ssget '((0 . "LWPOLYLINE,insert")))))
(foreach ent lstdt
(vla-getboundingbox (vlax-ename->vla-object ent) 'mn 'mx)
(vl-cmdf "._rectang" (vlax-safearray->list mn) (vlax-safearray->list mx))
(setq Box (vlax-ename->vla-object (entlast)))
(vl-catch-all-apply 'vla-put-ConstantWidth (list Box 0.5))
)
(setvar "clayer" cur_lay)
(setvar "osmode" oldos)
(setvar "CMDECHO" 1)
 (princ)
)

Tháng 6 25, 2020

Vào lúc 25/6/2020 tại 21:48, huunhantvxdts đã nói:

Sửa lại cho bạn thêm block

ii.lsp
[✎]


(defun c:ii (/ lstdt mn mx cur_lay oldos Box)
 (vl-load-com)
(setq cur_lay (getvar "clayer" ))
(setq oldos (getvar "OSMODE"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
 (if (not (tblsearch "layer" "Khung Viewport"))
 (COMMAND "LAYER" "M" "Khung Viewport" "C" "1" "" "L" "CONTINUOUS" "" "LW" "0.13" "" "P" "N" "" "")
 )
(setvar "clayer" "Khung Viewport")
(prompt "\nChon doi tuong:")
(setq lstdt (acet-ss-to-list (ssget '((0 . "LWPOLYLINE,insert")))))
(foreach ent lstdt
(vla-getboundingbox (vlax-ename->vla-object ent) 'mn 'mx)
(vl-cmdf "._rectang" (vlax-safearray->list mn) (vlax-safearray->list mx))
(setq Box (vlax-ename->vla-object (entlast)))
(vl-catch-all-apply 'vla-put-ConstantWidth (list Box 0.5))
)
(setvar "clayer" cur_lay)
(setvar "osmode" oldos)
(setvar "CMDECHO" 1)
 (princ)
)

cám ơn bác, đã ngon rồi <3

Đăng nhập

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

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

naturooo 36

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

Doan Van Ha 3.201

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

naturooo 36

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

naturooo 36

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

Biet ve CAD 258

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

naturooo 36

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

Biet ve CAD 258

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

naturooo 36

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

Biet ve CAD 258

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

tien2005 242

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

naturooo 36

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

naturooo 36

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

tien2005 242

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

naturooo 36

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

tien2005 242

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

naturooo 36

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

Doan Nguyen Van 491

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

naturooo 36

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

Doan Nguyen Van 491

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

naturooo 36