Jump to content
InfoFile
Tác giả: Tot77
Bài viết gốc: 313826
Tên lệnh: cca
tính chênh cao cho mắt lưới

Những cái text đó nằm gần nhau sẵn rồi cần gì hỏi nhập khoảng câch làm chi? tôi cho nó = 1 (kc tối đa)

bạn thử cái này. Tuy có thể quét chọn toàn bộ bản vẽ, nhưng để kiểm tra thì chỉ nên quét 1 phần tùy theo mắt bạn để tìm sự thay đổi trị số.

(defun c:cca (/ ss sstk sstn sscc v cdtk tm cc cdtn tm1)
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (defun...
>>

Những cái text đó nằm gần nhau sẵn rồi cần gì hỏi nhập khoảng câch làm chi? tôi cho nó = 1 (kc tối đa)

bạn thử cái này. Tuy có thể quét chọn toàn bộ bản vẽ, nhưng để kiểm tra thì chỉ nên quét 1 phần tùy theo mắt bạn để tìm sự thay đổi trị số.

(defun c:cca (/ ss sstk sstn sscc v cdtk tm cc cdtn tm1)
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (defun gan(v l)
    (car (vl-remove-if-not '(lambda(x) (< (distance (dxf 10 v) (dxf 11 x)) 1)) l))
  )
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex
(ssget '((0 . "TEXT") (8 . "CDTN,CDTK,CHENH CAO")))))) 
sstk (vl-remove-if-not '(lambda(x) (= (dxf 8 x) "CDTK")) ss)
sstn (vl-remove-if-not '(lambda(x) (= (dxf 8 x) "CDTN")) ss)
        sscc (vl-remove-if-not '(lambda(x) (= (dxf 8 x) "Chenh cao")) ss))
  (while sstk
    (setq v (car sstk)
 sstk (cdr sstk)
 cdtk (atof (dxf 1 v))
 tm   (gan v sstn)
 cc   (gan v sscc))
    (if (and tm cc)
       (setq  cdtn (atof (dxf 1 tm))
     sstn (vl-remove tm sstn) 
     sscc (vl-remove cc sscc)
     tm1 (entmod (subst (cons 1 (rtos (abs (* 100 (- cdtn cdtk))) 2 1)) (assoc 1 (entget cc)) (entget cc)))
)
    )   
  )
  (princ)
) 
 

<<

Filename: 313826_cca.lsp
Tác giả: thanhduan2407
Bài viết gốc: 313840
Tên lệnh: vtl2
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Em viết trải Taluy giữa 2 đường các anh ạ.

Em viết xong rồi. Chỉ nhờ trợ giúp 1 chút và tự làm thôi ạ

(defun C:VTL2 (  / Olmode Sovachngan  *Sovachngan* CDVN *CDVN*  CDDoan ObjPline1 ObjPL2 ObjPline2 VlaObjPline1 CDaiPLine1 VlaObjPline2
		   n d1 d2 LtsEnameLD LtsEnameLN Lts1 Lts2 LtsPntNgan   PntInObjPline2 PntInObjPline3 ang_1 ang_2 P3
	       )
(MakeLayer_ "TALUYN" 1)
(MakeLayer_ "TALUYD" 7)
(defun...
>>

Em viết trải Taluy giữa 2 đường các anh ạ.

Em viết xong rồi. Chỉ nhờ trợ giúp 1 chút và tự làm thôi ạ

(defun C:VTL2 (  / Olmode Sovachngan  *Sovachngan* CDVN *CDVN*  CDDoan ObjPline1 ObjPL2 ObjPline2 VlaObjPline1 CDaiPLine1 VlaObjPline2
		   n d1 d2 LtsEnameLD LtsEnameLN Lts1 Lts2 LtsPntNgan   PntInObjPline2 PntInObjPline3 ang_1 ang_2 P3
	       )
(MakeLayer_ "TALUYN" 1)
(MakeLayer_ "TALUYD" 7)
(defun *error* ( msg )
(if Olmode (setvar 'osmode Olmode))
(if (not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
    (princ (strcat "\nError: " msg))
)
(princ)
)
(setq Olmode (getvar "OSMODE"))
(setq Sovachngan 1)
(or *CDVN* (setq *CDVN* 2.5))
(setq CDVN (getreal (strcat "\nNh\U+1EADp kho\U+1EA3ng c\U+00E1ch gi\U+1EEFa c\U+00E1c v\U+1EA1ch: < "
			  (rtos *CDVN* 2 2)
			 " > :"
		    )
	 )
)
(if (not CDVN) (setq CDVN *CDVN*) (setq *CDVN* CDVN))
(setq CDDoan (* (+ Sovachngan 1) CDVN ))


  
(setq ObjPline1 (car (entsel "\nChon duong thu nhat: ")))
(setq ObjPL2  (entsel "\nChon duong thu hai: "))
(setq ObjPline2 (car ObjPL2))

(setq VlaObjPline1 (vlax-ename->vla-object ObjPline1))
(setq CDaiPLine1 (vla-get-length VlaObjPline1))


(setq VlaObjPline2 (vlax-ename->vla-object ObjPline2))
  
(setq n (fix (/ CDaiPLine1 CDDoan)))
(setq d1 0)
(setq Lts1 (list))
(setq LtsEnameLD (list))
(setq LtsEnameLN (list))
(while (< d1 CDaiPLine1)
	(progn
		(setq Ptd (vlax-curve-getPointAtDist VlaObjPline1 d1))
		(setq d1 (+ d1 CDDoan))
	  	(setq ang_1 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPline1 (vlax-curve-getParamAtPoint VlaObjPline1 Ptd))))
	  	(if (setq PntInObjPline2 (TDKDGN Ptd ObjPline2 (polar Ptd (+ ang_1 (/ pi 2) ) CDVN)))
		    (progn
	  	    	(entmake (list (cons 0 "LINE") (cons 8 "TALUYD") (cons 10  Ptd) (cons 11 PntInObjPline2)))
	  	    	(setq EnameLD (entlast))
	  		(setq LtsEnameLD (append LtsEnameLD (list EnameLD)))
	  		(setq Lts1 (append Lts1 (list Ptd)))
		    )
		)
	)
)
(setq d2 0)
(setq Lts2 (list))
(setq m (fix (/ CDaiPLine1 CDVN)))
(while (< d2 CDaiPLine1)
	(progn
		(setq Ptn_N (vlax-curve-getPointAtDist VlaObjPline1 d2))
		(setq d2 (+ d2 CDVN))
	  	(setq Lts2 (append Lts2 (list Ptn_N)))
	)
)
(setq LtsPntNgan (LM:ListDifference Lts2 Lts1))
(foreach Pnt1 LtsPntNgan
  	(setq ang_2 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPline1 (vlax-curve-getParamAtPoint VlaObjPline1 Pnt1))))
  	(if (setq PntInObjPline3 (TDKDGN Pnt1 ObjPline2 (polar Pnt1 (+ ang_2 (/ pi 2) ) CDVN)))
	    (progn
	  	(setq P3 (list (/ (+ (car Pnt1) (car PntInObjPline3)) 2) (/ (+ (cadr Pnt1) (cadr PntInObjPline3)) 2)))
	  	(entmake (list (cons 0 "LINE") (cons 10  Pnt1) (cons 8 "TALUYN") (cons 11 P3)))
	    )
	)
)
(princ)
)

(defun MakeLayer_ ( name colour /)
    (if (null (tblsearch "LAYER" name))
        (entmake
            (list
               '(0 . "LAYER")
               '(100 . "AcDbSymbolTableRecord")
               '(100 . "AcDbLayerTableRecord")
               '(70 . 0)
                (cons 2 name)
                (cons 62 colour)
            )
        )
    )
)

(defun LM:ListDifference ( l1 l2 )
  (if l1
    (if (member (car l1) l2)
      (LM:ListDifference (cdr l1) l2)
      (cons (car l1) (LM:ListDifference (cdr l1) l2))
    )
  )
)

(defun LM:Intersections ( obj1 obj2 mode / l r )
    (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
    (repeat (/ (length l) 3)
        (setq r (cons (list (car l) (cadr l) (caddr l)) r)
              l (cdddr l)
        )
    )
    (reverse r)
)

(defun MakeXline (pt vec)
  (entmakex (list (cons 0 "XLINE")
                  (cons 100 "AcDbEntity")
                  (cons 100 "AcDbXline")
                  (cons 10 pt)
                  (cons 11 vec)
	    )
  )
)

(defun TDKDGN (P1 ObjPline1 Pnt / Vla:ObjPline1   EnameXline Vla:Xline LtsPnt ) ;;;TIM DIEM KEO DAI GAN NHAT
(setq Vla:ObjPline1 (vlax-ename->vla-object ObjPline1))
(setq P2 (mapcar '- Pnt P1))
(MakeXline P1 P2)
(setq EnameXline (entlast))
(setq Vla:Xline (vlax-ename->vla-object EnameXline))
(setq LtsPnt (LM:Intersections Vla:ObjPline1  Vla:Xline acextendboth))
(entdel EnameXline)
(setq PntNear (car (vl-sort LtsPnt '(lambda(x y) (< (distance x P1) (distance y P1))))))
PntNear
)

<<

Filename: 313840_vtl2.lsp
Tác giả: nhoclangbat
Bài viết gốc: 313847
Tên lệnh: vktt
Chương 6 : Bài Tập

- nhoc gôm lại vậy đc không anh Ket ^^

;; ham luu gia tri
(defun getvalue ( a giatri dongnhac / astr) 
(or a (setq a giatri))
(cond
	((= (type a) 'INT) (setq a (cond ((getint (strcat "\n" dongnhac "(" (itoa a) ") :")))(a))))
	((= (type a) 'REAL) (setq a (cond ((getreal (strcat "\n" dongnhac "(" (rtos a 2) ") :")))(a))))
	((= (type a) 'STR) (setq a (cond ((= "" (setq astr (getstring T (strcat "\n" dongnhac " (" a "): ")))) a)...
>>

- nhoc gôm lại vậy đc không anh Ket ^^

;; ham luu gia tri
(defun getvalue ( a giatri dongnhac / astr) 
(or a (setq a giatri))
(cond
	((= (type a) 'INT) (setq a (cond ((getint (strcat "\n" dongnhac "(" (itoa a) ") :")))(a))))
	((= (type a) 'REAL) (setq a (cond ((getreal (strcat "\n" dongnhac "(" (rtos a 2) ") :")))(a))))
	((= (type a) 'STR) (setq a (cond ((= "" (setq astr (getstring T (strcat "\n" dongnhac " (" a "): ")))) a) (astr))))
))
;;;;
;;;tao textstyle
(defun emk_style (MyStyle MyFont)
(entmake (list    (cons 0 "STYLE")    
(cons 100 "AcDbSymbolTableRecord")    
(cons 100 "AcDbTextStyleTableRecord")    
(cons 2 MyStyle)    (cons 3  MyFont)    
(cons 70 0))))
;;;;;    
;;;ham ve cau thang
(defun kkkv ( diem cao rong sbac / pt1 pt2 e f)
(setvar "cmdecho" 0)
(command ".Pline" diem (setq pt1 (polar diem (/ pi 2) cao)) (setq pt2 (polar pt1 0 rong)) "")
(setq e (entlast))
(command ".line" diem pt2 "")
(setq f (entlast))
(command ".ucs" "e" f)
(command "-array" e "" "R" 1 sbac (distance diem pt2))
(command ".erase" f "")
(command ".ucs" "w")
(setvar "cmdecho" 0)
)
;;;;
(defun danhso (/ codanh)
(initget "Y N")
(setq codanh (Xstrcase (getkword "\nBan co mun danh so bac < Y / N > :")))
(if (= codanh "N") (setq codanh nil) (setq codanh t))
(if codanh
						  (progn
		                    (repeat sb
						      (command "text" (polar pt (/ pi 2) (+ cb 0.05)) (/ cb 1.5) 0 (itoa (setq i (1+ i))))
						      (command ".pline" pt (polar pt (/ pi 2) cb) (setq pt (polar (polar pt (/ pi 2) cb) 0 rb)) "")
						   
						     )
						   )
						 (kkkv pt cb rb sb)
						 )
)


;;;; bai 7 + 8 : ve cau thang them lua chon co danh so bac hay ko ^^
(defun c:vktt (/ lst_va old key )
(setq lst_va '("osmode" "cmdecho" "ANGDIR" "ANGBASE" "AUNITS"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(1 0 0 0 0))
(emk_style "danhso" "Ariali.ttf")
(setvar "textstyle" "danhso")
(setq i 0)
;(initget "Y N")
;(setq codem (Xstrcase (getkword "\nBan co mun danh so bac <Enter=Yes/No>: ")))
;(if (= codem "N") (setq codem nil) (setq codem t))
(initget 1 "A B C")
(setq key (Xstrcase (getkword "\nAsobacktbac Bcaonhasobacrongbac Ccaonhasobacgocnghieng <A/B/C>:")))
(cond 
           ((= key "A")
		        (if (and 
				        (setq pt (getpoint "\nchon diem dat:"))
						(setvar "osmode" 0)
				         (setq sb (getvalue sb 7 "nhap so bac")
				               rb (getvalue rb 0.25 "nhap chieu rong bac")
						       cb (getvalue cb 0.2 "nhap chieu cao bac")))
						(danhso)
                 )
            )
			((= key "B")
			     (if (and 
				        (setq pt (getpoint "\nchon diem dat:"))
						(setvar "osmode" 0)
						(setq cnha (getvalue cnha 3.5 "nhap do cao nha")
						      sb (getvalue sb 9 "nhap so bac")
							  rb (getvalue rb 0.25 "nhap chieu rong bac")
							  cb (/ cnha sb)))
					 (danhso)
				  )
			)
			((= key "C")
			       (if (and   
				          (setq pt (getpoint "\nchon diem dat:"))
						  (setvar "osmode" 0)
						  (setq cnha (getvalue cnha 4.0 "nhap chieu cao nha")
						        sb (getvalue sb 11 "nhap so bac thang:")
								gocng (getvalue gocng 45.0 "nhap goc nghieng")
								cb (/ cnha sb)
								pt4 (polar pt (* PI (/ 90 180.0)) cb)
								pt5 (polar pt4 0 100)
								pt6 (polar pt (* PI (/ gocng 180.0)) 100)
								pt7 (inters pt pt6 pt4 pt5 nil)
								rb (sqrt (- (expt (distance pt pt7) 2) (expt cb 2)))))
						(danhso)
					)
				)
)
(command ".zoom" "e")
(mapcar 'setvar lst_va old)
(princ)
)

<<

Filename: 313847_vktt.lsp
Tác giả: nhoclangbat
Bài viết gốc: 314030
Tên lệnh: tbcc
Lisp tính giá trị trung bình của các Text !!!!

- học tới ssget mà quên mất ^^, nhoc mông má lại cái lsp tính trung bình cộng, trong trường hợp bạn đó có trục trặc khi sử dụng lsp cũ sẽ có lsp mới để test lại ^^

;;ham tao text
(defun mktext (point height string justify layer textstyle mau / lst)
(setq lst (list '(0 . "TEXT")
                              (cons 10 point)
							  (cons 40 height)
							  (cons 1 string)
							  (cons 8 layer)
							 ...
>>

- học tới ssget mà quên mất ^^, nhoc mông má lại cái lsp tính trung bình cộng, trong trường hợp bạn đó có trục trặc khi sử dụng lsp cũ sẽ có lsp mới để test lại ^^

;;ham tao text
(defun mktext (point height string justify layer textstyle mau / lst)
(setq lst (list '(0 . "TEXT")
                              (cons 10 point)
							  (cons 40 height)
							  (cons 1 string)
							  (cons 8 layer)
							  (cons 7 textstyle)
							  (cons 62 mau)
			)
			justify (strcase justify))
		(cond   ((= justify "L") (setq Lst (append Lst (list (cons 72 0) (cons 11 point)))))
		        ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))
				((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))
				((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))
				)
	(entmakex Lst)
  )	;end mktext
;;;;
(defun C:tbcc(/ c tong oldob oldos txtstr realk mastyle malayer xtext num gstyle glayer tam tong tbc p ss)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
  (setq ss (ssget '((0 . "TEXT") (1 . "~*@*"))))
  (setq c 0 tong 0)
  (if (/= ss nil)
    (while (< c (sslength ss))
      (setq oldob (entget (ssname ss c)))
      (setq txtstr (assoc 1 oldob))
	  (setq realk (assoc 40 oldob))
	  (setq mastyle (assoc 7 oldob))
	  (setq malayer (assoc 8 oldob))
	(if (/= txtstr nil)
        (progn
		  (setq ctext (cdr realk))
          (setq num (cdr txtstr))
		  (setq gstyle (cdr mastyle))
		  (setq glayer (cdr malayer))
          (setq tam (atof num))
          (setq tong (+ tong tam))
		  (setq tbc (/ tong (sslength ss)))
        );progn
      );if
      (setq c (1+ c))
    );while
  );if
    (setq p (getpoint "\nNhap vi tri xuat ket qua: "))
	(if (= tbc 0)
    (mktext p ctext (rtos tbc 2 0) "L" glayer gstyle 1)
	(mktext p ctext (rtos tbc 2 3) "L" glayer gstyle 1)
	)
(setvar "cmdecho" 1)
(setvar "osmode" oldos)
(princ)	   
)
(prompt "ten lenh : tbcc")


<<

Filename: 314030_tbcc.lsp
Tác giả: Tot77
Bài viết gốc: 314071
Tên lệnh: test
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Lsp test. Không dùng với pline kín.

(defun c:test()
  (setq a (car (entsel "\nChon pline:")))
  (while (setq b (getpoint "\nChon diem:"))
    (setq b1 (vlax-curve-getClosestPointTo a b)
 a1 (vlax-curve-getpointAtParam a (fix (vlax-curve-getparamatPoint a b1)))
 a2 (vlax-curve-getpointAtParam a (1+ (fix (vlax-curve-getparamatPoint a b1)))))
    (if (or (equal (cos (+ (* 0.5 pi) (angle a1 a2))) (cos (angle b b1)) 0.001)
 ...
>>

Lsp test. Không dùng với pline kín.

(defun c:test()
  (setq a (car (entsel "\nChon pline:")))
  (while (setq b (getpoint "\nChon diem:"))
    (setq b1 (vlax-curve-getClosestPointTo a b)
 a1 (vlax-curve-getpointAtParam a (fix (vlax-curve-getparamatPoint a b1)))
 a2 (vlax-curve-getpointAtParam a (1+ (fix (vlax-curve-getparamatPoint a b1)))))
    (if (or (equal (cos (+ (* 0.5 pi) (angle a1 a2))) (cos (angle b b1)) 0.001)
   (equal (sin (+ (* 0.5 pi) (angle a1 a2))) (sin (angle b b1)) 0.001))
      (princ "Ben Phai") (princ "Ben Trai"))
  )
  (princ)
)

<<

Filename: 314071_test.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 314135
Tên lệnh: tbcc
Lisp tính giá trị trung bình của các Text !!!!

Ví dụ (code nhanh nên chưa kiểm tra kỹ)

(defun C:tbcc()
 (setq ss (ssget '((0 . "TEXT"))))
 (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
 (setq lst (mapcar '(lambda(ent) (distof (cdr (assoc 1 (entget ent))))) lst))
 (setq lst (vl-remove-if '(lambda(x) (= x nil)) lst))
 (/ (apply '+ lst) (length lst)))
 


Filename: 314135_tbcc.lsp
Tác giả: Tue_NV
Bài viết gốc: 314165
Tên lệnh: tbcc
Lisp tính giá trị trung bình của các Text !!!!

Code cho Nhóc đây!. Nhóc tham khảo nhé! code gọn lẹ ^_^

 

(defun C:tbcc(/ c tong mstbc num ss)
  (setq c -1 tong 0 mstbc 0)
  (if (setq ss (ssget '((0 . "TEXT"))))
    (while (setq ename (ssname ss (setq c (1+ c))))
      (if (setq num (distof (cdr (assoc 1 (entget ename)))))
          (setq tong (+ tong num) mstbc (1+ mstbc))
      );if
    );while
  );if    
(if (null (zerop mstbc)) (/ tong...
>>

Code cho Nhóc đây!. Nhóc tham khảo nhé! code gọn lẹ ^_^

 

(defun C:tbcc(/ c tong mstbc num ss)
  (setq c -1 tong 0 mstbc 0)
  (if (setq ss (ssget '((0 . "TEXT"))))
    (while (setq ename (ssname ss (setq c (1+ c))))
      (if (setq num (distof (cdr (assoc 1 (entget ename)))))
          (setq tong (+ tong num) mstbc (1+ mstbc))
      );if
    );while
  );if    
(if (null (zerop mstbc)) (/ tong mstbc))
)

<<

Filename: 314165_tbcc.lsp
Tác giả: nhoclangbat
Bài viết gốc: 314166
Tên lệnh: tbcc
Lisp tính giá trị trung bình của các Text !!!!

- hihi nhoc cũng mới mò ra, code của anh Tue gọn ngang a Ha, cách nhoc mò cũng hao hao cách của anh Tue nhưng dài hơn, vì có mấy hàm nhoc chưa học tới ^^

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/13750-lisp-tinh-gia-tri-trung-binh-cua-cac-text/page-2
;;ham tao text
(defun mktext (point height string justify layer textstyle mau / lst)
(setq lst (list '(0 . "TEXT")
      ...
>>

- hihi nhoc cũng mới mò ra, code của anh Tue gọn ngang a Ha, cách nhoc mò cũng hao hao cách của anh Tue nhưng dài hơn, vì có mấy hàm nhoc chưa học tới ^^

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/13750-lisp-tinh-gia-tri-trung-binh-cua-cac-text/page-2
;;ham tao text
(defun mktext (point height string justify layer textstyle mau / lst)
(setq lst (list '(0 . "TEXT")
                              (cons 10 point)
							  (cons 40 height)
							  (cons 1 string)
							  (cons 8 layer)
							  (cons 7 textstyle)
							  (cons 62 mau)
			)
			justify (strcase justify))
		(cond   ((= justify "L") (setq Lst (append Lst (list (cons 72 0) (cons 11 point)))))
		        ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))
				((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))
				((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))
				)
	(entmakex Lst)
  )	;end mktext
;;;;
(defun C:tbcc(/ c tong oldob oldos txtstr realk mastyle malayer xtext num gstyle glayer tam tong tbc p ss dem)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(princ "\n")
(prompt "cho cac text so:")
(setq ss (ssget '((0 . "TEXT"))))
  
  (if (/= ss nil)
  (progn
  (setq c 0 tong 0.0 dem 0)
    (while (< c (sslength ss))
      (setq oldob (entget (ssname ss c)))
      (setq txtstr (assoc 1 oldob))
	  (setq realk (assoc 40 oldob))
	  (setq mastyle (assoc 7 oldob))
	  (setq malayer (assoc 8 oldob))
	
		  (setq ctext (cdr realk))
          (setq num (cdr txtstr))
		  (setq gstyle (cdr mastyle))
		  (setq glayer (cdr malayer))
          (setq tam (distof num))
		  (if tam
		  (progn
          (setq tong (+ tong tam))
		  (setq dem (1+ dem))
		  ))
		  (setq c (1+ c))
        );while
		(setq tbc (/ tong dem))
      );progn
      
    );if
    (setq p (getpoint "\nNhap vi tri xuat ket qua: "))
	(if (= tbc 0)
    (mktext p ctext (rtos tbc 2 0) "L" glayer gstyle 1)
	(mktext p ctext (rtos tbc 2 3) "L" glayer gstyle 1)
	)
(setvar "cmdecho" 1)
(setvar "osmode" oldos)
(princ)	   
)
(prompt "ten lenh : tbcc")


<<

Filename: 314166_tbcc.lsp
Tác giả: tien2005
Bài viết gốc: 314174
Tên lệnh: tbcc
Lisp tính giá trị trung bình của các Text !!!!

code mới cho nhoc tham khảo

(DEFUN C:tbcc(/ SS ss1 pt TT)
  (defun ssnum (ss);return list ent
    (if ss(vl-remove-if-not
		     '(lambda (x) (distof (cdr (assoc 1 (entget x)))))
		     (vl-remove-if'listp(mapcar'cadr(ssnamex ss)))
		   )
      )
    )
  
  (defun dxf (code e) (cdr (assoc code (entget e))))
  (or sole (setq sole 2))
  
  (if(and(setq sole (cond((getint (strcat "\nLay bao nhieu so le <" (rtos sole 2 0) ">: "))) (sole)))
	 (setq ss...
>>

code mới cho nhoc tham khảo

(DEFUN C:tbcc(/ SS ss1 pt TT)
  (defun ssnum (ss);return list ent
    (if ss(vl-remove-if-not
		     '(lambda (x) (distof (cdr (assoc 1 (entget x)))))
		     (vl-remove-if'listp(mapcar'cadr(ssnamex ss)))
		   )
      )
    )
  
  (defun dxf (code e) (cdr (assoc code (entget e))))
  (or sole (setq sole 2))
  
  (if(and(setq sole (cond((getint (strcat "\nLay bao nhieu so le <" (rtos sole 2 0) ">: "))) (sole)))
	 (setq ss (ssnum (ssget '((0 . "TEXT") ))))
	 )
    (progn
      (setq #DIMZIN (GETVAR "DIMZIN"))
      (SETVAR "DIMZIN" 0)
      (setq tt (apply '+(mapcar'(lambda (x) (atof (dxf 1 x)))ss)))
      (setq tt (RTOS tt 2 sole))
      (if (setq ss1(car(entsel "\nChon TEXT de ghi ket qua hoac enter de chon diem ghi ket qua: ")))
	  (vla-put-textstring (vlax-ename->vla-object ss1) tt)
	  (entmake
	    (list (cons 0 "TEXT")
		  (cons 1 TT)
		  (cons 7 (dxf 7 (car ss)))
		  (cons 8 (dxf 8 (car ss)))
		  ;...
		  (cons 40 (dxf 40 (car ss)))
		  (cons 10 (getpoint "\nChon diem ghi ket qua: "))
	    )
	  )
	  )
      (SETVAR "DIMZIN" #DIMZIN)
      )
    )
  (princ)
)

<<

Filename: 314174_tbcc.lsp
Tác giả: pphung183
Bài viết gốc: 314233
Tên lệnh: tbcc
Lisp tính giá trị trung bình của các Text !!!!

Mượn hoa kính Phật, nhoclangbat có thể làm theo cách tự đặt Height của bạn Ha :) :

(vl-load-com)
(defun C:tbcc (/ old TSIZE ss lst tbc)
(setq old (mapcar 'getvar (list "cmdecho" "osmode")))
(setvar "cmdecho" 0) (setvar "osmode" 0)
(if (not TSIZE) (setq TSIZE (GETVAR "TEXTSIZE")))
(INITGET 6)
 (setq TSIZE1 (getreal (strcat "\nText Height <" (rtos TSIZE 2 3) ">:")))
(if TSIZE1 (setq TSIZE TSIZE1))
 (setq ss (ssget '((0 ....
>>

Mượn hoa kính Phật, nhoclangbat có thể làm theo cách tự đặt Height của bạn Ha :) :

(vl-load-com)
(defun C:tbcc (/ old TSIZE ss lst tbc)
(setq old (mapcar 'getvar (list "cmdecho" "osmode")))
(setvar "cmdecho" 0) (setvar "osmode" 0)
(if (not TSIZE) (setq TSIZE (GETVAR "TEXTSIZE")))
(INITGET 6)
 (setq TSIZE1 (getreal (strcat "\nText Height <" (rtos TSIZE 2 3) ">:")))
(if TSIZE1 (setq TSIZE TSIZE1))
 (setq ss (ssget '((0 . "TEXT"))))
 (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
 (setq lst (mapcar '(lambda(ent) (distof (cdr (assoc 1 (entget ent))))) lst))
 (setq lst (vl-remove-if '(lambda(x) (= x nil)) lst))
 (setq tbc (/ (apply '+ lst) (length lst)))
    (setq p (getpoint "\nNhap vi tri xuat ket qua: "))
    (command "TEXT" p TSIZE 0 (rtos tbc 2 3))
(mapcar 'setvar (list "cmdecho" "osmode") old)
(princ))

<<

Filename: 314233_tbcc.lsp
Tác giả: Nguyen Hoanh
Bài viết gốc: 3087
Tên lệnh: %3Cspan+styl
code giới hạn thời gian sử dụng File lisp

Với file lisp thì rất khó để làm được điều này. Bởi người biết sử dụng lisp sẽ vô hiệu hoá ngay nếu như đọc được mã lisp. Tuy nhiên, có thể làm được điều này với 1 file VLX đã được mã hoá. Cách làm thông thường như sau: Ghi thông tin các lần sử dụng lệnh vào 1 vị trí trên registry, hoặc vào file config của AutoCAD. Sau đó, đọc các thông tin này để có hành động phù hợp.
>>
Với file lisp thì rất khó để làm được điều này. Bởi người biết sử dụng lisp sẽ vô hiệu hoá ngay nếu như đọc được mã lisp. Tuy nhiên, có thể làm được điều này với 1 file VLX đã được mã hoá. Cách làm thông thường như sau: Ghi thông tin các lần sử dụng lệnh vào 1 vị trí trên registry, hoặc vào file config của AutoCAD. Sau đó, đọc các thông tin này để có hành động phù hợp.

Sau đây là 1 ví dụ đơn giản:


Lệnh TEST để xác định số lần thực thi. Chỉ thực thi lệnh được 5 lần. Không quan trọng ngày tháng, không quan trọng số lần sử dụng ACAD, cứ dùng lệnh TEST quá 5 lần là hết hạn.
Lệnh RESET để khởi tạo lại giá trị.

Tất nhiên, ví dụ trên là 1 cái khoá đơn giản chỉ khoá được người ngay chứ không khoá được kẻ gian.
<<

Filename: 3087_%3Cspan+styl.lsp
Tác giả: nhoclangbat
Bài viết gốc: 314216
Tên lệnh: tbcc
Lisp tính giá trị trung bình của các Text !!!!

- kỳ thật, nhoc lại ko chịu đc cảnh đem co bỏ chợ khó chịu ^^, nhoc lại ráng mò cho ra ^^, dựa trên code anh Tue nhoc ráng viết lại hoàn chỉnh ko bị các lỗi như a Tue nêu, tới đây nhoc nhận ra rằng có quá nhiều trường hợp ^^ để xét @@

- lọc ra các text chỉ số đã ổn 

- nếu ko chọn gì enter hoặc chọn toàn text chữ enter sẽ thoát lệnh ko bị lỗi lsp chạy tới dòng chọn điểm...

>>

- kỳ thật, nhoc lại ko chịu đc cảnh đem co bỏ chợ khó chịu ^^, nhoc lại ráng mò cho ra ^^, dựa trên code anh Tue nhoc ráng viết lại hoàn chỉnh ko bị các lỗi như a Tue nêu, tới đây nhoc nhận ra rằng có quá nhiều trường hợp ^^ để xét @@

- lọc ra các text chỉ số đã ổn 

- nếu ko chọn gì enter hoặc chọn toàn text chữ enter sẽ thoát lệnh ko bị lỗi lsp chạy tới dòng chọn điểm đặt nữa hay lỗi ** Error: divide by zero ** => tạm ổn ^^

- tạo text ghi kết quả height text ko bị ảnh hưởng bởi textstyle khác 0 

- mục đích nhoc lấy các mã dxf trong lsp cũ là là để gán vào text ghi kết quả: ko phải set chiều cao text, lấy lun textstyle, layer của tập chọn cho nó gọn nhưng

  nếu các text ko cùng layer or ko cùng height text or ko cùng style nữa thì sao nhỉ, nếu set thêm layer, style của kq tbc riêng thì có thể có người thấy hơi thừa trong bãn vẽ trừ phi người đó mún tạo ra 1 lst các giá trị tbc nằm ở 1 lớp riêng cho việc khác ^^

- lsp nhoc chỉnh lại dựa trên code a Tue nhoc cũng đã thử các trường hợp trên vẫn in ra đc kq, nhưng các thông số trên dựa theo quy luật nào mà thằng kết quả nó lấy của đối tượng nào để add vô ^^, đã thử nếu nhoc chọn từng thằng 1 thì thằng nào nhoc chọn cuối thì nó sẽ theo thằng đó, còn mà quét 1 lúc thì ko pit đc thằng nào là thằng cuối ^^

(defun mktext (point height string justify layer textstyle mau / lst)
(setq lst (list '(0 . "TEXT")
                              (cons 10 point)
							  (cons 40 height)
							  (cons 1 string)
							  (cons 8 layer)
							  (cons 7 textstyle)
							  (cons 62 mau)
			)
			justify (strcase justify))
		(cond   ((= justify "L") (setq Lst (append Lst (list (cons 72 0) (cons 11 point)))))
		        ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))
				((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))
				((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))
				)
	(entmakex Lst)
  )	;end mktext
;;;;
(defun C:tbcc(/ c tong mstbc num ss pt glayer ctext gstyle kq old)
(setq old (getvar "osmode"))
(setq c -1 tong 0 mstbc 0)
(if (setq ss (ssget '((0 . "TEXT"))))
 (progn
    (while (setq ename (ssname ss (setq c (1+ c))))
      (if (setq num (distof (cdr (assoc 1 (entget ename)))))
	      
          (setq tong (+ tong num) mstbc (1+ mstbc))
      );if
	  (if ename
	  (progn
	  (setq ctext (cdr (assoc 40 (entget ename))))
	  (setq glayer (cdr (assoc 8 (entget ename))))
	  (setq gstyle (cdr (assoc 7 (entget ename))))
	  )
	  )
    );while
	
	(if (null (zerop mstbc))
	(progn
	(setq kq (/ tong mstbc))
	(setvar "osmode" 0)
	(setq pt (getpoint "\nchon diem dat ket qua:"))
    (mktext pt ctext (rtos kq 2 3) "L" glayer gstyle 1)
     );progn
    );if	 
	
  );progn
);if    
(setvar "osmode" old)
(princ)
)

- p/s: nhiều vấn đề thật, mấy a góp ý cho nhoc với lsp này nên lấy thông số của đối tượng chọn add vào kq hay mình tạo 1 thông số riêng cho nó, cái nào tối ưu hơn nhỉ 


<<

Filename: 314216_tbcc.lsp
Tác giả: nhoclangbat
Bài viết gốc: 314346
Tên lệnh: tbcc
Lisp tính giá trị trung bình của các Text !!!!

- bạn cứ test thử nhiều trường hợp có lỗi pm nhoc hen ^^

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/13750-lisp-tinh-gia-tri-trung-binh-cua-cac-text/page-3
(defun mktext (point height string justify style  mau / lst)
(setq lst (list '(0 . "TEXT")
                              (cons 10 point)
							  (cons 40 height)
							  (cons 7 style)
							  (cons 1 string)
							  (cons 62...
>>

- bạn cứ test thử nhiều trường hợp có lỗi pm nhoc hen ^^

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/13750-lisp-tinh-gia-tri-trung-binh-cua-cac-text/page-3
(defun mktext (point height string justify style  mau / lst)
(setq lst (list '(0 . "TEXT")
                              (cons 10 point)
							  (cons 40 height)
							  (cons 7 style)
							  (cons 1 string)
							  (cons 62 mau)
			)
			justify (strcase justify))
		(cond   ((= justify "L") (setq Lst (append Lst (list (cons 72 0) (cons 11 point)))))
		        ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))
				((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))
				((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))
				)
	(entmakex Lst)
  )	;end mktext
;;;;
(prompt "Lenh tinh trung binh cong cac so: TBCC")
(defun C:tbcc(/ c tong mstbc num ss pt ctext kq old sty)
(setq old (getvar "osmode"))
(setq sty (getvar "textstyle"))
(setq c -1 tong 0 mstbc 0)
(if (setq ss (ssget '((0 . "TEXT"))))
 (progn
    (while (setq ename (ssname ss (setq c (1+ c))))
      (if (setq num (distof (cdr (assoc 1 (entget ename)))))
	      
          (setq tong (+ tong num) mstbc (1+ mstbc))
      );if
	  (if ename
	  (progn
	  (setq ctext (cdr (assoc 40 (entget ename))))
	  ;(setq glayer (cdr (assoc 8 (entget ename))))
	  ;(setq gstyle (cdr (assoc 7 (entget ename))))
	  )
	  )
	  
    );while
	
	
	(if (null (zerop mstbc))
	(progn
	(setq kq (/ tong mstbc))
	(setvar "osmode" 0)
	(setq pt (getpoint "\nchon diem dat ket qua:"))
    (mktext pt ctext (rtos kq 2 3) "L" sty 1)
     );progn
    );if	 
	
  );progn
  (alert "\nChua co doi tuong dc chon hoac ban chi chon toan text chu ^^")
);if    
(setvar "osmode" old)
(princ)
)

 


<<

Filename: 314346_tbcc.lsp
Tác giả: nhoclangbat
Bài viết gốc: 314420
Tên lệnh: toado
Listp bảng tọa độ vn2000

- lỡ giúp,  nhoc giúp cho trót  bạn đỡ đi tìm lại chủ đề trước ^^

- lưu ý trước khi chạy bạn phải tạo rùi set ranh đất bạn muốn chạy tọa độ ở layer tên "ranh_38", lệnh là "toado"

(defun *error* (msg)
  (princ "error: ")
  (princ msg)
  (princ)
)

(defun Wdis (p1 p2 / dis ang point point1)
  (setq dis...
>>

- lỡ giúp,  nhoc giúp cho trót  bạn đỡ đi tìm lại chủ đề trước ^^

- lưu ý trước khi chạy bạn phải tạo rùi set ranh đất bạn muốn chạy tọa độ ở layer tên "ranh_38", lệnh là "toado"

(defun *error* (msg)
  (princ "error: ")
  (princ msg)
  (princ)
)

(defun Wdis (p1 p2 / dis ang point point1)
  (setq dis (distance p1 p2))
  (setq ang (angle p1 p2))
  (if (and (> ang (/ Pi 2)) (< ang (* Pi 1.5)) )
    (progn
      (setq ang (+ Ang Pi)) 
      (setq Point (polar p2 ang (/ dis 2.0)))
      (setq Point1 (polar point (+ (/ pi 2) ang) (* 0.25 (/ TileBdHT 500))))

    )
	(progn
    (setq Point (polar p1 ang (/ dis 2.0)))
    (setq Point1 (polar point (+ (/ pi 2) ang) (* 0.25 (/ TileBdHT 500))))
	)
  )
  (command "Text" "S" "vaptimn" "c" point1 (/ TileBdHT 500) (* (/ ang Pi) 180) (rtos dis 2 2) )
)
(defun ssgetLayer( La1 La2 / ss)
  (setq ss (ssget "X" (list
                         (cons -4  "<OR")  
                           (cons -4  "<AND")  
                             (cons 8 La1)  
                             (cons 0  "LWPOLYLINE")
                           (cons -4  "AND>")  
                           (cons -4  "<AND")  
                             (cons 8 La1)  
                             (cons 0  "LINE")
                           (cons -4  "AND>")  
                           (cons -4  "<AND")  
                             (cons 8 La2)  
                             (cons 0  "LWPOLYLINE")
                           (cons -4  "AND>")  
                           (cons -4  "<AND")  
                             (cons 8 La2)  
                             (cons 0  "LINE")
                           (cons -4  "AND>")  
                         (cons -4  "OR>")  
                       )
  ))
  ss
)
(defun pointpl (name t2 k / namem i bien t1 p1 diem)
	(setq namem name)
	(setq i 1)
	(while (<= i k)
	(progn
		(setq bien (assoc t2 namem))
		(setq t1 (member bien namem))
		(setq p1 (car t1))
		(setq namem (cdr t1))
		(setq diem (cdr p1))
		(setq i (+ 1 i))
	)
	)
	diem
)
(defun c:Toado( / i k luuxy st p xoa)
	(setvar "cmdecho" 0)
	(setq st (ssgetLayer "Ranh_toado" "Ranh_38") )
	(if (/= st  nil)
(progn
	(if (null (tblsearch "style" "vaptimn"))
		(command "style" "vaptimn" "vni-avo" "" "" "" "" ""))
	(if (null (tblsearch "style" "vhelveb"))
		(command "style" "vhelveb" "vni-helve" "" "" "" "" ""))
	(if (null (tblsearch "layer" "sohieu_diem"))
		(command "_layer" "n" "sohieu_diem" ""))
	(command "_layer" "c" "2" "sohieu_diem" "")
	(if (null (tblsearch "layer" "canh"))
		(command "_layer" "n" "canh" ""))
	(command "_layer" "c" "3" "canh" "")
	(if (null (tblsearch "layer" "bang_toado"))
		(command "_layer" "n" "bang_toado" ""))
	(command "_layer" "c" "7" "bang_toado" "")
	(command "_layer" "c" "6" "Ranh_38" "")
	(command "_layer" "c" "6" "Ranh_toado" "")
	(if (null (tblsearch "layer" "Polygon"))
		(command "_layer" "n" "Polygon" ""))
	(command "_layer" "c" "8" "Polygon" "")
	(if (not r1) (setq r1 500))
	(setq TileBdHT (getreal (strcat "\nMau So Ti Le Cua BDHT" "(" (rtos r1 2 0) "):")))
	(if (= TileBdHT nil)
		(setq TileBdHT r1))
	

	(setvar "blipmode" 0)
	(setq old (getvar "osmode"))
	(setvar "osmode" 0)
	(setq p (getpoint "\n Pick"))
	(command "_layer" "s" "Polygon" "")
	(if (/= p nil)
		(command "-Boundary" "a" "b" "n" st "" "" p "" )
	)
	(setq luuxy (entget (entlast)))
	(setq pt (getpoint "\n Diem dat bang toa do :"))
;(entdel (entlast))
	(setq k (cdr (assoc 90 luuxy)))
	(if (/= pt nil)
		(progn
			(setq p01 pt)
			(setq p02 (mapcar '+ pt '(10.0  0.0 0.0)))
			(setq p03 (mapcar '+ pt '(22.5 -2.5 0.0)))
			(setq p04 (mapcar '+ pt '(35.0  0.0 0.0)))
			(setq p05 (mapcar '+ pt '(45.0  0.0 0.0)))
			(setq p06 (mapcar '+ pt '(0.0 -5.0 0.0)))
			(setq p07 (mapcar '+ pt '(10.0 -2.5 0.0)))
			(setq p08 (mapcar '+ pt '(35.0 -2.5 0.0)))
			(setq p09 (mapcar '+ pt '(45.0 -5.0 0.0)))
			(if (<= k 10)			
				(progn
					(setq p10 (mapcar '+ pt '(0.0 -40.0 0.0)))
					(setq p11 (mapcar '+ pt '(10.0 -40.0 0.0)))
					(setq p12 (mapcar '+ pt '(22.5 -40.0 0.0)))
					(setq p13 (mapcar '+ pt '(35.0 -40.0 0.0)))
					(setq p14 (mapcar '+ pt '(45.0 -40.0 0.0)))
				)
				(progn
					(setq ty (* -1 (+ 10.0 (* k 3))))
					(setq t0 (list 0.0 ty 0.0))
					(setq t1 (list 10.0 ty 0.0))
					(setq t2 (list 22.5 ty 0.0))
					(setq t3 (list 35.0 ty 0.0))
					(setq t4 (list 45.0 ty 0.0))
					(setq p10 (mapcar '+ pt t0))
					(setq p11 (mapcar '+ pt t1))
					(setq p12 (mapcar '+ pt t2))
					(setq p13 (mapcar '+ pt t3))
					(setq p14 (mapcar '+ pt t4))
				)
			)
			(command "layer" "s" "bang_toado" "")
			(command "Line" p01 p05 "")
			(command "Line" p01 p10 "")
			(command "Line" p02 p11 "")
			(command "Line" p03 p12 "")
			(command "Line" p04 p13 "")
			(command "Line" p05 p14 "")
			(command "Line" p07 p08 "")
			(command "Line" p06 p09 "")
			(command "Line" p10 p14 "")
(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ pt '(22.5 2.0 0.0)) 1.25 0 "BAÛNG LIEÄT KEÂ TOÏA ÑOÄ GOÙC RANH")
(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ pt '(5.0 -1.5 0.0)) 1.15 0 "Soá hieäu")
(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ pt '(5.0 -3.5 0.0)) 1.15 0 "ñieåm")
(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ pt '(22.5 -1.25 0.0)) 1.15 0 "Toïa ñoä")
(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ pt '(16.25 -3.75 0.0)) 1.15 0 "X(m)")
(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ pt '(28.75 -3.75 0.0)) 1.25 0 "Y(m)")
(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ pt '(40.0 -2.5 0.0)) 1.25 0 "Caïnh")
		)
	)
	(setq i 1)
	(while (<= i k)
		(progn
			(setq toado (pointpl luuxy 10 i))
			(setq x (rtos (car toado) 2 2))
			(setq y (rtos (cadr toado) 2 2))
			(command "layer" "s" "sohieu_diem" "")
			(setq doi (list (* 0.2 (/ TileBdHT 500)) (* 0.2 (/ TileBdHT 500)) 0.0))
			(command "Text" "S" "vaptimn" (mapcar '+ toado doi) (/ TileBdHT 500) 0 i)
			(command ".donut" 0 (* 0.25 (/ TileBdHT 500)) toado "")			
			(setq tsh (list 5.0 (- (* -3 i) 4.5) 0.0))
			(setq txx (list 16.25 (- (* -3 i) 4.5) 0.0))
			(setq tyy (list 28.75 (- (* -3 i) 4.5) 0.0))
			(setq tgc (list 40.0 (- (* -3 i) 3.0) 0.0))
			(setq psh (mapcar '+ pt tsh))
			(setq pxx (mapcar '+ pt txx))
			(setq pyy (mapcar '+ pt tyy))
			(setq pgc (mapcar '+ pt tgc))
			(if (= i 1)
				(progn
					(setq toado1 toado)
					(setq x1 (rtos (car toado1) 2 2))
					(setq y1 (rtos (cadr toado1) 2 2))
				)
			)
			(if (>= i 2)
(progn
	(setq canh (distance toado0 toado))
	(command "layer" "s" "bang_toado" "")
	(command "Text" "S" "vaptimn" "j" "M" pgc 1.2 0 (rtos canh 2 2) )
	(command "layer" "s" "canh" "")
	(wdis toado0 toado)
)
			)
			(command "layer" "s" "bang_toado" "")
			(command "Text" "S" "vaptimn" "j" "M" psh 1.2 0 i)
			(command "Text" "S" "vaptimn" "j" "M" pxx 1.2 0 y)
			(command "Text" "S" "vaptimn" "j" "M" pyy 1.2 0 x)
			(setq toado0 toado)
			(setq i (+ i 1))
		)
	)
	(command "layer" "s" "canh" "")
	(wdis toado toado1)
	(setq canh (distance toado toado1))
			(setq tsh (list 5.0 (- (* -3 (+ k 1)) 4.5) 0.0))
			(setq txx (list 16.25 (- (* -3 (+ k 1)) 4.5) 0.0))
			(setq tyy (list 28.75 (- (* -3 (+ k 1)) 4.5) 0.0))
			(setq tgc (list 40.0 (- (* -3 (+ k 1)) 3.0) 0.0))
			(setq psh (mapcar '+ pt tsh))
			(setq pxx (mapcar '+ pt txx))
			(setq pyy (mapcar '+ pt tyy))
			(setq pgc (mapcar '+ pt tgc))
	(command "layer" "s" "bang_toado" "")
	(command "Text" "S" "vaptimn" "j" "M" pgc 1.2 0 (rtos canh 2 2) )
	(command "Text" "S" "vaptimn" "j" "M" psh 1.2 0 "1")
	(command "Text" "S" "vaptimn" "j" "M" pxx 1.2 0 y1)
	(command "Text" "S" "vaptimn" "j" "M" pyy 1.2 0 x1)
	(setvar "osmode" old)
);(end progn)
);(end if)
	(if (= st nil)
	(progn
		(setvar "cmdecho" 1)
		(princ "Khong co layer Ranh_toado")
	)
	)
	(command "_layer" "s" "0" "")

)

-p/s: trường hợp tải ko đc, bạn copy toàn bộ nội dung trong code về past vào file txt rùi đổi đuôi thành file .lsp


<<

Filename: 314420_toado.lsp
Tác giả: Nguyen Hoanh
Bài viết gốc: 14476
Tên lệnh: test %3Cspan+styl
code giới hạn thời gian sử dụng File lisp

Ví dụ lệnh CUA nằm trong file c:\cadviet\lisp\archanwoo.lsp nhưng người sử dụng không biết tên lệnh là CUA. Khi người sử dụng lệnh TEST, sẽ tương đương như lệnh CUA, nhưng chỉ được 5 lần sử dụng.
Code như sau:

Filename: 14476_test_%3Cspan+styl.lsp
Tác giả: Tot77
Bài viết gốc: 314502
Tên lệnh: cca
tính chênh cao cho mắt lưới

Thì sửa cái lsp trên 1 chút, nhưng ở đây thấy có 3 số lẻ và không nhân 100.

(defun c:cca (/ ss sstk sstn sscc v cdtk tm cc cdtn tm1)
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (defun gan(v l)
    (car (vl-remove-if-not '(lambda(x) (< (distance (dxf 10 v) (dxf 11 x)) 1)) l))
  )
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex
(ssget "X" '((0 . "TEXT") (8 . "CDTN,CDTK,CC"))))))
sstk...
>>

Thì sửa cái lsp trên 1 chút, nhưng ở đây thấy có 3 số lẻ và không nhân 100.

(defun c:cca (/ ss sstk sstn sscc v cdtk tm cc cdtn tm1)
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (defun gan(v l)
    (car (vl-remove-if-not '(lambda(x) (< (distance (dxf 10 v) (dxf 11 x)) 1)) l))
  )
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex
(ssget "X" '((0 . "TEXT") (8 . "CDTN,CDTK,CC"))))))
sstk (vl-remove-if-not '(lambda(x) (= (dxf 8 x) "CDTK")) ss)
sstn (vl-remove-if-not '(lambda(x) (= (dxf 8 x) "CDTN")) ss)
        sscc (vl-remove-if-not '(lambda(x) (= (dxf 8 x) "CC")) ss))
  (while sstk
    (setq v (car sstk)
 sstk (cdr sstk)
 cdtk (atof (dxf 1 v))
 tm  (gan v sstn)
 cc  (gan v sscc))
    (if (and tm cc)
       (setq cdtn (atof (dxf 1 tm))
    sstn (vl-remove tm sstn)
    sscc (vl-remove cc sscc)
    tm1 (entmod (subst (cons 1 (rtos (abs  (- cdtn cdtk)) 2 3)) (assoc 1 (entget cc)) (entget cc)))
    )
    )
  )
  (princ)
) 
 
 

<<

Filename: 314502_cca.lsp
Tác giả: Tot77
Bài viết gốc: 314597
Tên lệnh: ddo
Lisp tính cao độ khi biết cao độ và độ dốc

Thật ra không phải do lsp mà là do 2 cái pline của bạn có chiều dài khác nhau dù rất nhỏ. Bạn cho luprec = 8 rồi nhấp vào từng pline rồi ctr-1 sẽ thấy length khác nhau. Và vì vậy nên khi nhân độ dốc sẽ khác nhau (cũng do vấn đề làm tròn số) dù chỉ 1 mm.

Tôi sửa lại lsp để khử cái vụ chênh nhau 1 chút đó.

(defun c:ddo( / a b txt tt1 sole dd1 vt)
  (defun...
>>

Thật ra không phải do lsp mà là do 2 cái pline của bạn có chiều dài khác nhau dù rất nhỏ. Bạn cho luprec = 8 rồi nhấp vào từng pline rồi ctr-1 sẽ thấy length khác nhau. Và vì vậy nên khi nhân độ dốc sẽ khác nhau (cũng do vấn đề làm tròn số) dù chỉ 1 mm.

Tôi sửa lại lsp để khử cái vụ chênh nhau 1 chút đó.

(defun c:ddo( / a b txt tt1 sole dd1 vt)
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (defun ator (a sl) (atof (rtos a 2 sl)))
  (setq a (getpoint "\nChon diem da biet cao do: ")
       txt (car (entsel "\nText cao do tuong ung: "))
       tt1 (dxf 1 txt)
       sole (if (setq vt (vl-string-search "." tt1)) (- (strlen (substr tt1 vt)) 2) 0)
       dd1 (getreal (strcat "\nNhap do doc (+ len; - xuong) <" (rtos (if (not dd) (setq dd 0.01) dd)) ">: ")))
 (if dd1 (setq dd dd1))
 (while (setq b (getpoint a "\nChon diem can tinh cao do: "))
  (entmake (list '(0 . "TEXT") (cons 10 b) (cons 11 b) (cons 40 (dxf 40 txt)) (cons 41 (dxf 41 txt))
 (cons 8 (dxf 8 txt)) (cons 62 (if (dxf 62 txt) (dxf 62 txt) 256))
 (cons 7 (dxf 7 txt)) (cons 72 (dxf 72 txt)) (cons 73 (dxf 73 txt)) '(50 . 0)
 (cons 1 (rtos (+ (atof (dxf 1 txt)) (ator (* dd (ator (distance a b) sole)) sole)) 2 sole))))
 )
 (princ)
)

<<

Filename: 314597_ddo.lsp
Tác giả: luhaivinh
Bài viết gốc: 314744
Tên lệnh: dth ht tg cn hv vel vac vxe vxh tly taoly ddd lll hhh ttt
Bài tập chương 4

hehe,và ta đã trở lai..

Mấy hôm nay công việc nhiều quá nên không làm bài tập được,

Nghe lời bạn Nhoc mình vòng về mấy bài trước và đi chậm lại.Bắt đầu thấy khá hơn tí rồi. :)

Nhờ mọi người gốp ý bài làm với.

CÂU 1 , CÂU 2

 

;cau 1
;a > 4
;b > loi (mac dinh chi mot tham so )
;c > loi ("13.5" duoc hieu khong phai la so)
;d > loi ("2"...
>>

hehe,và ta đã trở lai..

Mấy hôm nay công việc nhiều quá nên không làm bài tập được,

Nghe lời bạn Nhoc mình vòng về mấy bài trước và đi chậm lại.Bắt đầu thấy khá hơn tí rồi. :)

Nhờ mọi người gốp ý bài làm với.

CÂU 1 , CÂU 2

 

;cau 1
;a > 4
;b > loi (mac dinh chi mot tham so )
;c > loi ("13.5" duoc hieu khong phai la so)
;d > loi ("2" duoc hieu khong phai la so)
;e > loi (cac so dat trong dau "" khong duoc hieu la so)
;f > loi (sai cau truc mac dinh)
;g > 0.0
;h > loi (4.0 la so thuc, mac dinh tham so phai la so nguyen)
;i > loi (phai co 2 tham so tham gia)
;j > loi (so trong can phi la so duong)
;k > loi (khong thuc hien duoc) `
;l > loi (do e khong thuoc int hoac real)
;m > loi (getstring chi cho chuoi chu khong cho so)
;n > loi (ham yeu cau tham so la so nguyen nhung getreal cho so thuc)

;cau 2
(defun laythapphan(a)
 (- a (fix a)))
(defun lamtronxuong(a)
 (fix a))
(defun lamtronlen(a)
 (+ 1 (fix a)))
(defun LCR()
 (* (/ (abs a) (gcd a b)) (abs b))))
 
(defun DTR(a)
 (/ (* a pi) 180))

 

CÂU 3, CÂU 4

 


;cau 3
(defun start()
  (setq oldcm (getvar "cmdecho"))
  (setq oldos (getvar "osmode"))
  (setq oldab (getvar "angbase"))
  (setq oldad (getvar "angdir")))
(defun end()
  (setvar "cmdecho" oldcm)
  (setvar "osmode" oldos)
  (setvar "angbase" oldab)
  (setvar "angdir" oldad))
(defun moment()
  (setvar "cmdecho" 0)
  (setvar "osmode" 681)
  (setvar "angbase" 0)
  (setvar "angdir" 0))
;chuong 8
(defun c:dth(/ p1 p2) ;a
  (start)
  (moment)
  (setq p1 (getpoint "\nNhap toa do diem dau:"))
  (setq p2 (getpoint p1 "\nNhap toa do diem thu hai:"))
  (command "line" p1 p2 "" )
  (end))
(defun c:ht(/ pt d); b
  (start)
  (moment)
  (setq pt (getpoint "\nNhap toa do tam:"))
  (setq d (getreal "\nNhap duong kinh:"))
  (command "circle" pt (/ d 2) "zoom" "e")
  (end))
(defun c:tg(/ pt1 pt2 a); c
  (start)
  (moment)
  (setq pt1 (getpoint "\nNhap toa do dinh dau:"))
  (setq a (getreal "\nNhap chieu dai canh:"))
  (setq pt2 (polar pt1 0 a))
  (command "polygon" 3 "e" pt1 pt2)
  (end))
(defun c:cn(/ pt1 pt2); d
  (start)
  (moment)
  (setq pt1 (getpoint "\nNhap toa do dinh dau:"))
  (setq pt2 (getpoint "\nNhap toa do dinh doi dien:"))
  (command "rectang" p1 p2)
  (end))
(defun c:hv(/ pt1 pt2 a); e
  (start)
  (moment)
  (setq pt1 (getpoint "\nNhap toa do dinh dau:"))
  (setq a (getreal "\nNhap chieu dai canh:"))
  (setq pt2 (polar pt1 0 a))
  (command "polygon" 4 "e" pt1 pt2)
  (end))
(defun c:vel(/ pt1 pt2 pt3);f
  (start)
  (moment)
  (setq pt1 (getpoint "\nNhap toa do diem dau:"))
  (setq pt2 (getpoint "\nNhap toa do diem thu hai:"))
  (setq pt3 (getpoint "\nNhap toa do diem thu cuoi:"))
  (command "ellipse" pt1 pt2 pt3 )
  (end))
(defun c:vac(/ pt1 pt2 pt3);g
  (start)
  (moment)
  (setq pt1 (getpoint "\nNhap toa do diem dau:"))
  (setq pt2 (getpoint "\nNhap toa do diem thu hai:"))
  (setq pt3 (getpoint "\nNhap toa do diem thu cuoi:"))
  (command "arc" pt1 pt2 pt3 )
  (end))
(defun c:vxe();h
  (start)
  (moment)
  (command ".erase" "last" "")
  (end))
(defun c:vxh();h
  (start)
  (moment)
  (command ".erase" "p" "")
  (end))
 
;cau 4
(defun c:tly();a
  (command "-layer" "m" "ten" "c" mau "l" "ten duong" "lw" do day net "" ""))
(defun c:taoly();b
  (command "-layer" "m" "dim" "c" 2 "" "l" "continuous" "" "lw" 0.1 "" "")
  (command "-layer" "m" "hatch" "c" 1 "" "l" "continuous" "" "lw" 0.15 "" "")
  (command "-layer" "m" "text" "c" 4 "" "l" "continuous" "" "lw" 0.2 "" ""))

(defun c:ddd(/ pt1 pt2);c
  (start)
  (setq ocl (getvar "clayer"))
  (moment)
  (command "-layer" "m" "dim" "")
  (setq pt1 (getpoint "\nChon diem dau:"))
  (setq pt2 (getpoint pt1 "\nChon diem cuoi:"))
  (command "DIMALIGNED" pt1 pt2)
  (end)
  (setvar "clayer" ocl))
(defun c:lll(/ pt1 pt2 pt3)
  (start)
  (setq ocl (getvar "clayer"))
  (moment)
  (command "-layer" "m" "leader" "c" 3 "" "l" "continuous" "" "lw" 0.15 "" "")
  (setq pt1 (getpoint "\nChon diem dau:"))
  (setq pt2 (getpoint pt1 "\nChon diem thu hai:"))
  (setq pt3 (getpoint pt2 "\nChon diem cuoi:"))
  (command "leader" pt1 pt2 pt3 "" "" "")
  (end)
  (setvar "clayer" ocl))
(defun c:hhh()
  (start)
  (setq ocl (getvar "clayer"))
  (moment)
  (command "-layer" "m" "hatch" "")
  (command "-hatch" "co" 5 "")
  (end)
  (setvar "clayer" ocl))
(defun c:ttt(/ pt a b)
  (start)
  (setq ocl (getvar "clayer"))
  (moment)
  (command "-layer" "m" "text" "")
  (setq pt (getpoint "\nChon diem dat chu"))
  (setq a (getreal "\nNhap chieu cao chu:"))
  (setq b (getreal "\nNhap goc xoay chu:"))
  (command "-text" pt a b)
  (end)
  (setvar "clayer" ocl))
  

;d 
De dua layer ve trang thai ban dau ta luu layer o truoc khi thuc hien lenh vao mot biet tam,sau khi ket thuc lenh ta setvar clayer la bien tam vua tao do. 

<<

Filename: 314744_dth_ht_tg_cn_hv_vel_vac_vxe_vxh_tly_taoly_ddd_lll_hhh_ttt.lsp
Tác giả: Tot77
Bài viết gốc: 314687
Tên lệnh: cca
tính chênh cao cho mắt lưới

Bạn dùng cái này. Nó chỉ hỏi 1 lần thôi.

(defun c:cca (/ ss sstk sstn sscc v cdtk tm cc cdtn tm1)
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (defun gan(v l)
   (car (vl-remove-if-not '(lambda(x) (< (distance (dxf 10 v) (dxf 11 x)) 1)) l))
  )
  (if (not laylist)
    (setq laylist (cons (dxf 8 (car (entsel "\nChon doi tuong thuoc layer Cao do thiet ke :"))) laylist)
 laylist (cons (dxf 8 (car (entsel "\nChon...
>>

Bạn dùng cái này. Nó chỉ hỏi 1 lần thôi.

(defun c:cca (/ ss sstk sstn sscc v cdtk tm cc cdtn tm1)
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (defun gan(v l)
   (car (vl-remove-if-not '(lambda(x) (< (distance (dxf 10 v) (dxf 11 x)) 1)) l))
  )
  (if (not laylist)
    (setq laylist (cons (dxf 8 (car (entsel "\nChon doi tuong thuoc layer Cao do thiet ke :"))) laylist)
 laylist (cons (dxf 8 (car (entsel "\nChon doi tuong thuoc layer Cao do tu nhien :"))) laylist)
 laylist (cons (dxf 8 (car (entsel "\nChon doi tuong thuoc layer Chenh cao :"))) laylist)
    )
  )      
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex
(ssget "X" (list '(0 . "TEXT") (cons 8 (strcat (car laylist)"," (cadr laylist) "," (last laylist))))))))
sstk (vl-remove-if-not '(lambda(x) (= (dxf 8 x) (last laylist))) ss)
sstn (vl-remove-if-not '(lambda(x) (= (dxf 8 x) (cadr laylist))) ss)
sscc (vl-remove-if-not '(lambda(x) (= (dxf 8 x) (car laylist))) ss))
(while sstk
 (setq v (car sstk)
       sstk (cdr sstk)
       cdtk (atof (dxf 1 v))
       tm (gan v sstn)
       cc (gan v sscc))
 (if (and tm cc)
    (setq cdtn (atof (dxf 1 tm))
 sstn (vl-remove tm sstn)
 sscc (vl-remove cc sscc)
 tm1 (entmod (subst (cons 1 (rtos (- cdtk cdtn) 2 3)) (assoc 1 (entget cc)) (entget cc)))
  )
 )
)
(princ)
)

<<

Filename: 314687_cca.lsp
Tác giả: nhoclangbat
Bài viết gốc: 314797
Tên lệnh: hhh
Bài tập chương 4

- hi thằng hatch là thằng khó xơi bạn Vinh ơi, nó rối hơn mấy lệnh khác, bạn làm thử trong cad chưa, xem nó đòi nhưng tham số nào ^^

bạn chạy thử lsp vd nhoc đưa xem nó có đưa đúng layer ko hỉ ^^

(defun c:hhh(/ pt)
  (start)
  (setq ocl (getvar "clayer"))
  (setvar "osmode" 0)
  (command "-layer" "m" "hatch" "c" 5 "" "l" "continuous" "" "lw" 0.13 "" "")
  (setq pt (getpoint "\nchon vung hatch:"))
 ...
>>

- hi thằng hatch là thằng khó xơi bạn Vinh ơi, nó rối hơn mấy lệnh khác, bạn làm thử trong cad chưa, xem nó đòi nhưng tham số nào ^^

bạn chạy thử lsp vd nhoc đưa xem nó có đưa đúng layer ko hỉ ^^

(defun c:hhh(/ pt)
  (start)
  (setq ocl (getvar "clayer"))
  (setvar "osmode" 0)
  (command "-layer" "m" "hatch" "c" 5 "" "l" "continuous" "" "lw" 0.13 "" "")
  (setq pt (getpoint "\nchon vung hatch:"))
  (command "-hatch" pt "")
  (end)
  (setvar "clayer" ocl)
  )
;;;;
(defun start()
  (setq oldcm (getvar "cmdecho"))
  (setq oldos (getvar "osmode"))
  (setq oldab (getvar "angbase"))
  (setq oldad (getvar "angdir")))
(defun end()
  (setvar "cmdecho" oldcm)
  (setvar "osmode" oldos)
  (setvar "angbase" oldab)
  (setvar "angdir" oldad))

<<

Filename: 314797_hhh.lsp

Trang 174/330

174