Jump to content
InfoFile
Tác giả: naturooo
Bài viết gốc: 448747
Tên lệnh: qf
Lisp Quick Filter: Lọc nhanh theo một số thuộc tính thông dụng

Thay vì lệnh Filter (FI) mặc định chọn rồi xoá xoá. Lisp Quick Filter (QF) này sẽ chọn một số thuộc tính thông dụng để lọc, giảm bớt vài thao tác thừa không cần thiết:

;; List Box  -  Lee Mac
;; Displays a DCL list box allowing the user to make a selection from the supplied data.
;; msg -  Dialog label
;; lst -  List of strings to display
;; bit -  1=allow...
>>

Thay vì lệnh Filter (FI) mặc định chọn rồi xoá xoá. Lisp Quick Filter (QF) này sẽ chọn một số thuộc tính thông dụng để lọc, giảm bớt vài thao tác thừa không cần thiết:

;; List Box  -  Lee Mac
;; Displays a DCL list box allowing the user to make a selection from the supplied data.
;; msg -  Dialog label
;; lst -  List of strings to display
;; bit -  1=allow multiple; 2=return indexes
;; Returns:  List of selected items/indexes, else nil
(defun LM:listbox ( msg lst bit / dch des tmp rtn )
    (cond
        (   (not
                (and
                    (setq tmp (vl-filename-mktemp nil nil ".dcl"))
                    (setq des (open tmp "w"))
                    (write-line
                        (strcat "listbox:dialog{label=\"" msg "\";spacer;:list_box{key=\"list\";multiple_select="
                            (if (= 1 (logand 1 bit)) "true" "false") ";width=50;height=15;}spacer;ok_cancel;}"
                        )
                        des
                    )
                    (not (close des))
                    (< 0 (setq dch (load_dialog tmp)))
                    (new_dialog "listbox" dch)
                )
            )
            (prompt "\nError Loading List Box Dialog.")
        )
        (   t     
            (start_list "list")
            (foreach itm lst (add_list itm))
            (end_list)
            (setq rtn (set_tile "list" "0"))
            (action_tile "list" "(setq rtn $value)")
            (setq rtn
                (if (= 1 (start_dialog))
                    (if (= 2 (logand 2 bit))
                        (mapcar '(lambda ( x ) (nth x lst)) (read (strcat "(" rtn ")")))
                        (read (strcat "(" rtn ")"))
                      ;  (mapcar '(lambda ( x ) (nth x lst)) (read (strcat "(" rtn ")")))
                    )
                )
            )
        )
    )
    (if (< 0 dch)
        (unload_dialog dch)
    )
    (if (and tmp (setq tmp (findfile tmp)))
        (vl-file-delete tmp)
    )
    rtn
)
;====================================Main Lisp: Quick Filter (QF)======================================
(defun C:QF (/ ss ss1 ob lyrname colr blkname txth txtn lstQF lstDCL lstidx lstfi a)
  (setq ss1 (entsel "\nSelect Object: "))
  (while (or
	   (null ss1)
	   (= "" (cdr (assoc 0 (entget (car ss1)))))
	 )
  (setq ss1 (entsel "\nSelect Object Again: "))
  )
  (setq ss (entget (car ss1)))

  (setq ob (cdr (assoc 0 ss)))
  (setq lstQF (list (cons 0 ob)))
  (if (= "INSERT" ob)
  	(setq lstDCL (list (strcat "Object           : " "Block")))
	(setq lstDCL (list (strcat "Object           : " ob)))
  );endif
  (setq lyrname (cdr (assoc 8 ss)))
  (setq lstQF (append lstQF (list (cons 8 lyrname))))
  (setq lstDCL (append lstDCL (list (strcat "Layer            : " lyrname))))
  (if (= 62 (car (assoc 62 ss)))
     (progn	
    	(setq colr (cdr (assoc 62 ss)))
        (setq lstQF (append lstQF (list(cons 62 colr))))
	(setq lstDCL (append lstDCL (list (strcat "Color            : " (rtos colr 2 0)))))
     );progn
	(progn
	(setq lstQF (append lstQF '((62 . 256))))
	(setq lstDCL (append lstDCL (list (strcat "Color            : " "256"))))
	)
  )					;end if
  (if (= 2 (car (assoc 2 ss)))
    (progn	
    	(setq blkname (cdr (assoc 2 ss)))
	(setq lstQF (append lstQF (list (cons 2 blkname))))
	(setq lstDCL (append lstDCL (list (strcat "Block Name       : " blkname))))
    );end progn
  )					;end if
  (if (= 40 (car (assoc 40 ss)))
    (progn	
    	(setq txth (cdr (assoc 40 ss)))
	(setq lstQF (append lstQF (list (cons 40 txth))))
	(setq lstDCL (append lstDCL (list (strcat "Text Height      : " (rtos txth)))))
    );end progn
  )					;end if
  (if (= 7 (car (assoc 7 ss)))
    (progn	
    	(setq txtn (cdr (assoc 7 ss)))
	(setq lstQF (append lstQF (list (cons 7 txtn))))
	(setq lstDCL (append lstDCL (list (strcat "Text Style Name  : " txtn))))
    );end progn
  )					;end if
 (setq lstidx (LM:listbox "Selection to Filter:" lstDCL 1))
 (foreach a lstidx
	(setq lstfi (append lstfi (list (nth a lstQF))))
 )
(sssetfirst nil (ssget lstfi))
(Print "Write by: NghiaKieu")
(princ)
)

 


<<

Filename: 448747_qf.lsp
Tác giả: ttbinh54
Bài viết gốc: 164366
Tên lệnh: tinhthang
Vẽ thang bằng lisp

Bạn mệt mỏi khi phải dóng để vẽ mặt đứng thang phức tạp?

 

Hãy để lisp tính thang của CADViet giúp bạn phần nào....

>>

Bạn mệt mỏi khi phải dóng để vẽ mặt đứng thang phức tạp?

 

Hãy để lisp tính thang của CADViet giúp bạn phần nào. Bạn copy đoạn code dưới đây vào file một file lisp rồi appload lên và dùng lệnh tinhthang.

 

(defun c:tinhthang()
(defun l2bac(ent)
(setq
tt (entget ent)
p1 (cdr (assoc 10 tt))
p2 (cdr (assoc 11 tt))
)
(list p1 p2)
)
(setq
ssbac (ssget '((0 . "LINE")))
hbac (getdist "\nChieu cao bac")
lstent (ss2ent ssbac)
ttbac (mapcar 'l2bac lstent)
index 0.0
)
(command ".3dmesh")
(command (* 2 (length lstent)) 2)
(foreach pp ttbac
(setq
caoht (* index hbac)
index (+ index 1.0)
p1 (car pp)
p2 (cadr pp)
x1 (car p1)
y1 (cadr p1)
x2 (car p2)
y2 (cadr p2)
za caoht
zb (+ caoht hbac)
p1a (list x1 y1 za)
p1b (list x1 y1 zb)
p2a (list x2 y2 za)
p2b (list x2 y2 zb)
)
(command p1a p2a p1b p2b)
)
)
(defun ss2ent(ss / sodt index lstent)
(setq
sodt (if ss (sslength ss) 0)
index 0
)
(repeat sodt
(setq ent (ssname ss index)
index (1+ index)
lstent (cons ent lstent)
)
)
(reverse lstent)
)

 

Đầu tiên là mặt bằng của bạn:

Thang01.gif

 

bạn đổi viewport để xem dạng phối cảnh:

thang02.gif

 

dùng lệnh tinhthang để vẽ 3d của bậc thang:

thang03.gif

 

dùng lệnh shade để xem thang dạng có diện:

thang04.gif

 

Xoay để lấy mặt đứng biên:

thang05.gif

 

Lệnh tính thang không thể vẽ kỹ được thang cho bạn, nhưng chắc chắn nó sẽ giúp bạn làm những thao tác cơ bản để có được những nét phôi của thang. Từ đó bạn sẽ thêm nét để trở thành mặt chiếu hay phối cảnh của thang.

 

Rất mong có được sự hồi âm sau khi sử dụng Lisp.

Anh Hoanh ơi , Autolisp của Anh hay lắm nhưng mà Em vẽ nó cú dính nhau ấy , Anh chỉ Em với ? hic


<<

Filename: 164366_tinhthang.lsp
Tác giả: naturooo
Bài viết gốc: 448775
Tên lệnh: selectbycolour
Lisp Quick Filter: Lọc nhanh theo một số thuộc tính thông dụng
11 giờ trước, vanlam6408 đã nói:
>>
11 giờ trước, vanlam6408 đã nói:

vâng.hi

(defun c:SelectByColour ( / c d e l )
   (if (setq e (car (entsel)))
       (progn
           (setq c
               (cond
                   (   (cdr (assoc 62 (entget e)))   )
                   (   (abs (cdr (assoc 62 (tblsearch "LAYER" (cdr (assoc 8 (entget e)))))))   )
               )
           )                     
           (while (setq d (tblnext "LAYER" (null d)))
               (if (= c (abs (cdr (assoc 62 d))))
                   (setq l (cons "," (cons (cdr (assoc 2 d)) l)))
               )
           )
           (sssetfirst nil
               (ssget "_X"
                   (if l
                       (list
                           (cons -4 "<OR")
                               (cons 62 c)
                               (cons -4 "<AND")
                                   (cons 62 256)
                                   (cons 8 (apply 'strcat (cdr l)))
                               (cons -4 "AND>")
                           (cons -4 "OR>")
                       )
                       (list (cons 62 c))
                   )
               )
           )
       )
   )
   (princ)
)

Mình tìm thấy cái chọn màu kể cả By layer của Lee Mac đây. Để lúc nào m thêm tuỳ chọn chọn cả theo màu của layer xem sao :)


<<

Filename: 448775_selectbycolour.lsp
Tác giả: dunguss3581
Bài viết gốc: 448794
Tên lệnh: a22
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)
(defun c:a22 ( / sel :n e1 e1n poly POLY_vl Dx Dy Lp List_vert_poly
                list_p_int P_center dist step1 step2 bienchung)

    (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))   
    
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;mmmmmmmmmmmmmmmmmmmmmmmmmmmm......../////////////////////////////

(if (setq chonlinepolyline (ssget '((-4 . "<OR
>>
(defun c:a22 ( / sel :n e1 e1n poly POLY_vl Dx Dy Lp List_vert_poly
                list_p_int P_center dist step1 step2 bienchung)

    (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))   
    
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;mmmmmmmmmmmmmmmmmmmmmmmmmmmm......../////////////////////////////

(if (setq chonlinepolyline (ssget '((-4 . "<OR")(0 . "LINE")(0 . "CIRCLE")(0 . "SPLINE")(0 . "ARC")(0 . "ELLIPSE")(0 . "*POLYLINE")(-4 . "OR>"))))
    (progn   
      (setq chonpolyline (ssadd))
      (setq lsppolyline nil)
      (setq i 0)
      (repeat (sslength chonlinepolyline)
    (taopolyline (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
               (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
              10000)) "0" 1)
    (ssadd (entlast) chonpolyline)
    (setq lsppolyline (append lsppolyline (list (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
                              (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
                             10000)))))
    (setq i (+ i 1))
    )
      (setq lspgiaodiem (LM:IntersectionsInSet chonpolyline))
      (setq chonline (ssadd))
      (setq lspchonline nil)
      (setq lsp2diemline nil)
      (foreach lsp lsppolyline
    (foreach diemgiao lspgiaodiem
      (setq lsp (DDH:pointtolsppoint diemgiao lsp))
      )
    (setq i 0)
    (repeat (- (length lsp) 1)
      (setq lsp2diemline (append lsp2diemline (list (list (nth i lsp) (nth (+ i 1) lsp)))))
      (setq i (+ i 1))
      )
    )
      (setq lsp2diemline (LM:Uniqueline lsp2diemline))
      (foreach line lsp2diemline
    (entmakex (list '(0 . "LINE")
            (cons 10 (car line))
            (cons 11 (cadr line))
            ))
    (ssadd (entlast) chonline)
    (setq lspchonline (append lspchonline (list (vlax-ename->vla-object (entlast)))))
    )
      (or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object))))
      (setq ms (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
      (if (setq lsptongregion (vlax-invoke ms 'AddRegion lspchonline))
    (progn
      (command "ERASE" chonline "")
      (command "ERASE" chonpolyline "")
      (setq lspxetbien nil)
      (foreach tungregion lsptongregion
        (setq lspxetbien (append lspxetbien (list (list (vlax-vla-object->ename tungregion) (vlax-get-property tungregion 'area)))))
        )
      (setq lspxetbien (vl-sort lspxetbien (function (lambda (e1 e2) (> (cadr e1) (cadr e2))))))
        (setq rt (FiltReg lspxetbien))
      (foreach r rt
            (setq lspxetbien (vl-remove r lspxetbien))
        (entdel (car r))
      )
            
      (setq mau 0)
      (foreach xetpl lspxetbien
            (setq mau (1+ (rem mau 255)))
	    (setq bienchung (car xetpl))
	    (1re2pl bienchung)
	    (setq e1 (entlast))
	    (setq mau (+ mau 1))
;                                                            

    (if (and
            ;(princ "\nSelect objects (caloaidoituong): ")

	  )
      (Progn
		(cond
                    ( (= "LWPOLYLINE" (cdr (assoc 0 (entget e1)))) (poly_c e1) )
                    ( t (setq P_center (cdr (assoc 10 (entget e1)))))
                )
                (entmake
                    (list
                        (cons 0 "TEXT")
                        (cons 8 (getvar "clayer"))
                        (cons 7 (getvar "textstyle"))
                        (cons 10 P_center)
                        (cons 11 P_center)
                        (cons 40 (getvar "textsize"))
                        (cons 72 1)
                        (cons 73 2)
                        (cons 1 (rtos (vlax-curve-getArea e1) 2 1))
                    )
                )
		(command "ERASE" e1 "")
     )
        (alert "No valid object selected")
    )
    (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))   
    (princ)
  ;;;;;;;;;;;;;;;;;;;;;;;;;;bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb
	)
      )
)
)
)
)

Bác xem giúp nhé bệnh nhân đây. tiện bác xem giúp em cho lisp chạy nhanh hơn không chứ nó chạy chậm quá. Thanks!


<<

Filename: 448794_a22.lsp
Tác giả: Danh Cong
Bài viết gốc: 448745
Tên lệnh: vtt
nhờ viết list (viết list vẽ nhiều đường nối thép liên tiếp)
Vào lúc 12/8/2020 tại 13:54, xuanquoc đã nói:

anh cho e xin...

>>
Vào lúc 12/8/2020 tại 13:54, xuanquoc đã nói:

anh cho e xin với ạ, cảm ơn anh nhiều ( email: xuanquocxd@gmail.com)

Gửi cho bạn. Lisp chỉ áp dụng trong trường hợp nối thẳng. Chiều dài mối nối được quy định trong Lisp. Khoảng cách giữa các thanh nối phụ thuộc vào tỷ lệ Scale của dim.



(defun c:VTT (/ d L40 X1 Y1 PT-end X-end Y-end scale L_Tieuchuan L PT1 PT2)
(Princ "Write by: Do Danh Cong")
(command "undo" "begin")
(setq L_TieuChuan
       (list
     (cons 10 450)
     (cons 12 540)
     (cons 14 630)
     (cons 16 720)
     (cons 18 810)
     (cons 20 900)
     (cons 22 990)
     (cons 25 1125)
     (cons 28 1260)
     (cons 32 1455)))

;;;;; So lieu dau vao
  (setq L (getdist "Nhap chieu dai / Chon 2 diem: "))
;;;;;; Luu gia tri duong kinh
  (or #VTT_D (setq #VTT_D 16))
  (setq #VTT_D (cond ((getreal (strcat "\nNhap D= < " (rtos #VTT_D 2 0) " >:")))(#VTT_D)))
  (setq    Pt1 (getpoint "\n Nhap diem ve: "))
  (setq scale (getvar "dimscale"))
  
  ;;;;; Tinh toan so lieu:
  
  (setq L40 (cdr (assoc #VTT_D L_TieuChuan))
    X1 (car Pt1)
    Y1 (cadr Pt1)
    PT-end (Polar Pt1 0 L)
    X-end (car Pt-end)
    Y-end (cadr Pt-end))
  ;;;;;; Ve thep

  (While  (> X-end X1)
          (if (>= 11700 (- X-end X1))
        (progn
              (command ".line" "non" Pt1 "non" Pt-End "")
              (setq X1  X-End))
        (Progn
              (setq Pt2 (polar Pt1 0 11700))
          (command ".line" "non" Pt1 "non" Pt2 "")
          (setq X1 (- (car Pt2) L40)
            Y1 (+ (cadr Pt1) (* 1.5 scale))
            Pt1 (list X1 Y1)
                    PT-end (list X-end Y1))
          )
      ))
  (command "undo" "end")
  (Princ))


<<

Filename: 448745_vtt.lsp
Tác giả: naturooo
Bài viết gốc: 448803
Tên lệnh: qf
Lisp Quick Filter: Lọc nhanh theo một số thuộc tính thông dụng
22 giờ trước, vanlam6408 đã nói:

vâng,mong là qf sẽ sớm được...

>>
22 giờ trước, vanlam6408 đã nói:

vâng,mong là qf sẽ sớm được hoàn thiện nhất.hi

Đã chế lại màu lọc theo True Color (màu hiển thị). Bạn thử xem có lỗi gì k nhé!

;; List Box  -  Lee Mac
;; Displays a DCL list box allowing the user to make a selection from the supplied data.
;; msg -  Dialog label
;; lst -  List of strings to display
;; bit -  1=allow multiple; 2=return indexes
;; Returns:  List of selected items/indexes, else nil
(defun LM:listbox (msg lst bit / dch des tmp rtn)
  (cond
    ((not
       (and
	 (setq tmp (vl-filename-mktemp nil nil ".dcl"))
	 (setq des (open tmp "w"))
	 (write-line
	   (strcat "listbox:dialog{label=\""
		   msg
		   "\";spacer;:list_box{key=\"list\";multiple_select="
		   (if (= 1 (logand 1 bit))
		     "true"
		     "false"
		   )
		   ";width=50;height=15;}spacer;ok_cancel;}"
	   )
	   des
	 )
	 (not (close des))
	 (< 0 (setq dch (load_dialog tmp)))
	 (new_dialog "listbox" dch)
       )
     )
     (prompt "\nError Loading List Box Dialog.")
    )
    (t
     (start_list "list")
     (foreach itm lst (add_list itm))
     (end_list)
     (setq rtn (set_tile "list" "0"))
     (action_tile "list" "(setq rtn $value)")
     (setq rtn
	    (if	(= 1 (start_dialog))
	      (if (= 2 (logand 2 bit))
		(mapcar	'(lambda (x) (nth x lst))
			(read (strcat "(" rtn ")"))
		)
		(read (strcat "(" rtn ")"))
		;  (mapcar '(lambda ( x ) (nth x lst)) (read (strcat "(" rtn ")")))
	      )
	    )
     )
    )
  )
  (if (< 0 dch)
    (unload_dialog dch)
  )
  (if (and tmp (setq tmp (findfile tmp)))
    (vl-file-delete tmp)
  )
  rtn
)
;====================================Main Lisp: Quick Filter (QF) Update 19/08/2020 Loc theo "True Color"======================================
(defun C:QF (/	    ss	   ss1	  ob	 lyrname       colr   blkname
	     txth   txtn   lstQF  lstDCL lstidx	lstfi  a      c
	     d	    l
	    )
  (setq ss1 (entsel "\nSelect Object: "))
  (while (or
	   (null ss1)
	   (= "" (cdr (assoc 0 (entget (car ss1)))))
	 )
    (setq ss1 (entsel "\nSelect Object Again: "))
  )
  (setq ss (entget (car ss1)))
  (setq ob (cdr (assoc 0 ss)))
  (setq lstQF (list (cons 0 ob)))
  (if (= "INSERT" ob)
    (setq lstDCL (list (strcat "Object           : " "Block")))
    (setq lstDCL (list (strcat "Object           : " ob)))
  );endif
  (setq lyrname (cdr (assoc 8 ss)))
  (setq lstQF (append lstQF (list (cons 8 lyrname))))
  (setq	lstDCL (append lstDCL
		       (list (strcat "Layer            : " lyrname))
	       )
  )

  (setq	c
	 (cond
	   ((cdr (assoc 62 ss)))
	   ((abs (cdr (assoc 62 (tblsearch "LAYER" (cdr (assoc 8 ss)))))
	    )
	   )
	 )
  )

  (while (setq d (tblnext "LAYER" (null d)))
    (if	(= c (abs (cdr (assoc 62 d))))
      (setq l (cons "," (cons (cdr (assoc 2 d)) l)))
    )
  )
(setq lstQF (append lstQF (list "True Color")))
  (setq	lstDCL (append lstDCL (list (strcat "True Color       : " (rtos c 2 0)))  )  )
  (if (= 2 (car (assoc 2 ss)))
    (progn
      (setq blkname (cdr (assoc 2 ss)))
      (setq lstQF (append lstQF (list (cons 2 blkname))))
      (setq
	lstDCL (append lstDCL
		       (list (strcat "Block Name       : " blkname))
	       )
      )
    )					;end progn
  )					;end if
  (if (= 40 (car (assoc 40 ss)))
    (progn
      (setq txth (cdr (assoc 40 ss)))
      (setq lstQF (append lstQF (list (cons 40 txth))))
      (setq lstDCL
	     (append lstDCL
		     (list (strcat "Text Height      : " (rtos txth)))
	     )
      )
    )					;end progn
  )					;end if
  (if (= 7 (car (assoc 7 ss)))
    (progn
      (setq txtn (cdr (assoc 7 ss)))
      (setq lstQF (append lstQF (list (cons 7 txtn))))
      (setq lstDCL (append lstDCL
			   (list (strcat "Text Style Name  : " txtn))
		   )
      )
    );end progn
  );end if
  (setq lstidx (LM:listbox "Selection to Filter:" lstDCL 1))
  (if lstidx
    (progn
      (foreach a lstidx
	(if (= "True Color" (nth a lstQF))
		(if l
   			(setq lstfi (append lstfi
    			  (list
      				(cons -4 "<OR")
      				(cons 62 c)
      				(cons -4 "<AND")
      				(cons 62 256)
      				(cons 8 (apply 'strcat (cdr l)))
      				(cons -4 "AND>")
      				(cons -4 "OR>")
    			  )
   			))
   			(setq lstfi (append lstfi
    			  (list (cons 62 c))
   			))
 		)
		(setq lstfi (append lstfi (list (nth a lstQF))))
      )
    )
      (sssetfirst nil (ssget lstfi))
    )
  )
  (Print "Write by: NghiaKieu")
  (princ)
)

 


<<

Filename: 448803_qf.lsp
Tác giả: huunhantvxdts
Bài viết gốc: 447790
Tên lệnh: ii
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

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

Tôi có lisp bo viền 1 khung tên, nhưng...

>>
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
    lisp help
  •  

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

 


<<

Filename: 447790_ii.lsp
Tác giả: thanhduan2407
Bài viết gốc: 156363
Tên lệnh: mkatb
viết lisp đánh số các đọan thẳng?

Hề hề hề,

Bạn thật là ?????????

Mình đã sửa theo ý bạn song mình sẽ không chịu trách nhiệm sửa nữa nếu như...

>>

Hề hề hề,

Bạn thật là ?????????

Mình đã sửa theo ý bạn song mình sẽ không chịu trách nhiệm sửa nữa nếu như trên bản vẽ của bạn có sẵn một block tên test mà không đúng với cái block thuộc tính bạn yêu cầu. Khi đó nếu bạn muốn sửa thì hãy tự sửa nhé vì mình vẫn để các dòng code cũ lại chỉ vô hiệu hóa chúng mà thôi.

Hy vọng bạn sẽ không còn thắc mắc nữa....

(defun C:mkatb (/ oldos col pt e1 e2 ten plst plst1 dlst j j1 i i1 n n1 m ssl ssl1 p p1 d d1 d2 k k1 ss1 ss2 ss3 goc)
(vl-load-com)
(command "undo" "be")
(setq oldos (getvar "osmode"))
(setq col (getvar "cecolor"))
(setvar "angdir" 0)
(setq pt (getpoint "\n Chon diem chuan"))
(setvar "osmode" 0)
(setvar "cecolor" "4")
(if (not (tblsearch "block" "test"))
(progn
(command "attdef" "" "tt" "Nhap so" "" "j" "MC" pt "250" "0" )
(setq e1 (entlast))
(setvar "cecolor" col)
(command "circle" pt 300)
(setq e2 (entlast))
;;;;;;;;(if (tblsearch "block" "test")
;;;;;;;;    (progn
;;;;;;;;    (setq ten (getstring t "\n Nhap ten block moi: "))
;;;;;;;;    (command "rename" "b" "test" ten)
;;;;;;;;    )
;;;;;;;;)
(command "block" "test" pt e1 e2 "" )
)
)
(setq plst (list)
       dlst (list)
        j (getint "\n Nhap gia tri so bat dau danh so: ")
        m (getstring t "\n Nhap cac ky tu di kem: ")
)
(prompt "\n Chon tap doi tuong doan thang theo phuong x")
(setq ssl (acet-ss-to-list (ssget (list (cons 0 "*line")))))
(setq j1 j)
(if ssl
(progn
(foreach x ssl
      (if (/= (cdr (assoc 0 (entget x))) "LINE")
      (setq p (vlax-curve-getpointatparam (vlax-ename->vla-object x) 0.5)
              d (vlax-curve-getdistatparam (vlax-ename->vla-object x) 1)
              plst (append plst (list (list p d)))               
      )
      (setq p (acet-geom-midpoint (cdr (assoc 10 (entget x))) (cdr (assoc 11 (entget x))))
              d (distance (cdr (assoc 10 (entget x))) (cdr (assoc 11 (entget x))))
              plst (append plst (list (list p d)))
      )
      )      
)
;;;;;;;;(setq ans (getstring t "\n Ban muon danh so theo phuong nao? <X or Y>: "))
;;;;;;;;(if (= (strcase ans) "Y")
;;;;;;;    (progn
;;;;;;;           (setq plst (vl-sort plst '(lambda (y1 y2) (< (car (car y1)) (car (car y2))))))
;;;;;;;           (setq goc "90")
;;;;;;;    )
;;;;;;;    (progn
(setq plst (vl-sort plst '(lambda (y1 y2) (< (cadr (car y1)) (cadr (car y2))))))
(setq goc "")
;;;;;;;    )
;;;;;;;)

(setq n (length plst)
        i 0

        p1 (car (nth i plst))
)
(command "insert" "test"  p1 "" "" goc (strcat (rtos j 2 0) m) )
(setq 
       d1 (cadr (nth i plst))
       dlst (cons d1 dlst))
(while (< i (1- n))
     (setq d2 (cadr (nth (1+ i) plst)))

     (if (setq k (vl-position d2 dlst))
         (progn
                (setq k1 (vl-position d2 (reverse dlst)))
                (setq p1 (car (nth (1+ i) plst)))
                (command "insert" "test"  p1 "" "" goc (strcat (rtos (+ k1 j1) 2 0) m) )
         )
         (progn
                (setq dlst (cons d2 dlst))
                (command "insert" "test"  (car (nth (1+ i) plst)) "" "" goc (strcat (rtos (setq j (1+ j)) 2 0) m) )
         )
     )
     (setq i (1+ i))
)
)
(setq j (1- j))     
)

(setq ss1 (ssget "x" (list (cons 0 "insert") (cons 2 "test"))))

(prompt "\n Chon tap doi tuong doan thang theo phuong y")
(setq ssl1 (acet-ss-to-list (ssget (list (cons 0 "*line")))))
(setq plst1 (list))
(if ssl1
(progn
(foreach x ssl1
      (if (/= (cdr (assoc 0 (entget x))) "LINE")
      (setq p (vlax-curve-getpointatparam (vlax-ename->vla-object x) 0.5)
              d (vlax-curve-getdistatparam (vlax-ename->vla-object x) 1)
              plst1 (append plst1 (list (list p d)))               
      )
      (setq p (acet-geom-midpoint (cdr (assoc 10 (entget x))) (cdr (assoc 11 (entget x))))
              d (distance (cdr (assoc 10 (entget x))) (cdr (assoc 11 (entget x))))
              plst1 (append plst1 (list (list p d)))
      )
      )      
)
(setq plst1 (vl-sort plst1 '(lambda (y1 y2) (< (car (car y1)) (car (car y2))))))
(setq goc "90")
(setq n1 (length plst1)
        i1 0)
(while (< i1  n1)
     (setq d2 (cadr (nth  i1 plst1)))

     (if (setq k (vl-position d2 dlst))
         (progn
                (setq k1 (vl-position d2 (reverse dlst)))
                (setq p1 (car (nth  i1 plst1)))
                (command "insert" "test"  p1 "" "" goc (strcat (rtos (+ k1 j1) 2 0) m) )
         )
         (progn
                (setq dlst (cons d2 dlst))
                (command "insert" "test"  (car (nth  i1 plst1)) "" "" goc (strcat (rtos (setq j (1+ j)) 2 0) m) )
         )
     )
     (setq i1 (1+ i1))
)
)
)

(setq ss2 (ssget "x" (list (cons 0 "insert") (cons 2 "test"))))
(setq ss3 (ACET-SS-REMOVE ss1 ss2))


;;;;;(if (= (strcase ans) "Y")
   (command "move" ss3 "" p1 (list (- (car p1) 300) (cadr p1) (caddr p1)))
   (command "move" ss1 "" p1 (list (car p1) (+ (cadr p1) 300) (caddr p1)))
;;;;;;)
(setvar "osmode" oldos)
(command "undo" "e")      
(princ)

)

Thấy bác Bình viết lách đêm khuya mà thấy tội cho bác Bình quá. Bác thiệt là con người nhiệt tình và đam mê lisp. Thiết nghĩ BQT Admin nên có phương án bồi dưỡng cho anh em viết Lisp khi có ai yêu cầu. Ai yêu cầu thì phải có phần thưởng cho những ai viết thành công yêu cầu của người đó. Chớ không chỉ vì tính đam mê Lisp mà làm ảnh hưởng sức khỏe anh em trong khi đó người yêu cầu ngủ ngon mà ko hay biết. Chúng ta nên có phương án lập 1 Topic mới cho đề án này. Bác Bình và mọi người giữ gìn sức khỏe nha.

P\s: Ketxu là người thích cái phần quà này lắm vì hay viết lisp mừ. :rolleyes:


<<

Filename: 156363_mkatb.lsp
Tác giả: tientracdia
Bài viết gốc: 333641
Tên lệnh: pt
Lisp ghi toạ độ điểm ra màn hình !!!

 

Thêm STT đây!

(defun c:pt (/ p lst fn pw n)
 (while (setq p (getpoint "\nPick Point: "))
  (setq lst...
>>

 

Thêm STT đây!

(defun c:pt (/ p lst fn pw n)
 (while (setq p (getpoint "\nPick Point: "))
  (setq lst (cons p lst)))
 (setq fn (getfiled "Chon file de xuat ket qua" "" "csv" 1))
 (setq pw (open fn "w"))
 (setq n 1)
 (write-line "STT,Y,X" pw)
 (foreach p (reverse lst)
  (write-line (strcat (itoa n) "," (rtos (cadr p) 2 2) "," (rtos (car p) 2 2)) pw)
  (setq n (1+ n)))
 (close pw)
 (princ))

Nhờ anh chỉnh thêm kí hiệu nút tại điểm chọn, ghi số Thứ tự, xuất ra bảng trên cad va excel. Cám ơn


<<

Filename: 333641_pt.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 124278
Tên lệnh: vb
Tạo đường bao cho các đường kín
Như thế này phải không?

(defun c:vb ( / MakeRectang LST)
(defun MakeRectang (PT1 PT2 Linetype LTScale Layer Color xdata)
(entmakex (list '(0 . "LWPOLYLINE")
 '(100 ....
>>
Như thế này phải không?

(defun c:vb ( / MakeRectang LST)
(defun MakeRectang (PT1 PT2 Linetype LTScale Layer Color xdata)
(entmakex (list '(0 . "LWPOLYLINE")
 '(100 . "AcDbEntity")
 (cons 8 (if Layer Layer (getvar "Clayer")))
 (cons 6 (if Linetype Linetype "bylayer"))
 (cons 48 (if LTScale LTScale 1))
 (cons 62 (if Color Color 256))
 '(100 . "AcDbPolyline")
 (cons 90 4)
 (cons 70 1)
 (cons 10 PT1)
 (cons 10 (list (car PT1) (cadr PT2)))
 (cons 10 PT2)
 (cons 10 (list (car PT2) (cadr PT1))))))
(prompt "Chon cac doi tuong can ve duong bao")
(setq LST (ACET-GEOM-SS-EXTENTS-FAST (ssget)))
(MakeRectang (car LST) (cadr LST) nil nil nil nil nil)
(princ))

Chú ý: cái này vẽ đuờng bao cho mọi đối tuợng bất kỳ

Ồ không, như thế này cơ! (http://www.cadviet.com/upfiles/3/ve_duong_bao.dwg)


<<

Filename: 124278_vb.lsp
Tác giả: thanhduan2407
Bài viết gốc: 383051
Tên lệnh: ctth
Chọn Tất Cả Các Text Trên Một Đường Thẳng!

Nếu bạn Move thì xài cái này xem.

(defun c:CTTH (/ L1 L2  PNT SSTEXT STT X)
  (vl-load-com)
  (setvar "CMDECHO" 0)
  (setq ssText (ssget (list (cons 0 "TEXT"))))
  (setq L1 (LM:ss->ent ssText))
  (setq
    Pnt	(TD:Text-Base (car (entsel "\nChon Text chuan lam mau: ")))
  )
  (if Pnt
    (setq L2 (vl-remove
	       nil
	       (mapcar '(lambda	(x)
			  (if (or (equal (car Pnt)
					 (car...
>>

Nếu bạn Move thì xài cái này xem.

(defun c:CTTH (/ L1 L2  PNT SSTEXT STT X)
  (vl-load-com)
  (setvar "CMDECHO" 0)
  (setq ssText (ssget (list (cons 0 "TEXT"))))
  (setq L1 (LM:ss->ent ssText))
  (setq
    Pnt	(TD:Text-Base (car (entsel "\nChon Text chuan lam mau: ")))
  )
  (if Pnt
    (setq L2 (vl-remove
	       nil
	       (mapcar '(lambda	(x)
			  (if (or (equal (car Pnt)
					 (car (TD:Text-Base x))
					 0.000000001
				  )
				  (equal (cadr Pnt)
					 (cadr (TD:Text-Base x))
					 0.000000001
				  )
			      )
			    x
			    nil
			  )
			)
		       L1
	       )
	     )
    )
  )
  (command "Move" (CV:List-to-ss L2) "" Pause Pause)
  (princ)
)




(defun TD:Text-Base (ent / MA71 MA72 X11)
  (setq Ma10 (cdr (assoc 10 (entget ent))))
  (setq Ma11 (cdr (assoc 11 (entget ent))))
  (setq X11 (car Ma11))
  (setq Ma71 (cdr (assoc 71 (entget ent))))
  (setq Ma72 (cdr (assoc 72 (entget ent))))
  (if (or (and (= Ma71 0) (= Ma72 0) (= X11 0))
	  (and (= Ma71 0) (= Ma72 3))
	  (and (= Ma71 0) (= Ma72 5))
      )
    Ma10
    Ma11
  )
)

(defun LM:ss->ent (ss / i l)
  (if ss
    (repeat (setq i (sslength ss))
      (setq l (cons (ssname ss (setq i (1- i))) l))
    )
  )
)

(defun CV:List-to-ss (lst / ss)
  (setq ss (ssadd))
  (foreach item	lst
    (or	(= (type item) 'Ename)
	(setq item (vlax-vla-object->ename item))
    )
    (setq ss (ssadd item ss))
  )
  ss
)

<<

Filename: 383051_ctth.lsp
Tác giả: quochuyksxd
Bài viết gốc: 242159
Tên lệnh: ha
tìm lisp đo diện tích trong diễn đàn

 

Quick code cho bạn.

 

(defun C:HA( / ent1 ent2 elist)
 (vl-load-com)
 (while
  (and
   (setq ent1...
>>

 

Quick code cho bạn.

 

(defun C:HA( / ent1 ent2 elist)
 (vl-load-com)
 (while
  (and
   (setq ent1 (car (entsel "\nChon hinh kin: ")))
   (setq ent2 (car (entsel "\nChon Text de ghi: "))))
  (setq elist (entget ent2))
  (entmod (subst (cons 1 (rtos (vla-get-Area (vlax-ename->vla-object ent1)) 2 2)) (assoc 1 elist) elist)))
 (princ))
 

Cám ơn bác Hà nhé. đúng ý em luôn.


<<

Filename: 242159_ha.lsp
Tác giả: whatcholingon
Bài viết gốc: 169150
Tên lệnh: demo
Lisp cộng trừ text độ, phút, giây...

Ý định của mình là đưa ra đoạn code tham khảo, sau đó bạn có thể chỉnh sửa theo ý mình.

Mình làm lại cái theo đề nghị của...

>>

Ý định của mình là đưa ra đoạn code tham khảo, sau đó bạn có thể chỉnh sửa theo ý mình.

Mình làm lại cái theo đề nghị của bạn:

 

- Nhập tóan tử (+/-), mặc định là lần nhập trước nếu bỏ qua.

- Nhập text 1

- Nhập text 2

- Nhập điểm chèn kết quả

- Quay lại nhập text1 ... cho đến khi bỏ qua 1 bước nào đó.

 

à quên, cái này xuất ra dạng 00d00'00", nếu yêu cầu phải đúng định dạng như đầu vào thì phải thêm 1 đoạn nữa. Bác thấy có nhất thiết phải thế không?

 


(defun c:demo (/ e e1 e2 key)
(defun s2d (str / ret)
 (setq ret
 (vl-list->string
(vl-remove-if
 	'(lambda (x) (or (< x 48) (> x 57)))
 	(reverse (vl-string->list str))
)
 )
 )
 (angtof
(vl-list->string
 	(reverse
(vl-string->list
(strcat "\"" (substr ret 1 2) "'" (substr ret 3 2) "d" (substr ret 5))
   	)
 	)
)
 )
)

(if (not func) (setq func + #func " + "))
(setq key (getstring (strcat "\nEnter an option  <" #func">: ")))
(cond
 ((member key '("-" "_")) (setq #func " - ") (setq func -))
 ((member key '("+" "=")) (setq #func " + ")(setq func +))
)

(while
 (and  func
(setq e1 (car (entsel "\nChon text 1 <Exit>:?")))
(setq e1 (s2d (cdr (assoc 1 (setq e (entget e1))))))
(setq e2 (car (entsel (strcat "\nChon text 2  <Exit>:"))))
(setq e2 (s2d (cdr (assoc 1 (entget e2)))))
(setq p (Getpoint "\nDiem chen ket qua <exit>:"))
)
  	(setq e (subst (cons 10 p) (assoc 10 e) e))
  	(setq e (subst (cons 1  (angtos (func e1 e2) 1 4)) (assoc 1 e) e))
  	(entmake e)
 )
)

 

 

Bạn cho mình hỏi có thể đưa text độ phút giây ở dạng: 180,0000, 123,1232 không?

Tại vì mình làm bên khảo sát khi đưa số liệu ở máy toàn đạc ra thì nó ở dạng như vậy.

Thanks!


<<

Filename: 169150_demo.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 433876
Tên lệnh: test
Nhờ các bác tạo giúp lisp cộng trừ số của TEXT OVERRIDE DIm

 

 

5 giờ trước, vanhuyou đã nói:

>>

 

 

5 giờ trước, vanhuyou đã nói:

image.png.e7498d53517390e5b4f2b9020c165054.png

Bạn có thể thêm sửa lại là: hiện ra bảng thông báo hoặc ghi ra text được không. Cám ơn bạn.

Định không viết vì yêu cầu không rõ ràng và mơ hồ và cũng có bác nhắc nhưng tại cứ nghĩ đến lại thấy muốn làm, lên lại thấy bác Duy viết rồi, nhưng mất công viết nên vẫn đăng vậy

Untitled.png.cc10f5518a35cfeb35d36bfc6188ff91.png

(vl-load-com)
(defun c:test (/ ss tong ent ent1 ent2 ent3 lst nd lststr ketqua ovr a b c text id x y )
  (setq ss (acet-ss-to-list (ssget (list (cons 0 "*DIM*") ))))
	(setq lst (list))
	(foreach ent1 ss
	  (if (Vl-string-search "%%" (dxf 1 ent1)) (Progn
						(setq nd (substr (dxf 1 ent1) (+ (Vl-string-search "%%" (dxf 1 ent1)) 1)))
						(or (vl-position nd lst) (setq lst (append lst (list nd))))
						))
	  )
 
  (setq lststr (list))
    (setq lst (vl-sort lst '(lambda (x y) (< (atoi (substr x 4 (- (Vl-string-search "a" x) 3))) (atoi (substr y 4 (- (Vl-string-search "a" y) 3)))))))
								  
  (foreach ent2 lst
    
  (setq tong 0)
  (foreach ent ss
    (if (Vl-string-search ent2 (dxf 1 ent)) (progn
    (setq ovr (dxf 1 ent))
  (setq a (vl-string-search "X" ovr)
 	    b (vl-string-search "%%" ovr)) 
  (setq	c (substr ovr (+ a 2) (- b (1+ a)))
	tong (+ tong (atoi c)))

    )))
    (setq str (strcat (itoa tong) ent2))
    (setq lststr (append lststr (list str)))
    )
  (Setq ketqua "")
  

  (foreach ent3 lststr
    (setq ketqua (strcat ketqua "\n" ent3))
    )
    (if (and (setq text (car (entsel "\n Pick Text")))
	     (Wcmatch (cdr (assoc 0 (entget text))) "*TEXT"))
      (vla-put-textstring (vlax-ename->vla-object text) ketqua)
    (alert ketqua) )
)
(defun dxf (id ent)
  (cdr (assoc id (entget ent))))

 


<<

Filename: 433876_test.lsp
Tác giả: jangboko
Bài viết gốc: 406498
Tên lệnh: cl
Nhờ Sửa Lisp Tính Chu Vi

nhờ các bác sửa hộ em cái lisp tính chu vi này em đã mót ở trên diễn đàn 

(defun add_mline ()

  (foreach e_record_sub	e_record

    (cond ((= 10 (car e_record_sub))

	   (setq pt1	   (cdr e_record_sub)

		 mline_len 0.0

	   )

	  )

	  ((= 11 (car e_record_sub))

	   (setq pt2	   (cdr e_record_sub)

		 mline_len (+ mline_len (distance pt2 pt1))

		 pt1	   pt2

	   )

	  )

    )

  )

  (setq tot_len (+ tot_len mline_len))

 ...
>>

nhờ các bác sửa hộ em cái lisp tính chu vi này em đã mót ở trên diễn đàn 

(defun add_mline ()

  (foreach e_record_sub	e_record

    (cond ((= 10 (car e_record_sub))

	   (setq pt1	   (cdr e_record_sub)

		 mline_len 0.0

	   )

	  )

	  ((= 11 (car e_record_sub))

	   (setq pt2	   (cdr e_record_sub)

		 mline_len (+ mline_len (distance pt2 pt1))

		 pt1	   pt2

	   )

	  )

    )

  )

  (setq tot_len (+ tot_len mline_len))

  (ssdel e_name ss)

)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun C:cl (/ tot_len ss e_name e_record e_type)

  (setq tot_len 0.0)

  (setq ss (ssget))

  (if (null ss)

    (exit)

  )

  (while (> (sslength ss) 0)

    (setq e_name (ssname ss 0))

    (setq e_record (entget e_name))

    (setq e_type (cdr (assoc '0 e_record)))

    (cond ((wcmatch e_type "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")

	   (command "lengthen" e_name "")

	   (setq tot_len (+ tot_len (getvar "PERIMETER")))

	   (ssdel e_name ss)

	  )

	  ((wcmatch e_type "MLINE") (add_mline))

	  (e_type (ssdel e_name ss))

    )

  )

  (prompt (strcat "\nTotal length is: " (rtos tot_len 2 2)))

  (princ)

)
 

nhờ các bác bổ xung thêm cho em phần ghi kết quả ra text. Em cám ơn các bác nhiều nhiều 

P/s: em đã cố tìm trên diễn đàn cái lisp tính chu vi mà có ghi kết quả ra text mà không thấy, nên đành mạo muội nhờ các bác. Chúc các bác luôn mạnh khỏe để các anh em dùng cad được nhờ.


<<

Filename: 406498_cl.lsp
Tác giả: dnhqs
Bài viết gốc: 11555
Tên lệnh: gp
lấy thuộc tính từ block
Thông cảm với bạn vì attrib block là đối tượng phức tạp. Bạn mới làm quen với entity, lại chọn đúng cái phức tạp mà "chơi" nên lúng túng cũng phải!

Đoạn lisp sau lấy ra...

>>
Thông cảm với bạn vì attrib block là đối tượng phức tạp. Bạn mới làm quen với entity, lại chọn đúng cái phức tạp mà "chơi" nên lúng túng cũng phải!

Đoạn lisp sau lấy ra được các thuộc tính từ attrib block có tên "caodomoc" trong bản vẽ của bạn. Kết quả nhận được là:

p: toạ độ điểm chèn block, kiểu point (list có 3 thành phần)

CD_TN: cao độ hiện trạng, kiểu string

CD_TK: cao độ thiết kế, kiểu string

CH_CAO: độ chênh cao, kiểu string

Bạn có thể sử dụng chúng để làm gì tuỳ ý. Hàm alert cuối cùng chỉ là ví dụ, minh hoạ cho việc áp dụng các kết quả nhận được.

 

(defun C:GP() ;;;Get Properties
(setq
;;;Lay cac doi tuong trong attrib block
   e (car (entsel "\nSelect attrib block:"))
   e1 (entnext e)
   e2 (entnext e1)
   e3 (entnext e2)

;;;Lay toan bo data tu cac doi tuong tren
   d (entget e)
   d1 (entget e1)
   d2 (entget e2)
   d3 (entget e3)

;;;Lay ra cac gia tri can quan tam tu cac data
   p (cdr (assoc 10 d))
   CD_TN (cdr (assoc 1 d1))
   CD_TK (cdr (assoc 1 d2))
   CH_CAO (cdr (assoc 1 d3))
)

;;;Vi du minh hoa su dung cac gia tri nhan duoc
(alert
   (strcat
       "\nREPORT:"
       "\n\tCao do hien trang: " CD_TN
       "\n\tCao do thiet ke: " CD_TK
       "\n\tDo chenh cao: " CH_CAO
       "\n\tToa do diem chen block: " (rtos (car p)) "; " (rtos (cadr p)) "; " (rtos (caddr p))
   )
)
)

thực ra rất hấp dẫn, máy hôm nay đi công tác nên không online được

nhưng mình cũng lấy được thuộc tính rồi

bác xem thử nhé từ của bác nhưng mà mình làm theo kiểu "nhà quê:

 

;;;--------------------------------------------------------------------

(defun ss2ent (ss / i Le e) ;;;Convert ss to list of ename

(setq i 0 Le nil)

(repeat (sslength ss)

(setq

e (ssname ss i)

Le (append Le (list e))

i (1+ i)

)

)

Le

)

;;;--------------------------------------------------------------------

(defun getntv(sst p / Lt) ;;;Get Nearest Text Value in sst from p

(setq

Lt (ss2ent sst)

neap (lambda (x y)

(<

(distance p (cdr (assoc 10 (entget x))))

(distance p (cdr (assoc 10 (entget y))))

)

)

Lt (vl-sort Lt 'neap)

)

(cdr (assoc 1 (entget (car Lt))))

)

;;;--------------------------------------------------------------------

(defun C:UPH(/ e p t1 t2 t3 e1 e2 e3 d1 d2 d3) ;;;UPdate Height

(setq

e (car (entsel "\nSelect height block:")) ;;;Select block

p (cdr (assoc 10 (entget e))) ;;;Insert point of block

t1 (getntv (ssget "X" '((0 . "TEXT") (62 . 3))) p) ;;;Green text value nearest from p

t2 (getntv (ssget "X" '((0 . "TEXT") (62 . 1))) p) ;;;Red text value nearest from p

t3 (rtos (- (atof t2) (atof t1)) 2 2) ;;;Subtract

;t3 (rtos caotrinh 2 2)

e1 (entnext e) ;;;Attrib CD_TN entity

e2 (entnext e1) ;;;Attrib CD_TK entity

e3 (entnext e2) ;;;Attrib CH_CAO entity

 

d1 (entget e1) ;;;Get data1

tt1 (assoc 1 d1)

d1 (subst (cons 1 t1) (assoc 1 d1) d1) ;;;Change data1

d2 (entget e2) ;;;Get data2

tt2 d2

d2 (subst (cons 1 t2) (assoc 1 d2) d2) ;;;Change data2

d3 (entget e3) ;;;Get data3

d3 (subst (cons 1 t3) (assoc 1 d3) d3) ;;;Change data3

)

(entmod d1) ;;;Modify e1

(entmod d2) ;;;Modify e2

(entmod d3) ;;;Modify e3

(command "regen") ;;;Regenerating

(princ tt1)

(princ "\n")

(princ (+ 1 (atof (cdr tt1))))

(setvar "CECOLOR" "cyan")

(command ".text" "s" "Standard" "j" "bl" p 0 (+ 1 (atof (cdr tt1))) ^C^C)

 

(princ) ;;;Silent quit

)

;;;--------------------------------------------------------------------

hì hì


<<

Filename: 11555_gp.lsp
Tác giả: qh2qa06
Bài viết gốc: 304532
Tên lệnh: test
Xin lisp kiểm tra độ vênh của tấm BTXM

 

Bạn thử cái này, điều kiện là text canh trái, tấm là lwpolyline.

 

(defun c:test(/ ss ssl txt lwp...
>>

 

Bạn thử cái này, điều kiện là text canh trái, tấm là lwpolyline.

 

(defun c:test(/ ss ssl txt lwp canhngan caodo venh kq)
  (setq ss (ssget '((0 . "TEXT,LWPOLYLINE")))
ssl (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
txt (vl-remove-if '(lambda(x) (= "LWPOLYLINE" (cdr (assoc 0 (entget x))))) ssl)
lwp (car (vl-remove-if '(lambda(x) (= "TEXT" (cdr (assoc 0 (entget x))))) ssl)  )
lwp (mapcar 'cdr (vl-remove-if-not '(lambda(x) (= 10 (car x))) (entget lwp)))
lwp (mapcar '(lambda(z) (list z 
     (car (vl-sort txt '(lambda(x y) (< (distance (cdr (assoc 10 (entget x))) z)
(distance (cdr (assoc 10 (entget y))) z))))))) lwp)
lwp (mapcar '(lambda(x) (list (car x) (atof (cdr (assoc 1 (entget (last x))))))) lwp)
canhngan (min (distance (car (nth 0 lwp)) (car (nth 1 lwp)))
     (distance (car (nth 0 lwp)) (car (nth 3 lwp))))
caodo (mapcar 'cadr lwp)
venh (if (<= (setq kq (/ (abs (- (+ (nth 0 caodo) (nth 2 caodo)) (+ (nth 1 caodo) (nth 3 caodo)))) canhngan 1.0)) 0.01)
      (princ (strcat "\nDo venh = " (rtos kq) " <= 1%"))
      (princ (strcat "\nDo venh = " (rtos kq) " > 1%")))        
  ) (princ)  
)

Lisp của bạn đã đáp ứng yêu cầu của mình. Bạn có thể chỉnh giúp mình là lisp sẽ tính cạnh của hình chữ nhật từ vị trí của text luôn được không? Mình sẽ không phải vẽ hình chữ nhật nữa, giảm được một bước vì mặt bằng của mình rất rộng.

Cảm ơn bạn rất nhiều!


<<

Filename: 304532_test.lsp
Tác giả: Tue_NV
Bài viết gốc: 216259
Tên lệnh: h7
VIẾT LISP CHO DÂN CƠ KHÍ!

Dự án P1 đã hoàn thành! Kiểu này chắc kiếm khẳm "Like This" của dân Cơ khí rồi! :lol: :lol: :lol:

Hội đồng xem có góp ý gì...

>>

Dự án P1 đã hoàn thành! Kiểu này chắc kiếm khẳm "Like This" của dân Cơ khí rồi! :lol: :lol: :lol:

Hội đồng xem có góp ý gì không để tại hạ đáp ứng.

(defun C:H7( / ass ss entlst elst len dsai suff data exdata)
(setq ass (list '(0 3 0.0010) '(3 6 0.0012) '(6 10 0.0015) '(10 18 0.0018) '(18 30 0.0021) '(30 50 0.0025) '(50 80 0.0030)
                		'(80 120 0.0035) '(120 180 0.0040) '(180 250 0.0046) '(250 315 0.0052) '(315 400 0.0057)))
(regapp (setq appName "ACAD"))
(princ "\nChon cac Dim can ghi dung sai...")
(if (setq ss (ssget '((0 . "DIMENSION"))))
 (progn
  (setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
  (foreach ent entlst
   (setq elst (entget ent))
   (setq len (cdr (assoc 42 elst)))
   (foreach n ass
(if (and (> len (car n)) (<= len (cadr n)))
     (setq dsai (caddr n))))
   (setq suff (strcat "\\C5;\\H0.5X;\\S+" (rtos dsai 2 4) "^;"))
   (setq data (list (cons 1000 "DSTYLE") (cons 1002 "{") (cons 1070 3) (cons 1000 suff) (cons 1002 "}")))
   (setq exdata (list (list -3 (cons appName Data))))
   (setq elst (append elst exdata))
   (entmod elst))))
(princ))

Chưa xong đâu bác!

Cả "một khẳm H" đang chờ. hờ hờ


<<

Filename: 216259_h7.lsp
Tác giả: ngokiet
Bài viết gốc: 449715
Tên lệnh: nd
HELP !! Nhờ các cao thủ lisp nối tâm Block thành đường Polyline
(defun c:nd(/ ss tt st i)
  (or (setq ss (vl-sort (mapcar '(lambda(x) (cons (vla-get-EffectiveName (setq x (vlax-ename->vla-object x)))
					          (vlax-safearray->list(vlax-variant-value(vla-get-insertionpoint x)))))
			         (acet-ss-to-list (ssget '((0 . "INSERT")))))
		        '(lambda(x y) (if (eq (car x) (car y)) (< (caddr x) (caddr x)) (< (car x) (car y))))))
      (exit))
  (setq tt (list...
>>
(defun c:nd(/ ss tt st i)
  (or (setq ss (vl-sort (mapcar '(lambda(x) (cons (vla-get-EffectiveName (setq x (vlax-ename->vla-object x)))
					          (vlax-safearray->list(vlax-variant-value(vla-get-insertionpoint x)))))
			         (acet-ss-to-list (ssget '((0 . "INSERT")))))
		        '(lambda(x y) (if (eq (car x) (car y)) (< (caddr x) (caddr x)) (< (car x) (car y))))))
      (exit))
  (setq tt (list (car ss))
	i 1)
  (foreach x (append (cdr ss) '(nil))
    (if (eq (car x) (caar tt)) (setq tt (cons x tt))
      (progn
	(or (tblsearch "LAYER" (setq st (strcat "Noi Diem " (itoa i))))
	    (entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord")'(100 . "AcDbLayerTableRecord")
			   (cons 2 st) '(70 . 0))))
	(entmakex (vl-list* '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") (cons 8 st) '(100 . "AcDbPolyline")
				(cons 90 (length tt)) '(70 . 0)
			    (mapcar '(lambda (x)(cons 10 (cdr x))) tt)))
	(setq tt (list x)
	      i  (1+ i)))))
  (princ))

Viết nhanh .Sài đỡ.


<<

Filename: 449715_nd.lsp
Tác giả: qinaide
Bài viết gốc: 200943
Tên lệnh: mul sum
đo khoảng cách bằng chỉ bằng 1 lần rê chuột

 

Lisp của mình cần cũng tương tự như Link trên .Nhưng thay vì kết quả là tính "Sum" hay "Mul" thì của mình là "khoảng cách"...

>>

 

Lisp của mình cần cũng tương tự như Link trên .Nhưng thay vì kết quả là tính "Sum" hay "Mul" thì của mình là "khoảng cách" và đối tượng được chọn của mình là Line hoặc Pline chứ không phải là TEXT

( Ý mình là muốn đo khoảng cách giữa các đường màu đỏ, và kết quả mình sẽ chọn Text để ghi thay thế)

Các bác xem và chỉnh sửa hộ nhé !

;;;-----------------------------------------
(defun CheckObj(e MyType) (equal (cdr (assoc 0 (entget e))) MyType))
;;;-----------------------------------------
(defun FilObj(ss1 MyType / ss2 i e)
(setq ss2 (ssadd) i 0)
(repeat (sslength ss1)
   	(setq e (ssname ss1 i) i (1+ i))
   	(if (CheckObj e MyType) (ssadd e ss2) )
)
(eval ss2)
)
;;;-----------------------------------------
(defun SelData( / OK)
(setq OK nil)
(while (not OK)
(prompt "\tChon cac text can tinh:")
(setq ss (FilObj (ssget) "TEXT"))
(if (> (sslength ss) 0) (setq OK T) (princ "\nDoi tuong chon khong phai text"))
)
)
;;;-----------------------------------------
(defun WriteRes(kq / OK e data)
(setq OK nil)
(while (not OK)
(setq e (car (entsel "\tChon text ghi ket qua:")))
(if (CheckObj e "TEXT") (setq OK T) (princ "\nDoi tuong chon khong phai text"))
)
(entmod (subst (cons 1 (rtos kq)) (assoc 1 (setq data (entget e))) data))
(princ)
)
;;;-----------------------------------------
(defun C:MUL( / i m e ss)
(SelData) (setq i 0 m 1.0)
(repeat (sslength ss) (setq e (ssname ss i) i (1+ i) m (* m (atof (cdr (assoc 1 (entget e)))))))
(WriteRes m)
)
;;;-----------------------------------------
(defun C:SUM( / i s e ss)
(SelData) (setq i 0 s 0.0)
(repeat (sslength ss) (setq e (ssname ss i) i (1+ i) s (+ s (atof (cdr (assoc 1 (entget e)))))))
(WriteRes s)
)
;;;-----------------------------------------

thank!


<<

Filename: 200943_mul_sum.lsp

Trang 314/330

314