Jump to content
InfoFile
Tác giả: nhoclangbat
Bài viết gốc: 318930
Tên lệnh: ve
Lisp thao tác trong 3D

update theo haanh:

- Set layer cho ống & cút

- Xoá 3dpolyline

 


- hihi nhoc test tí  ^^

;lisp ve duong ong 3d
(defun c:VE(/ lst_va old D ss lst_TC_DUC cao_tam_cut net R path cut base_w lst_ver lst_w obj i ss_ong ss_cut n len dau cuoi)
(setq lst_va '("osmode"...
>>

update theo haanh:

- Set layer cho ống & cút

- Xoá 3dpolyline

 


- hihi nhoc test tí  ^^

;lisp ve duong ong 3d
(defun c:VE(/ lst_va old D ss lst_TC_DUC cao_tam_cut net R path cut base_w lst_ver lst_w obj i ss_ong ss_cut n len dau cuoi)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
;=================
(setq D (getdist "\nNhap duong kinh ong: ")
	  lst_TC_DUC '((12 . 26.0) (13 . 26.0) (18 . 35.0) (19 . 35.0) (22 . 40.0) (23 . 40.0) (28 . 
50.0) (29 . 50.0) (35 . 55.0) (34 . 55.0) (40 . 60.0) (52 . 70.0) (53 . 70.0) 
(70 . 80.0) (69 . 80.0) (85 . 90.0) (84 . 90.0) (104 . 100.0) (129 . 187.5) 
(154 . 225.0) (204 . 300.0) (254 . 375.0))
	  cao_tam_cut (cdr (assoc D lst_TC_DUC))
	  )	;setq
;=================
(prompt "\nChon 3DPOLY: ")
(setq ss (ssget "+.:E:S" '((0 . "POLYLINE"))))
(if (and
		D
		(member D (mapcar 'car lst_TC_DUC))
		ss)
	(progn
		(or #lan_ve (setq #lan_ve 0))
		(setq #lan_ve (1+ #lan_ve))
		;ve cut mau:
		(setq net (getvar "clayer"))
		(if (tblsearch "layer" "Cut_DN50") 
			(setvar "clayer" "Cut_DN50") 
			(command "layer" "m" "Cut_DN50" "c" "t" "45,159,225" "" "")
			)	;if
		(command "arc" "c" '(0 0 0) (list cao_tam_cut 0 0) (list 0 cao_tam_cut 0))
		(setq path (entlast))
		(command "circle" '(0 0 0) (setq R (/ D 2.0)))
		(command "sweep" (entlast) "" path)
		(setq cut (entlast))
		(setq base_w (mapcar '(lambda (x) (trans x 1 0)) (list (list cao_tam_cut 0 0) (list cao_tam_cut cao_tam_cut 0) (list 0 cao_tam_cut 0))))
		;== xong cut mau ==
		(if (tblsearch "layer" "Ong_DN50") 
			(setvar "clayer" "Ong_DN50") 
			(command "layer" "m" "Ong_DN50" "c" "t" "133,230,244" "" "")
			)	;if 
		;Luu UCS:
		(command "ucs" "na" "s" "save1_ucs")
		;(command "-view" "s" "save_v")
		;*******************************
		(setq lst_ver (acet-geom-vertex-list (setq ename (ssname ss 0)))
			  lst_w (mapcar '(lambda (x) (trans x 1 0)) lst_ver)
			  obj (vlax-ename->vla-object ename))
		(setq i 0
			  ss_ong (ssadd)
			  ss_cut (ssadd)
			  )
		(repeat (setq n (1- (length lst_w)))
			(setq len (distance (setq dau (nth i lst_w)) (setq cuoi (nth (1+ i) lst_w))))
			(command "UCS" "za" (trans dau 0 1) (trans cuoi 0 1))
			(cond
				((= i 0) (command "CYLINDER" (trans dau 0 1) R (- len cao_tam_cut))	;ve ong
					(setq ss_ong (ssadd (entlast) ss_ong))
					(3DDD cut  
						(trans (car base_w) 0 1) 
						(trans (cadr base_w) 0 1) 
						(trans (last base_w) 0 1) 
						(trans (vlax-curve-getPointAtDist obj (- (vlax-curve-getDistAtParam obj 1) cao_tam_cut)) 0 1) 
						(trans (vlax-curve-getPointAtParam obj 1) 0 1) 
						(trans (vlax-curve-getPointAtDist obj (+ (vlax-curve-getDistAtParam obj 1) cao_tam_cut)) 0 1))	;align_copy cut
					(setq ss_cut (ssadd (entlast) ss_cut))
				)
				((= i (1- n)) (command "CYLINDER" (mapcar '+ (list 0 0 cao_tam_cut) (trans dau 0 1)) R (- len cao_tam_cut))	;ve ong
					(setq ss_ong (ssadd (entlast) ss_ong))
				)	
				(t (command "CYLINDER" (mapcar '+ (list 0 0 cao_tam_cut) (trans dau 0 1)) R (- len (* 2 cao_tam_cut)))	;ve ong
					(setq ss_ong (ssadd (entlast) ss_ong))
					(3DDD cut 
						(trans (car base_w) 0 1) 
						(trans (cadr base_w) 0 1) 
						(trans (last base_w) 0 1) 
						(trans (vlax-curve-getPointAtDist obj (- (vlax-curve-getDistAtParam obj (1+ i)) cao_tam_cut)) 0 1) 
						(trans (vlax-curve-getPointAtParam obj (1+ i)) 0 1) 
						(trans (vlax-curve-getPointAtDist obj (+ (vlax-curve-getDistAtParam obj (1+ i)) cao_tam_cut)) 0 1))		;align_copy cut
					(setq ss_cut (ssadd (entlast) ss_cut))
				)
			)
			(setq i (1+ i))
		)	;repeat
		;(command "-block" (strcat "Ong_" (rtos (getvar 'cdate) 2 4)) (trans (nth 0 lst_w) 0 1) ss_ong "")
		;(command "-block" (strcat "Cut_" (rtos (getvar 'cdate) 2 4)) (trans (nth 0 lst_w) 0 1) ss_cut "")
		(command "group" "c" (strcat "Ong_" (rtos (getvar 'cdate) 2 0) (itoa #lan_ve)) "Group_ong" ss_ong "")
		(command "group" "c" (strcat "Cut_" (rtos (getvar 'cdate) 2 0) (itoa #lan_ve)) "Group_cut" ss_cut "")
		;(mapcar 'entdel (list cut path))       ;Cai nay chay tren cad2014 thay co loi ko xoa path nen thay bang command
		(command ".ERASE" cut "")
		(command ".ERASE" path "")
		(command ".ERASE" ss "")
		(command "ucs" "na" "r" "save1_ucs")
		(command "ucs" "na" "d" "save1_ucs")
		;(command "-view" "r" "save_v")
		;(command "-view" "d" "save_v")
		(setvar "clayer" net)
	)
	(alert "***** Nhap du lieu chua dung ! *****")
)
(mapcar 'setvar lst_va old)
(princ)
)
(vl-load-com)
;*****************************************************************************************************************************
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;=============================================================================================================================
(defun 3DDD(ss pt_a pt_b pt_c pt_1 pt_2 pt_3 / lst_va old lst_point_w moc new pre
huong_12_xoy huong_13_xoy huong_ab_xoy huong_ac_xoy 
huong_12_yoz huong_13_yoz huong_ab_yoz huong_ac_yoz 
huong_12_xoz huong_13_xoz huong_ab_xoz huong_ac_xoz 
pt_phu pt_phu_w pt_phu2 pt_phu2_w base truc truc_w ang anh anh_c anh_w pt_phu2_2d pt_phu2_w_3d pt_phu_2d pt_phu_3d pt_phu_w_3d)
;Ham 3dalign khong scale Voi 3 diem chon phai "bang nhau" ve kich thuoc hinh dang
(setq lst_va '("osmode" "cmdecho" "AUNITS" "ANGDIR"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0 3 0))
(setq lst_point_w (mapcar '(lambda (x) (trans x 1 0)) (list pt_a pt_b pt_c pt_1 pt_2 pt_3)))
(command "ucs" "na" "s" "save_ucs")
;(command "-view" "s" "save_v")
(setq moc (entlast) 
	  new (ssadd))
(command "_.copy" ss "" pt_a pt_1)
(while (setq pre (entnext moc))
	(setq new (ssadd pre new)
		  moc pre)
)	;while
;======================================================================
;Kiem tra trung phuong, chieu
(command "ucs" "za" '(0 0 0) '(2.357 1.312 4.235))
(setq huong_12_xoy (angle (nth 3 lst_point_w) (nth 4 lst_point_w))
	  huong_13_xoy (angle (nth 3 lst_point_w) (nth 5 lst_point_w))
	  huong_ab_xoy (angle (nth 0 lst_point_w) (nth 1 lst_point_w))
	  huong_ac_xoy (angle (nth 0 lst_point_w) (nth 2 lst_point_w))
	  )
(command "ucs" "za" '(0 0 0) '(1 0 0))
(setq huong_12_yoz (angle (trans (nth 3 lst_point_w) 0 1) (trans (nth 4 lst_point_w) 0 1))
	  huong_13_yoz (angle (trans (nth 3 lst_point_w) 0 1) (trans (nth 5 lst_point_w) 0 1))
	  huong_ab_yoz (angle (trans (nth 0 lst_point_w) 0 1) (trans (nth 1 lst_point_w) 0 1))
	  huong_ac_yoz (angle (trans (nth 0 lst_point_w) 0 1) (trans (nth 2 lst_point_w) 0 1))
	  )
(command "ucs" "za" '(0 0 0) '(1 0 0))
(setq huong_12_xoz (angle (trans (nth 3 lst_point_w) 0 1) (trans (nth 4 lst_point_w) 0 1))
	  huong_13_xoz (angle (trans (nth 3 lst_point_w) 0 1) (trans (nth 5 lst_point_w) 0 1))
	  huong_ab_xoz (angle (trans (nth 0 lst_point_w) 0 1) (trans (nth 1 lst_point_w) 0 1))
	  huong_ac_xoz (angle (trans (nth 0 lst_point_w) 0 1) (trans (nth 2 lst_point_w) 0 1))
	  )
(command "ucs" "na" "r" "save_ucs")
;=====================================================================
(cond
	((and 
		(equal huong_12_xoy huong_ab_xoy 1e-5) 
		(equal huong_12_yoz huong_ab_yoz 1e-5)
		(equal huong_12_xoz huong_ab_xoz 1e-5)
		)
		(cond
			((and 
				(equal huong_13_xoy huong_ac_xoy 1e-5) 
				(equal huong_13_yoz huong_ac_yoz 1e-5)
				(equal huong_13_xoz huong_ac_xoz 1e-5)
				)
				(princ "\nAlign = Copy ! ")
				(princ)
			)
			(t 
				(setq pt_phu (mapcar '+ pt_1 (mapcar '- pt_c pt_a))
					  pt_phu_w (trans pt_phu 1 0))
				(command "ucs" "za" pt_1 pt_2)
				(command "rotate" new "" 
					(setq base (trans (nth 3 lst_point_w) 0 1))
					(- (angle base (trans (nth 5 lst_point_w) 0 1)) (angle base (trans pt_phu_w 0 1)))
					)
			)
		)
	)
	;========================================================
	((and 
		(or (equal (+ huong_12_xoy pi) huong_ab_xoy 1e-5) (equal (- huong_12_xoy pi) huong_ab_xoy 1e-5))
		(or (equal (+ huong_12_yoz pi) huong_ab_yoz 1e-5) (equal (- huong_12_yoz pi) huong_ab_yoz 1e-5))
		(or (equal (+ huong_12_xoz pi) huong_ab_xoz 1e-5) (equal (- huong_12_xoz pi) huong_ab_xoz 1e-5))
		)
			(setq truc (mapcar '+ pt_1 (mapcar '- pt_c pt_a))
				  truc_w (trans truc 1 0))
			(setq anh (mapcar '+ pt_1 (mapcar '- pt_b pt_a))
				  anh_w (trans anh 1 0))
			(command "ucs" "za" pt_1 truc)
			(command "rotate" new "" (setq base (trans (nth 3 lst_point_w) 0 1)) pi)
			(setq pt_phu2_2d
				(polar 
						base 
						(+ pi (angle base (setq anh_c (trans anh_w 0 1)))) 
						(distance base (list (car anh_c) (cadr anh_c)))
						)
				pt_phu2_w_3d (trans (list (car pt_phu2_2d) (cadr pt_phu2_2d) (last anh_c)) 1 0)
				)
			(cond
				((and 
					(equal huong_13_xoy huong_ac_xoy 1e-5) 
					(equal huong_13_yoz huong_ac_yoz 1e-5)
					(equal huong_13_xoz huong_ac_xoz 1e-5)
					)
					(princ)
				)
				((and 
					(or (equal (+ huong_13_xoy pi) huong_ac_xoy 1e-5) (equal (- huong_13_xoy pi) huong_ac_xoy 1e-5))
					(or (equal (+ huong_13_yoz pi) huong_ac_yoz 1e-5) (equal (- huong_13_yoz pi) huong_ac_yoz 1e-5))
					(or (equal (+ huong_13_xoz pi) huong_ac_xoz 1e-5) (equal (- huong_13_xoz pi) huong_ac_xoz 1e-5))
					)
					(command "ucs" "za" base (mapcar '(lambda (x) (* 0.5 x)) (mapcar '+ (trans pt_phu2_w_3d 0 1) (trans (nth 4 lst_point_w) 0 1))))
					(command "rotate" new "" (trans (nth 3 lst_point_w) 0 1) pi)
				)
				(t 
					(command "ucs" "3p" base (trans (nth 5 lst_point_w) 0 1) (trans truc_w 0 1))
					(command "rotate" new ""
						(setq base (trans (nth 3 lst_point_w) 0 1))
						(* -1 (angle base (trans truc_w 0 1)))
					)
				)
			)
	)
	;==================================================================
	(t 
		(cond
			((and 
					(equal huong_13_xoy huong_ac_xoy 1e-5) 
					(equal huong_13_yoz huong_ac_yoz 1e-5)
					(equal huong_13_xoz huong_ac_xoz 1e-5)
					)
					(setq pt_phu (mapcar '+ pt_1 (mapcar '- pt_b pt_a))
						  pt_phu_w (trans pt_phu 1 0))
					(command "ucs" "za" pt_1 pt_3)
					(command "rotate" new "" 
						(setq base (trans (nth 3 lst_point_w) 0 1))
						(- (angle base (trans (nth 4 lst_point_w) 0 1)) (angle base (trans pt_phu_w 0 1)))
					)
			)
			((and 
					(or (equal (+ huong_13_xoy pi) huong_ac_xoy 1e-5) (equal (- huong_13_xoy pi) huong_ac_xoy 1e-5))
					(or (equal (+ huong_13_yoz pi) huong_ac_yoz 1e-5) (equal (- huong_13_yoz pi) huong_ac_yoz 1e-5))
					(or (equal (+ huong_13_xoz pi) huong_ac_xoz 1e-5) (equal (- huong_13_xoz pi) huong_ac_xoz 1e-5))
					)
					(setq truc (mapcar '+ pt_1 (mapcar '- pt_b pt_a))
						  truc_w (trans truc 1 0))
					(setq anh (mapcar '+ pt_1 (mapcar '- pt_c pt_a))
						  anh_w (trans anh 1 0))
					(command "ucs" "za" pt_1 truc)
					(command "rotate" new "" (setq base (trans (nth 3 lst_point_w) 0 1)) pi)
					(command "ucs" "3p" base (trans (nth 4 lst_point_w) 0 1) (trans truc_w 0 1))
					(command "rotate" new ""
						(setq base (trans (nth 3 lst_point_w) 0 1))
						(* -1 (angle base (trans truc_w 0 1)))
					)
			)
			(t
				(setq pt_phu (mapcar '+ pt_1 (mapcar '- pt_b pt_a))
					  pt_phu_w (trans pt_phu 1 0)
					  pt_phu2 (mapcar '+ pt_1 (mapcar '- pt_c pt_a))
					  pt_phu2_w (trans pt_phu2 1 0))
				(command "ucs" "3p" pt_1 pt_2 pt_phu)
				(command "rotate" new "" 
					(setq base (trans (nth 3 lst_point_w) 0 1)) 
					(setq ang (* -1 (angle base (trans pt_phu_w 0 1))))
				)
				(setq pt_phu_2d 
						(polar 
							base 
							(+ ang (angle base (setq anh_c (trans pt_phu2_w 0 1)))) 
							(distance (list (car base) (cadr base)) (list (car anh_c) (cadr anh_c))))
					  pt_phu_3d (list (car pt_phu_2d) (cadr pt_phu_2d) (last anh_c))
					  pt_phu_w_3d (trans pt_phu_3d 1 0))
				(command "ucs" "za" (trans (nth 3  lst_point_w) 0 1) (trans (nth 4  lst_point_w) 0 1))
				(command "rotate" new "" 
					(setq base (trans (nth 3 lst_point_w) 0 1))
					(- (angle base (trans (nth 5 lst_point_w) 0 1)) (angle base (trans pt_phu_w_3d 0 1)))
				)
			)
		)
	)
)
(command "ucs" "na" "r" "save_ucs")
(command "ucs" "na" "d" "save_ucs")
;(command "-view" "r" "save_v")
;(command "-view" "d" "save_v")
(mapcar 'setvar lst_va old)
(princ)
)

 


<<

Filename: 318930_ve.lsp
Tác giả: Tue_NV
Bài viết gốc: 319553
Tên lệnh: dfd
lisp hiệu chỉnh mũi tên dimension?

E cảm ơn bác nhiều. nhưng cty e dùng CAD LT bản quyền và chạy thêm CADSTA Max hỗ trợ nên lisp này k dùng dk. bác có cách nào khắc phục dk k ah?

 

Mình không biết CAD LT hạn chế cái gì mà chạy không được

Nếu CADLT bạn đang sử dụng chạy với mã Lisp này thì mình sẽ viết bổ sung thêm...

>>

E cảm ơn bác nhiều. nhưng cty e dùng CAD LT bản quyền và chạy thêm CADSTA Max hỗ trợ nên lisp này k dùng dk. bác có cách nào khắc phục dk k ah?

 

Mình không biết CAD LT hạn chế cái gì mà chạy không được

Nếu CADLT bạn đang sử dụng chạy với mã Lisp này thì mình sẽ viết bổ sung thêm cho

Bạn thử xem :

(defun c:dfd (/ ss) 
(if (setq ss (ssget)) (command "._DIMOVERRIDE" "dimblk1" "Dot" "dimblk2" "Dot" "" ss "" ))
)

<<

Filename: 319553_dfd.lsp
Tác giả: Tot77
Bài viết gốc: 319583
Tên lệnh: ddm
nhờ viết lisp vẽ thêm đường đồng mức phụ

Bạn thử cái này, quét 2 đường đồng mức rồi nhập số khoảng chia, ở đây là 5.

(defun c:ddm (/ ss sk dd dn lst d1 dis n)
  
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "LWPOLYLINE"))))))
sk (getint "\nSo khoang chia:")
dd (car (vl-sort ss
   '(lambda (x y) (> (vlax-curve-getDistAtParam x (vlax-curve-getEndParam x))
     (vlax-curve-getDistAtParam y (vlax-curve-getEndParam...
>>

Bạn thử cái này, quét 2 đường đồng mức rồi nhập số khoảng chia, ở đây là 5.

(defun c:ddm (/ ss sk dd dn lst d1 dis n)
  
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "LWPOLYLINE"))))))
sk (getint "\nSo khoang chia:")
dd (car (vl-sort ss
   '(lambda (x y) (> (vlax-curve-getDistAtParam x (vlax-curve-getEndParam x))
     (vlax-curve-getDistAtParam y (vlax-curve-getEndParam y))))))
dn (car (vl-remove dd ss))
dd (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget dd)))
lst nil
  )
  (repeat (1- sk) (setq lst (cons '() lst)))
 
  (foreach d0 dd 
    (setq d1 (vlax-curve-getclosestpointto dn d0)
 dis (/ (distance d0 d1) sk)
          n 0)    
    (setq lst (mapcar '(lambda (x) (append x (list (polar d0 (angle d0 d1) (* (setq n (1+ n)) dis))))) lst)) 
  )
  (foreach v lst
    (entmake (append '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (100 . "AcDbPolyline"))
    (list (cons 90 (length v))) (mapcar '(lambda (x) (cons 10 x)) v  )
    ))
  )
  (princ)      
)

<<

Filename: 319583_ddm.lsp
Tác giả: Tot77
Bài viết gốc: 319620
Tên lệnh: ddm
nhờ viết lisp vẽ thêm đường đồng mức phụ

Đây bạn, nhưng nó chỉ làm với 2 poly hình dạng gần giống nhau thôi, còn dạng như yên ngựa thì chạy không đúng.

(defun c:ddm (/ ss dd dn lst d1 dis n)  
 
  (defun laydinh (en / l)
    (setq l nil)
    (if (= (cdr (assoc 70 (entget en))) 5) (setq tn t) (setq tn nil))
    (while (not (equal (cdr (assoc 0 (entget (setq en (entnext en))))) "SEQEND"))
      (setq l (cons (cdr (assoc 10 (entget en)))...
>>

Đây bạn, nhưng nó chỉ làm với 2 poly hình dạng gần giống nhau thôi, còn dạng như yên ngựa thì chạy không đúng.

(defun c:ddm (/ ss dd dn lst d1 dis n)  
 
  (defun laydinh (en / l)
    (setq l nil)
    (if (= (cdr (assoc 70 (entget en))) 5) (setq tn t) (setq tn nil))
    (while (not (equal (cdr (assoc 0 (entget (setq en (entnext en))))) "SEQEND"))
      (setq l (cons (cdr (assoc 10 (entget en))) l)))
    (if tn (setq l (cons (last l) l)))
    (reverse l)
  )
  
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "POLYLINE")))))))
  (if (not sokhoang) (setq sokhoang (getint "\nSo khoang chia:")))
  (setq dd (car (vl-sort ss '(lambda (x y) (> (vlax-curve-getDistAtParam x (vlax-curve-getEndParam x))
     (vlax-curve-getDistAtParam y (vlax-curve-getEndParam y))))))
dn (car (vl-remove dd ss))
dd (laydinh dd)
lst nil
  )
  (repeat (1- sokhoang) (setq lst (cons '() lst)))
 
  (foreach d0 dd 
    (setq d1 (vlax-curve-getclosestpointto dn d0)
 dis (/ (distance d0 d1) sokhoang)
          n 0)    
    (setq lst (mapcar '(lambda (x) (append x (list (polar d0 (angle d0 d1) (* (setq n (1+ n)) dis))))) lst)) 
  )
  (command "undo" "be")
  (foreach v lst
    (entmake '((0 . "POLYLINE") (66 . 1)) )
    (foreach v1 v (entmake (list '(0 . "VERTEX") (cons 10 v1))))
    (entmake '((0 . "SEQEND")))       
  )
  (command "undo" "e") (princ)      
)

<<

Filename: 319620_ddm.lsp
Tác giả: Tot77
Bài viết gốc: 319736
Tên lệnh: dkc
https://twitter.com/Healty_Pills

Bạn dùng lsp này, cái này đo kc từ 2 đầu dg cong, vì nhìu khi mình đâu biết cái nào đầu cái nào đuôi.

Chọn dg cong, điểm đầu và kc tới điểm đó.

 


(defun C:dkc()
  (defun cach (v p1 len / a1)
    (vlax-curve-getPointatDist v
       (abs (- (vlax-curve-getDistAtPoint v (vlax-curve-getClosestPointTo v p1)) len )))
  )
  (if (/=...
>>

Bạn dùng lsp này, cái này đo kc từ 2 đầu dg cong, vì nhìu khi mình đâu biết cái nào đầu cái nào đuôi.

Chọn dg cong, điểm đầu và kc tới điểm đó.

 


(defun C:dkc()
  (defun cach (v p1 len / a1)
    (vlax-curve-getPointatDist v
       (abs (- (vlax-curve-getDistAtPoint v (vlax-curve-getClosestPointTo v p1)) len )))
  )
  (if (/= (getvar 'pdmode) 3) (setvar 'pdmode 3))
  (entmake (list '(0 . "POINT")
(cons 10 (cach (car (entsel "\nChon duong cong:")) (getpoint "\nDiem dau:") (getreal "\nDo dai:"))))
  )
  (princ)
)

<<

Filename: 319736_dkc.lsp
Tác giả: Tue_NV
Bài viết gốc: 109539
Tên lệnh: kt
Viết lisp theo yêu cầu [phần 2]


@Bác Bình :
Lisp nó dai sức lắm bác ạ. Nó vẫn chạy tiếp tục và chạy tầm bậy. Đôi lúc chạy sai, có khi nó thiết lập không đúng ý của mình nữa
Nên ta mới đi kiểm tra, làm tường rào, chặn Lisp lại, không cho nó chạy nữa, hề hề...

Filename: 109539_kt.lsp
Tác giả: MANHHUNGXDA
Bài viết gốc: 13794
Tên lệnh: oo
Xin-đồ án về trung tâm thương mại và văn phòng cho thuê


Này, ông vào ký túc xá mà copy các đồ án tốt nghiệp, có nhiều loại lắm
nhiều nhất là cái đề tài của ông đấy.!

Filename: 13794_oo.lsp
Tác giả: hiepttr
Bài viết gốc: 302134
Tên lệnh: test1 test2
Bài tập Chương 8.2 - Tạo đối tượng mới với Entmake, entmakex -

Tiếp tục:

;;;Bai 2: Tao 10000 doi tuong bang command , ss entmake & nhan xet
;2.1: Tao bang command:
(defun c:test1( / old pt i)
(setq old (mapcar 'getvar '("osmode" "cmdecho")))
(mapcar 'setvar '("osmode" "cmdecho") '(0 0))
(setq pt (getpoint "\nChon diem: ")
	  i 0
	  st (getvar 'millisecs))
(while (< i 10000)
	(command ".point" pt)
	(setq i (1+ i)
		  pt (list (car pt) (cadr pt) (+ 5 (last pt))))
)
(princ (strcat "\nThoi gian chay 1: " (rtos (/...
>>

Tiếp tục:

;;;Bai 2: Tao 10000 doi tuong bang command , ss entmake & nhan xet
;2.1: Tao bang command:
(defun c:test1( / old pt i)
(setq old (mapcar 'getvar '("osmode" "cmdecho")))
(mapcar 'setvar '("osmode" "cmdecho") '(0 0))
(setq pt (getpoint "\nChon diem: ")
	  i 0
	  st (getvar 'millisecs))
(while (< i 10000)
	(command ".point" pt)
	(setq i (1+ i)
		  pt (list (car pt) (cadr pt) (+ 5 (last pt))))
)
(princ (strcat "\nThoi gian chay 1: " (rtos (/ (- (getvar 'millisecs) st) 1000.) 2 4) " giay."))
(mapcar 'setvar '("osmode" "cmdecho") old)
(princ)
)
;=============
(defun c:test2( / old pt i st cmd)
(setq old (mapcar 'getvar '("osmode" "cmdecho")))
(mapcar 'setvar '("osmode" "cmdecho") '(0 0))
(setq pt (getpoint "\nChon diem: ")
	  i 0
	  st (getvar 'millisecs))
(while (< i 10000)
	(entmake (list
		'(0 . "POINT")
		(cons 10 pt)
	))
	(setq i (1+ i)
		  pt (list (car pt) (cadr pt) (+ 5 (last pt))))
)
(princ (strcat "\nThoi gian chay 2: " (rtos (/ (- (getvar 'millisecs) st) 1000.) 2 4) " giay."))
(mapcar 'setvar '("osmode" "cmdecho") old)
(princ)
)
;======================
;;ket qua test
;Command: TEST2

;Chon diem:
;Thoi gian chay 2: 0.2500 giay.

;Command:
;Command: TEST1

;Chon diem:
;Thoi gian chay 1: 1.4530 giay.
;;;=======>>> entmake chay nhanh hon command nhieu, 
;;;==>>> & nhuoc diem cua entmake la code dai, de phat sinh loi khi chua quen !!!
;;=====================================================================================================
;;Bai3: entmake 1 dtuong bang layer ko ton tai ==> nhan xet
(entmake (list '(0 . "POINT") '(8 . "VD") (cons 10 (getpoint "\nChon diem: "))))
;===> NX: layer tu sinh ra voi cac dac tinh tuong tu layer "0" (mau 7, continuous)

<<

Filename: 302134_test1_test2.lsp
Tác giả: nhoclangbat
Bài viết gốc: 319807
Tên lệnh: kko kkj
Bài tập Chương 8.2 - Tạo đối tượng mới với Entmake, entmakex -

- anh Ket nhoc xin nộp bài C8 ^^

;==================================================BAI 1================================================================
;a ve line qua 2 diem
(defun K:line (pt1 pt2 layer clr / lst)
(setq lst (list
          '(0 . "LINE")
		  (cons 8 (if layer layer (getvar "Clayer")))
		  (cons 62 (if clr clr 256))
		  (cons 10 pt1)
		  (cons 11 pt2)))
(entmakex lst)
)
;b ve duong tron biet tam va duong kinh
(defun K:circle (pt dk...
>>

- anh Ket nhoc xin nộp bài C8 ^^

;==================================================BAI 1================================================================
;a ve line qua 2 diem
(defun K:line (pt1 pt2 layer clr / lst)
(setq lst (list
          '(0 . "LINE")
		  (cons 8 (if layer layer (getvar "Clayer")))
		  (cons 62 (if clr clr 256))
		  (cons 10 pt1)
		  (cons 11 pt2)))
(entmakex lst)
)
;b ve duong tron biet tam va duong kinh
(defun K:circle (pt dk layer clr / lst)
(setq lst (list
             '(0 . "CIRCLE")
			 (cons 8 (if layer layer (getvar "Clayer")))
		     (cons 62 (if clr clr 256))
			 '(100 . "AcDbCircle")
			 (cons 10 pt)
			 (cons 40 (/ dk 2.0))))
(entmakex lst)
)
;c ve tam giac deu pit 1canh va 1 dinh
(defun K:tamgiacdeu (pdinh canh layer clr / lst )
(setq lst (list
           '(0 . "LWPOLYLINE")
		   '(100 . "AcDbEntity")
		    (cons 8 (if layer layer (getvar "Clayer")))
		    (cons 62 (if clr clr 256))
			'(100 . "AcDbPolyline")
			(cons 90 3)
			(cons 70 1)
			(cons 10 pdinh)
			(cons 10 (polar pdinh 0 canh))
			(cons 10 (polar pdinh (/ (* 60 pi) 180) canh))))
(entmakex lst)
)
; d ve hinh chu nhat biet toa do 2 goc cheo
(defun K:chunhat (p1 p2 layer clr / lst)
(setq lst (list
           '(0 . "LWPOLYLINE")
		   '(100 . "AcDbEntity")
		    (cons 8 (if layer layer (getvar "Clayer")))
		    (cons 62 (if clr clr 256))
			'(100 . "AcDbPolyline")
			(cons 90 4)
			(cons 70 1)
			(cons 10 p1)
			(cons 10 (polar p1 (/ pi 2) (- (cadr p2) (cadr p1))))
			(cons 10 p2)
			(cons 10 (polar p1 0 (- (car p2) (car p1))))
			))
(entmakex lst)
)
; e ve hinh vuong biet toa do 1 diem va chieu dai 1 canh
(defun K:vuong (pt a layer clr / lst)
(setq lst (list
           '(0 . "LWPOLYLINE")
		   '(100 . "AcDbEntity")
		    (cons 8 (if layer layer (getvar "Clayer")))
		    (cons 62 (if clr clr 256))
			'(100 . "AcDbPolyline")
			(cons 90 4)
			(cons 70 1)
			(cons 10 pt)
			(cons 10 (polar pt (/ pi 2) a))
			(cons 10 (polar pt (/ pi 4) (* a (sqrt 2))))
			(cons 10 (polar pt 0 a)))
			)
(entmakex lst)
)
; f ve ellisp biet toa do 3 dinh
(defun K:ellisp (p1 p2 p3 layer clr / lst tam)
(setq tam (polar p1 (angle p1 p2) (/ (distance p1 p2) 2.0)))
(setq lst (list
           '(0 . "ELLIPSE")
		   '(100 . "AcDbEntity")
		    (cons 8 (if layer layer (getvar "Clayer")))
		    (cons 62 (if clr clr 256))
			'(100 . "AcDbEllipse")
			(cons 10 tam)
			(cons 11 (list (- (car p1) (car tam)) (- (cadr p1) (cadr tam)) 0.0))
			(cons 40 (/ (distance p3 tam) (distance tam p1))))
			)
(entmakex lst)
)
; g ham ve cung trong di qua 3 diem
(defun K:arc (p1 p2 p3 layer clr / lst tam timtam ang1 ang2 ang3)
(defun K:timtam (p1 p2 p3 / a b)
(setq a (polar p1 (angle p1 p2) (/ (distance p1 p2) 2.0)) b (polar p2 (angle p2 p3) (/ (distance p2 p3) 2.0)))
(inters a (polar a (- (angle p1 p2) (/ pi 2)) 9000) b (polar b (- (angle p2 p3) (/ pi 2)) 9000) nil)
)
(setq tam (K:timtam p1 p2 p3))
(setq ang1 (angle tam p1) ang2 (angle tam p2) ang3 (angle tam p3))
(if (or (< ang1 ang2 ang3) (< ang2 ang3 ang1) (< ang3 ang1 ang2))
  (progn
      (setq dxf50 ang1 dxf51 ang3))
   (progn
      (setq dxf50 ang3 dxf51 ang1))
)
(setq lst (list
             '(0 . "ARC")
			 '(100 . "AcDbEntity")
			 (cons 8 (if layer layer (getvar "Clayer")))
		     (cons 62 (if clr clr 256))
			 '(100 . "AcDbCircle")
              (cons 10 tam)
              (cons 40 (distance tam p1))
             '(100 . "AcDbArc")
              (cons 50 dxf50)
              (cons 51 dxf51)
))
(entmakex lst)
)
;===============================================****************************++++++++++BAI 4+++++++++*********************===========
(defun K:layer (ten clr)
(if (null (tblsearch "LAYER" ten))
(entmakex (list 
               '(0 . "LAYER")
               '(100 . "AcDbSymbolTableRecord")
               '(100 . "AcDbLayerTableRecord")
			   '(70 . 0)
                (cons 2 ten)
                (cons 62 clr))
)
)
)
;===========================================================================================so sanh command entmake
(defun c:kko(/ pt bk)
(setq bk (getreal "\nnhap:"))
(setq pt (getpoint "\ndatdiem:") begin (getvar "millisecs"))
(repeat 10000
(K:circle pt bk nil nil)
)
(setq end (getvar "millisecs"))
(princ (strcat "tong thoi gian thuc hien : " (rtos (/ (- end begin) 1000.0)) " giay"))
(princ)
)
;=====================
(defun c:kkj(/ pt bk)
(setvar "cmdecho" 0)
(setq bk (getreal "\nnhap:"))
(setq pt (getpoint "\ndatdiem:") begin (getvar "millisecs"))
(repeat 10000
(command ".circle" pt bk)
)
(setq end (getvar "millisecs"))
(princ (strcat "tong thoi gian thuc hien : " (rtos (/ (- end begin) 1000.0)) " giay"))
(setvar "cmdecho" 1)
(princ)
)			

- câu so sánh nhoc thử với entmake thì ok, còn command thì máy nhoc đơ lun kaka ^^

- câu tạo đối tượng có kèm layer, layer ko có trước thì vẫn tạo ra layer với tên mình đặt các thông số còn lại nó sẽ lấy mắc mặc định


<<

Filename: 319807_kko_kkj.lsp
Tác giả: Tot77
Bài viết gốc: 319832
Tên lệnh: test
Nhờ cách anh giúp về hàm vl-remove

Đây là code theo mô tả của bạn.

(defun c:test ()
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget))))
ss1 (vl-remove-if-not '(lambda (x) (and (= (dxf 0 x) "LWPOLYLINE")  (= (dxf 8 x) "LAYER1"))) ss)
ss2 (vl-remove-if-not '(lambda (x) (= (dxf 8 x) "LAYER2")) ss)
ss3 (vl-remove-if-not '(lambda (x) (= (dxf 0 x) "TEXT")) ss)
  )
)

Giải thích :

ss là...

>>

Đây là code theo mô tả của bạn.

(defun c:test ()
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget))))
ss1 (vl-remove-if-not '(lambda (x) (and (= (dxf 0 x) "LWPOLYLINE")  (= (dxf 8 x) "LAYER1"))) ss)
ss2 (vl-remove-if-not '(lambda (x) (= (dxf 8 x) "LAYER2")) ss)
ss3 (vl-remove-if-not '(lambda (x) (= (dxf 0 x) "TEXT")) ss)
  )
)

Giải thích :

ss là list gồm các đtượng được chọn.

ss1 :   loại bỏ các ptu của ss nếu không phải là pline và không thuộc layer1

ss2  :  loại bỏ các ptu của ss nếu không  thuộc layer2

ss3 :   loại bỏ các ptu của ss nếu không phải là text.


<<

Filename: 319832_test.lsp
Tác giả: ketxu
Bài viết gốc: 320116
Tên lệnh: sv
Hỏi cách xem nhiều file *.sld

Trong CAD :

Sử dụng script hoặc lisp tạo script hoặc viết form fill image slide vào.

Mình đóng gói 1 ví dụ cho bạn đây

http://www.cadviet.com/upfiles/3/24067_sv.rar

 

Code LSP :

(defun c:sv( / display_image sldpath slides dial_id sldx sldy)
(vl-load-com)
(defun display_image (img sldx sldy)
(start_image...
>>

Trong CAD :

Sử dụng script hoặc lisp tạo script hoặc viết form fill image slide vào.

Mình đóng gói 1 ví dụ cho bạn đây

http://www.cadviet.com/upfiles/3/24067_sv.rar

 

Code LSP :

(defun c:sv( / display_image sldpath slides dial_id sldx sldy)
(vl-load-com)
(defun display_image (img sldx sldy)
(start_image "slideimg")
(fill_image 0 0 sldx sldy -2)
(end_image)
(start_image "slideimg")
(slide_image 0 0 sldx sldy img)
(end_image)
)

(cond
((setq sldpath (getfiled "Select a Slide in Folder" "c:\\" "sld" 8))
(setq sldpath (strcat(vl-filename-directory sldpath)"\\")
slides (vl-directory-files sldpath "*.sld")
dial_id (load_dialog "slideview")
)
(new_dialog "slideview" dial_id)
(setq sldx(dimx_tile "slideimg")
sldy(dimy_tile "slideimg")
)
(start_list "slidelist")
(mapcar 'add_list slides)
(end_list)
(action_tile "slidelist"
"(display_image(strcat sldpath(nth(atoi $value)slides))sldx sldy)"
)
(setq next(start_dialog))
(unload_dialog dial_id)
)
)
(princ)
)

Code DCL :

// slideview.dcl

slideview : dialog {
label = "Slide Viewer";
: boxed_row {
: column {
: list_box {
label = "Slide List:";
key = "slidelist";
width = 20;
height = 24;
}
: button {
key = "exit";
label = "Exit";
is_cancel = true;
mnemonic = "E";
}
}
: image {
key = "slideimg";
aspect_ratio = 1.0;
fixed_width = true;
width = 114;
fixed_height = true;
height = 31.75;
color = graphics_background;
}
}
}	

Cái này cũng search thấy nhiều quá luôn


<<

Filename: 320116_sv.lsp
Tác giả: ketxu
Bài viết gốc: 320116
Tên lệnh: sv
Hỏi cách xem nhiều file *.sld

Trong CAD :

Sử dụng script hoặc lisp tạo script hoặc viết form fill image slide vào.

Mình đóng gói 1 ví dụ cho bạn đây

http://www.cadviet.com/upfiles/3/24067_sv.rar

 

Code LSP :

(defun c:sv( / display_image sldpath slides dial_id sldx sldy)
(vl-load-com)
(defun display_image (img sldx sldy)
(start_image...
>>

Trong CAD :

Sử dụng script hoặc lisp tạo script hoặc viết form fill image slide vào.

Mình đóng gói 1 ví dụ cho bạn đây

http://www.cadviet.com/upfiles/3/24067_sv.rar

 

Code LSP :

(defun c:sv( / display_image sldpath slides dial_id sldx sldy)
(vl-load-com)
(defun display_image (img sldx sldy)
(start_image "slideimg")
(fill_image 0 0 sldx sldy -2)
(end_image)
(start_image "slideimg")
(slide_image 0 0 sldx sldy img)
(end_image)
)

(cond
((setq sldpath (getfiled "Select a Slide in Folder" "c:\\" "sld" 8))
(setq sldpath (strcat(vl-filename-directory sldpath)"\\")
slides (vl-directory-files sldpath "*.sld")
dial_id (load_dialog "slideview")
)
(new_dialog "slideview" dial_id)
(setq sldx(dimx_tile "slideimg")
sldy(dimy_tile "slideimg")
)
(start_list "slidelist")
(mapcar 'add_list slides)
(end_list)
(action_tile "slidelist"
"(display_image(strcat sldpath(nth(atoi $value)slides))sldx sldy)"
)
(setq next(start_dialog))
(unload_dialog dial_id)
)
)
(princ)
)

Code DCL :

// slideview.dcl

slideview : dialog {
label = "Slide Viewer";
: boxed_row {
: column {
: list_box {
label = "Slide List:";
key = "slidelist";
width = 20;
height = 24;
}
: button {
key = "exit";
label = "Exit";
is_cancel = true;
mnemonic = "E";
}
}
: image {
key = "slideimg";
aspect_ratio = 1.0;
fixed_width = true;
width = 114;
fixed_height = true;
height = 31.75;
color = graphics_background;
}
}
}	

Cái này cũng search thấy nhiều quá luôn


<<

Filename: 320116_sv.lsp
Tác giả: Tot77
Bài viết gốc: 320130
Tên lệnh: vsl
Hỏi cách xem nhiều file *.sld

Tặng bạn cái máy chiếu phim di động mini.

Mở cái folder chứa file sld, nhấp đại file nào trong đó để lấy tên folder, mỗi slide sau khi xăm xoi thấy ok rồi thì nhấn space hoặc enter để chiếu cái tiếp theo.

 

(defun c:vsl()
  (if slddir
    (setq slddir (vl-filename-directory  (getfiled "Open file" (strcat slddir "\\") "sld" 4)))
    (setq slddir (vl-filename-directory (getfiled...
>>

Tặng bạn cái máy chiếu phim di động mini.

Mở cái folder chứa file sld, nhấp đại file nào trong đó để lấy tên folder, mỗi slide sau khi xăm xoi thấy ok rồi thì nhấn space hoặc enter để chiếu cái tiếp theo.

 

(defun c:vsl()
  (if slddir
    (setq slddir (vl-filename-directory  (getfiled "Open file" (strcat slddir "\\") "sld" 4)))
    (setq slddir (vl-filename-directory (getfiled "Open file" (getvar "dwgprefix") "sld" 4)))    
  )
  (foreach slide (vl-directory-files slddir "*.sld" 1)    
    (command "VSLIDE" (strcat slddir "\\" slide))
    (getstring)
  )
  (redraw)
)

<<

Filename: 320130_vsl.lsp
Tác giả: ndtnv
Bài viết gốc: 320127
Tên lệnh: nn
nhờ các bác viết cho em auto lisp nối các đường line rời rạc thành pline

Của bạn đây

(defun C:nn(/ f a)
    (setq f '((0 . "LINE,ARC,*POLYLINE")) a (getvar "PEDITACCEPT"))
    (setvar "PEDITACCEPT" 1)
    (if (setq e (car (entsel "Chon doi tuong loc layer: ")))
        (setq f (cons (assoc 8 (entget e)) f ))        )
    (vl-cmdf "PEDIT" "M" (ssget f) "" "J" "" "" )
    (setvar "PEDITACCEPT" a)
)

Filename: 320127_nn.lsp
Tác giả: nhoclangbat
Bài viết gốc: 320150
Tên lệnh: tlc
Đo khoảng cách hai điểm và ghi kết quả ra nơi minh chọn

- hi nhoc góp vui tí ^^, các dạng đường cong nhoc nghĩ chỉ có  cách chọn mới tính đc chiều dài của nó, nhoc mót đc của mấy anh, viết lại để tính riêng cho dạng đường cong, bạn dùng thử xem, còn gộp 2 cái của anh Tue lun thì suy nghĩ thêm ^^

;;;--------------------------------------------------------------------
(defun Length1(e) 
(vlax-curve-getDistAtParam e (vlax-curve-getEndParam...
>>

- hi nhoc góp vui tí ^^, các dạng đường cong nhoc nghĩ chỉ có  cách chọn mới tính đc chiều dài của nó, nhoc mót đc của mấy anh, viết lại để tính riêng cho dạng đường cong, bạn dùng thử xem, còn gộp 2 cái của anh Tue lun thì suy nghĩ thêm ^^

;;;--------------------------------------------------------------------
(defun Length1(e) 
(vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
;;;--------------------------------------------------------------------
(defun C:TLC(/ L edd ss1 e)
(prompt "Chon duong cong mun tinh kich thuoc")
(while (setq ss1 (ssget "+.:E:S" (list (cons 0 "ARC,CIRCLE,ELLIPSE,SPLINE"))))
(progn
(setq L 0.0)
(while (setq e (ssname ss1 0))    
	(setq L (+ L (length1 e)))    
	(ssdel e ss1))
(setq edd (entget (car (entsel "\nchon text ghi ket qua:"))))
(entmod (subst (cons 1 (rtos L 2 2)) (assoc 1 edd) edd))
)
)
(princ "\n")
(princ "xong")
(princ)
)

<<

Filename: 320150_tlc.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 320166
Tên lệnh: vsl
Hỏi cách xem nhiều file *.sld

Ek :wacko: , thay dòng (getstring) bằng (command "delay" "3000") thì thử trong Folder có 3 slide lisp chạy dừng 3s cái rẹt luôn 1 hình :blink: khỏi thấy 2 hình kia :wub:

Trong trường hợp này Delay không được. Thì chuyển qua Wait vậy.

(defun c:vsl()
  (if slddir
    (setq slddir...
>>

Ek :wacko: , thay dòng (getstring) bằng (command "delay" "3000") thì thử trong Folder có 3 slide lisp chạy dừng 3s cái rẹt luôn 1 hình :blink: khỏi thấy 2 hình kia :wub:

Trong trường hợp này Delay không được. Thì chuyển qua Wait vậy.

(defun c:vsl()
  (if slddir
    (setq slddir (vl-filename-directory  (getfiled "Open file" (strcat slddir "\\") "sld" 4)))
    (setq slddir (vl-filename-directory (getfiled "Open file" (getvar "dwgprefix") "sld" 4)))    
  )
  (foreach slide (vl-directory-files slddir "*.sld" 1)    
    (command "VSLIDE" (strcat slddir "\\" slide))
    (wait 3)
;(command "delay" 3000)
;    (getstring)
  )
  (redraw)
)
(defun wait (seconds / stop)
 (setq stop (+ (getvar "DATE") (/ seconds 86400.0)))
 (while (> stop (getvar "DATE"))
  (princ)))
 


<<

Filename: 320166_vsl.lsp
Tác giả: nhoclangbat
Bài viết gốc: 320178
Tên lệnh: tl3
Đo khoảng cách hai điểm và ghi kết quả ra nơi minh chọn

- ah vậy ý bạn đó là lấy khoảng cách 2 điểm bất kỳ thuộc đường đã chọn ^^, theo gợi ý anh Ket nhoc viết lại thế này xem bạn đó vừa ý chưa hì :)

;=======================
(defun _d2p(e p1 p2) ;Getdist along curve by : Ename P1 P2	
	(abs (apply '- (mapcar '(lambda(x)(vlax-curve-getDistAtPoint e (trans (vlax-curve-getclosestpointto e x) 1 0))) (list p1 p2))))
)
;====================================
(defun...
>>

- ah vậy ý bạn đó là lấy khoảng cách 2 điểm bất kỳ thuộc đường đã chọn ^^, theo gợi ý anh Ket nhoc viết lại thế này xem bạn đó vừa ý chưa hì :)

;=======================
(defun _d2p(e p1 p2) ;Getdist along curve by : Ename P1 P2	
	(abs (apply '- (mapcar '(lambda(x)(vlax-curve-getDistAtPoint e (trans (vlax-curve-getclosestpointto e x) 1 0))) (list p1 p2))))
)
;====================================
(defun C:TL3(/ ss L te p1 p2 textmau P enty old)
(setq old (getvar 'osmode))
(setvar 'osmode 545)
(prompt "chon doi tuong")
(while (and 
            (setq ss (ssget "+.:E:S" (list (cons 0 "*LINE,ARC,CIRCLE,ELLIPSE,SPLINE"))))
            (setq p1 (getpoint "\n Chon diem thu nhat :")) 
            (setq p2 (getpoint p1 "\n Chon diem thu hai :"))
			)
(setq enty (ssname ss 0))
(setq L (_d2p enty p1 p2))
(setq p (getpoint "\nPick diem chen hoac enter bo qua de chon Text :"))
 
(cond ((/= p nil)
  
    (if (not textmau) (setq textmau (car(entsel "\nChon Text mau:"))))
    (entmake (list (cons 0 "TEXT") (cons 1 (rtos L 2 2)) (assoc 40 (entget textmau)) 
  (cons 10 p) (cons 11 p) (assoc 7 (entget textmau)) 
    ))
  )
  ((= p nil)
  (setq te (entget (car (entsel "\n Chon Text de gan ket qua :")))
        te (subst (cons 1 (rtos L 2 2)) (assoc 1 te) te))
(entmod te)
  )
)
(princ "\n")
(prompt "chon doi tuong")
)
(setvar 'osmode old)
(princ)
)

<<

Filename: 320178_tl3.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 320191
Tên lệnh: vsl
Hỏi cách xem nhiều file *.sld

Thanks bạn Doan Van Ha :) .Test đã OK. Nhưng nếu có thể cho trình chiếu lập lại cho đến khi Enter kết thúc trình chiếu thì lisp này tuyệt vời :P .

Được voi đòi 2 bà Trưng hè!

Lisp đây! Nó lặp hết 1 lượt trong thư...

>>

Thanks bạn Doan Van Ha :) .Test đã OK. Nhưng nếu có thể cho trình chiếu lập lại cho đến khi Enter kết thúc trình chiếu thì lisp này tuyệt vời :P .

Được voi đòi 2 bà Trưng hè!

Lisp đây! Nó lặp hết 1 lượt trong thư mục thì lại lặp lượt khác, chừng nào chưa nhấn Enter hoặc Space.

(defun c:vsl(/ lst grr)
 (if slddir
  (setq slddir (vl-filename-directory  (getfiled "Open file" (strcat slddir "\\") "sld" 4)))
  (setq slddir (vl-filename-directory (getfiled "Open file" (getvar "dwgprefix") "sld" 4))))
 (setq lst (vl-directory-files slddir "*.sld" 1))
 (while (and (setq grr (grread T 4 0)) (not (equal '(2 32) grr)) (not (equal '(2 13) grr)))  
  (command "VSLIDE" (strcat slddir "\\" (car lst)))
  (setq lst (cdr lst))
  (if (not lst) (setq lst (vl-directory-files slddir "*.sld" 1)))
  (wait 3))
  (redraw))
(defun wait (seconds / stop)
 (setq stop (+ (getvar "DATE") (/ seconds 86400.0)))
 (while (> stop (getvar "DATE"))
  (princ)))
 

 


<<

Filename: 320191_vsl.lsp
Tác giả: nhoclangbat
Bài viết gốc: 320288
Tên lệnh: kmp
Đo khoảng cách hai điểm và ghi kết quả ra nơi minh chọn

- nhoc mới viết đc phần chính ^^, ban test xem có đúng ý bạn chưa, sau khi chọn Pline lsp sẽ xuất bảng thông báo danh sách các cạnh và các góc kẹp, bạn nên làm thủ công trước rùi dùng lsp xem lsp trả về có đúng chưa hì ^^, nếu ok bạn trình bày rõ kết quả cuối cùng bạn mún nó như thế nào nhoc sẽ mông má lại lsp, file cad minh họa càng tốt ^^

>>

- nhoc mới viết đc phần chính ^^, ban test xem có đúng ý bạn chưa, sau khi chọn Pline lsp sẽ xuất bảng thông báo danh sách các cạnh và các góc kẹp, bạn nên làm thủ công trước rùi dùng lsp xem lsp trả về có đúng chưa hì ^^, nếu ok bạn trình bày rõ kết quả cuối cùng bạn mún nó như thế nào nhoc sẽ mông má lại lsp, file cad minh họa càng tốt ^^

;;----------------------------------------------------------------------------------------------
(defun c:kmp (/ ss ename lst lstcanh lstgoc dem p1 p2 p3 d ang1 ang2 goc kdo)
  (vl-load-com)
  (prompt "chon PLine:")
  (setq ss (ssget "+.:E:S" '((0 . "LWPOLYLINE"))))
  (setq ename (ssname ss 0))
  (setq lst (acet-geom-vertex-list ename))
  (setq lstcanh nil
	     lstgoc nil)
;================================================
  (setq p1 (car lst)
	dem 1)
;===============================================================
  (while (< dem  (length lst))
    (setq p2 (nth dem lst))
    (setq d (distance p1 p2))
    (setq lstcanh (append lstcanh (list d)))
    (setq p1 p2
	  dem (1+ dem))
    (princ)
    )
;==================================================================================
  (setq p1 (car lst)
	dem 1)
;===============================================================================
  (while (< dem  (1- (length lst)))
    (setq p2 (nth  dem lst))
    (setq p3 (nth  (1+ dem) lst))
    (setq ang1 (angle p2 p1)
	  ang2 (angle p2 p3))
    (setq goc (abs (- ang1 ang2)))
    (if (> goc PI)
      (setq goc (- (* 2 pi) goc))
      )
;================================================================================
    (setq kdo (* (/ goc pi) 180.0))
    (setq lstgoc (append lstgoc (list kdo)))
;====================================================================================
    (setq p1 p2
	  dem (1+ dem))
   )
(alert (strcat "Danh sach chieu dai cac canh: " (vl-princ-to-string lstcanh) "\nDanh sach cac goc kep: " (vl-princ-to-string lstgoc)))
); end KMP


<<

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

- anh Ket khi nào a happy trở lại xem dùm nhoc hen, lang thang nhot mót đc làm lại hàm vẽ thang gọn hơn liên tục hơn = pline ^^

;; 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...
>>

- anh Ket khi nào a happy trở lại xem dùm nhoc hen, lang thang nhot mót đc làm lại hàm vẽ thang gọn hơn liên tục hơn = pline ^^

;; 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))))
;;;;;    
;;;;ve cau thang
(defun kkkv ()
(command ".pline")
                          (command pt)
		                    (repeat sb
						       (command (strcat "@0," (rtos cb))) 
                               (command (strcat "@" (rtos rb) ",0"))
                               							   
						     )
							 (command "")
)
;;;;
(defun danhso (/ codanh ptn ptn1)
(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
						  (setq ptn (polar pt (/ pi 2) (+ cb 0.05)))
                                                  (setq ptn1 (list (+ (car pt) rb) (+ (cadr pt) cb) 0)) 					  
						  (repeat sb
							 (command "text" ptn (/ cb 1.5) 0 (itoa (setq i (1+ i))))
							 (setq ptn (polar ptn (angle pt ptn1) (distance pt ptn1))))
						  (kkkv)
							 
						   )
						 (kkkv)
						 )
)


;;;; bai 7 + 8 : ve cau thang them lua chon co danh so bac hay ko ^^
(defun c:vktt (/ lst_va old key pt4 pt5 pt6 pt7 )
(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: 313908_vktt.lsp

Trang 180/304

180