Jump to content
InfoFile
Tác giả: Kieu Tan
Bài viết gốc: 409580
Tên lệnh: mb
Viết Chữ Tiếng Việt Trong Lisp (Unicode)

 

>>

 

 

Mình có đoạn lsp dùng để viết chữ (chữ mặc định), nhưng sau khi gõ lệnh và dùng thì nó bị lỗi font 

Mình muốn dùng font arial (bảng mã unicode, kiểu gõ vni)

Mình muốn ghi ra là chữ" MẶT BẰNG TÔN MÁI 

Mong mọi người sửa dùm tí, mình xin cảm ơn ! 


(DEFUN C:MB (/ TILE P)
  (IF (= (TBLOBJNAME "STYLE" "ARIAL") NIL)
  	(command ".STYLE" "ARIAL" "VNI-ARIAL" "" "" "" "" "" "")
    )
  (SETQ
	tile (getint "\nTi le: ")
	p (getpoint "\nChon diem chen text: ")
	)
  (COMMAND "TEXT" "S" "ARIAL" "J" "MC" P (* TILE 2) "0" "%%UMẶT BẰNNG TÔN MÁI"
	            )
)




Thử cái này xem nhé ^_^ máy mình ko có vni-arial nên thay bằng helve

(DEFUN C:MB (/ tile p)
  (IF (= (TBLOBJNAME "STYLE" "ARIAL") NIL)
;(command ".STYLE" "ARIAL" "VNI-ARIAL" "" "" "" "" "" "")
    (entmake '((0 . "STYLE")
	       (100 . "AcDbSymbolTableRecord")
	       (100 . "AcDbTextStyleTableRecord")
	       (2 . "ARIAL")	;style name 
	       (3 . "VNI-HELVE.TTF")	;font file 
	       (70 . 0)
	       (40 . 0.0)
	       (41 . 1.0)
	       (50 . 0.0)
	       (71 . 0)
	      )
    )
  )
  (SETQ
    tile (getint "\nTi le: ")
    p	 (getpoint "\nChon diem chen text: ")
  )
;;;  (COMMAND "TEXT" "S" "ARIAL" "J" "MC" P (* TILE 2) "0" "%%UM?T B?NNG TÔN MÁI"
  (entmake (list
	     (cons 0 "TEXT")
	     (cons 1 "MAËT BAÈNG TOÂN MAÙI")
	     (cons 10 p)
	     (cons 40 (* tile 2))
	     (cons 7 "ARIAL")
	   )
  )

)

 

Không được bạn ơi, Nếu máy không có font vni-arial thì phải cài hay sao vậy bạn? Và nếu cài thì cài như thế nào vậy bạn?


<<

Filename: 409580_mb.lsp
Tác giả: SoftvnBin
Bài viết gốc: 205444
Tên lệnh: ddt
Nhờ giúp Lisp tính diện tích và lập bảng

Hề hề hề,

Mình giúp bạn lần này đưa vấn đề bạn hỏi về cùng topic gốc. Lần sau bạn nên rút kinh nghiệm để diễ...

>>

Hề hề hề,

Mình giúp bạn lần này đưa vấn đề bạn hỏi về cùng topic gốc. Lần sau bạn nên rút kinh nghiệm để diễ đàn đỡ rối rắm.

Bạn dùng thử cái này xem đã ưng ý chưa nhé.


(defun c:ddt(/ lacol ladin laos tl h tl1 cao1 k tdt ss pt p1 p2 p3 p4 p5 p6 p7 p8
                       pa pt1 pt2 e ep p9 p10 p11 p12 p13 et dtcon )
 (setvar "cmdecho" 0)
 (setq lacol (getvar "CEColor"))
 (setq ladin (getvar "dimzin"))
 (setq laos (getvar "osmode"))  
 (if (not tl) (setq tl 1))
 (if (not h) (setq h 1))
 (setq tl1 (getreal (strcat "\nty le ban ve < 1/" (rtos tl 2 0) " >: 1/"))
caot1 (getreal (strcat "\nCao text < " (rtos h 2 0) " >: ")))
 (if tl1 (setq tl tl1))
 (if caot1 (setq h caot1))
 (command "undo" "be")
 (setq  k 0
tdt 0)
 (setq ss (ssadd))

(setvar "dimzin" 0)
(setvar "OSMODE" 0)
(setq PT (getpoint "\nChon diem xuat bang thong ke dien tich (mep trai):"))
(setq  P1 (list (+ (car PT)(* 6 h)) (cadr PT))
P2 (list (+ (car PT)(* 22 h)) (cadr PT))
P3 (list (car PT) (- (cadr PT)(* 3 h)))
P4 (list (car P1) (cadr P3))
P5 (list (car P2) (cadr P3))
P6 (list (+ (car PT)(* 11 h)) (+ (cadr PT)(* 2 h)))
P7 (list (+ (car PT)(* 3 h)) (- (cadr PT)(* 1.5 h)))
P8 (list (+ (car PT)(* 14 h)) (- (cadr PT)(* 1.5 h)))
);setq
(command  "pline" PT P2 P5 P3 "C"
"pline" P1 P4 ""
"text" "m" P6 (* 1.2 h) 0 "Bang thong ke dien tich"
"text" "m" P7 h 0 "STT"
"text" "m" P8 h 0 "Dien tich (mm2)"
);command
(setq PA  (getstring "\n Ban chon phuong an chon doi tuong < 1 or 2 > : "))
(if (= pa "1")
   (setq pt1 (getpoint "\n Chon mien tinh dien tich : "))
   (setq ep (car (setq e (entsel "\n Chon doi tuong la polyline kin")))
             pt2 (cadr e)  )
)
 (while (or (/= pt1 nil) (/= ep nil) )
(setq k (+ 1 k))
                 (if pt1
(command "TEXT" "m" pt1 (* 1 h) 0 (rtos k 2 0))
                 )
                 (if ep
                 (command "TEXT" "m" pt2 (* 1 h) 0 (rtos k 2 0))
                 )
(setq  PT (list (car P3) (cadr P3))
P1 (list (+ (car PT)(* 6 h)) (cadr PT))
P2 (list (+ (car PT)(* 22 h)) (cadr PT))
P3 (list (car PT) (- (cadr PT)(* 3 h)))
P4 (list (car P1) (cadr P3))
P5 (list (car P2) (cadr P3))
P7 (list (+ (car PT)(* 3 h)) (- (cadr PT)(* 1.5 h)))
P8 (list (+ (car PT)(* 14 h)) (- (cadr PT)(* 1.5 h)))
P9 (list (car PT) (- (cadr P3)(* 3 h)))
P10 (list (car P1) (cadr P9))
P11 (list (car P2) (cadr P9))
P12 (list (car P7) (- (cadr P3)(* 1.5 h)))
P13 (list (car P8) (cadr P12))
);setq
                 (if  pt1
                     (progn
       (command "CECOLOR" 4 "-boundary" pt1 "" )
       (setvar "CECOLOR" lacol)
       (setq et (entlast))
       (ssadd et ss)
       (command "area" "e" "last")
                     )
                 )
                 (if ep
                     (command "area" "o" ep)
                 )
;;;;;;(setq et (entlast))
;;;;;;(ssadd et ss)
(setq dtcon (* (getvar "AREA") tl tl))
(setq tdt (+ dtcon tdt))
(command "erase" ss "")

(command "pline" PT P2 P5 P3 "C"
"pline" P1 P4 ""
"text" "m" P7 h 0 (rtos k 2 0)
"text" "m" P8 h 0 (rtos dtcon 2 2))
                 (if pt1
(setq pt1 (getpoint "\n chon mien tinh dien tich tiep theo hoac enter de ket thuc lenh..."))
                 )
                 (if ep
                     (setq ep (car (setq e (entsel "\n Chon polyline tiep theo hoạc enter de ket thuc lenh ..."))) pt2 (cadr e)  )
                 )
);while
(setq ss nil)
(setvar "DIMZIN" ladin)
(command  "pline" P3 P9 P11 P5 "C"
"pline" P10 P4 ""
"text" "m" P12 h 0 "Tong"
"text" "m" P13 h 0 (rtos tdt 2 2)
);command
(command "undo" "e")
(setvar "OSMODE" laos)
(setvar "cmdecho" 1)
(princ)
)

Chúc bạn vui......

 

Mình lại làm phiền bạn nhé, nhờ bạn giúp mình sửa như sau:

 

 

1. Nhập tên lệnh: AAA

2. Nhập tỷ lệ bản vẽ <1000, 100, 10, 1>: 1000 (sẽ gợi nhớ số này cho lần thực hiện tiếp)

3. Nhập đơn vị xuất <m, dm, cm, mm>: m (tương ứng với 1000 ở trên) (sẽ gợi nhớ số này cho lần thực hiện tiếp)

4. Nhập trọng lượng riêng <2500>: 2500 (sẽ gợi nhớ số này cho lần thực hiện tiếp)

5. Pick vị trí đặt bảng <đỉnh mép trái>:

6. Chọn kiểu <1: Pick miền, 2: Pick đường bao>:

7. Chọn vùng tính toán:

 

Kết quả sẽ cho ra như sau:

17200_gui_caviet_2.jpg


<<

Filename: 205444_ddt.lsp
Tác giả: ThanhDattdk
Bài viết gốc: 404902
Tên lệnh: trai
Vẽ Polyline Bám Theo Các Polyline Trước(Ý Tưởng Trải Vải Địa)

 

Mấy hôm nay bận nên Rep bạn hơi muộn ^^

Chúc công việc suôn sẻ !

;lisp trai vai...
>>

 

Mấy hôm nay bận nên Rep bạn hơi muộn ^^

Chúc công việc suôn sẻ !

;lisp trai vai dia
;=================================
(defun MakeLWPolyline (listpoint closed Linetype LTScale Layer Color xdata / Lst)	
(setq Lst (list '(0 . "LWPOLYLINE")'(100 . "AcDbEntity")									
				(cons 8 (if Layer Layer (getvar "Clayer")))								  
				(cons 6 (if Linetype Linetype "bylayer"))									
				(cons 48 (if LTScale LTScale 1))									
				(cons 62 (if Color Color 256))									
				'(100 . "AcDbPolyline")									
				(cons 90 (length listpoint))									
				(cons 70 (if closed 1 0))))	
(foreach PP listpoint	
	(setq Lst (append Lst (list (cons 10 PP))))
	)	
				(if xdata (setq Lst (append lst (list (cons -3 (list xdata))))))	
				(entmakex Lst)
)	;end
;===================================
(defun get_lst_vertex (PL / lst)
	(setq lst (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= 10 (car x))) (entget PL))))
	(if (< (car (car lst)) (car (last lst))) lst (reverse lst))
)
;=============================================================================================
(defun c:TRAI ( / cmd ss_coc ins_point ss lst_ver len i)
(setq cmd (getvar 'cmdecho))
(setvar 'cmdecho 0)
(prompt "\nQuet chon trac ngang: ")
(setq ss_coc (ssget '((0 . "TEXT") (8 . "entdauco") (1 . "C*c:*"))))
(if ss_coc 
	(progn
		(setq ss_coc (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss_coc))))
		(foreach coc ss_coc
			(setq ins_point (cdr (assoc 11 (entget coc)))
				  ss (ssget "_W" (list (- (car ins_point) 17) (- (cadr ins_point) 15)) (list (+ (car ins_point) 17) (cadr ins_point))
						(list (cons 8 "VetHuuCo,Danh cap"))))
			(if ss
				(progn
					(setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
						  ss (vl-sort ss '(lambda (x y)  (< (car (car (get_lst_vertex x))) (car (car (get_lst_vertex y))))))
					)
					(setq lst_ver (get_lst_vertex (car ss)))
					(cond 
						((> (setq len (length ss)) 1)
							(setq i 0)
							(repeat (- len 1)
								(setq lst_ver (reverse (cdr (reverse lst_ver)))
									lst_ver (append lst_ver (cdr (get_lst_vertex (nth (setq i (1+ i)) ss))))
								)
							)
						)
					)
					(setq lst_ver 
						(append 
							(list (list (1+ (car (car lst_ver))) (cadr (car lst_ver))))
							lst_ver 
							(list (list (1- (car (last lst_ver))) (cadr (last lst_ver))))
						))
					(MakeLWPolyline lst_ver nil nil nil "Vai_dia_KT" 4 nil)
				)
			)
		)
	)
)
(setvar 'cmdecho cmd)
(princ)
)

em cảm ơn bác.rút ngắn thời gian rất nhiều, em chỉ mới tập tành chưa hiểu nhiều, bác có thể cho em biết sơ về thuật toán ko ạ.chúc bác sức khỏe


<<

Filename: 404902_trai.lsp
Tác giả: namgiangduy89
Bài viết gốc: 386520
Tên lệnh: aaa
Nhờ giúp Lisp tính diện tích và lập bảng

Hề hề hề,

Đêm có tí đêm , ngày có tí ngày chớ bộ.

Đây là cái tí đêm hôm qua cho bạn nè:

>>

Hề hề hề,

Đêm có tí đêm , ngày có tí ngày chớ bộ.

Đây là cái tí đêm hôm qua cho bạn nè:

 
(defun c:aaa (/ lacol ladin laos tl esty h tl1 cao1 k tdt ss pt p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 p11 p12 p13
                        p14 p15 p16 p17 p18 p19 p20 pa pt1 pt2 e ep  et dtcon cvcon klcon klt klr kl0 cvt ten oldla)
  (setvar "cmdecho" 0)
  (setq lacol (getvar "CEColor"))
  (setq ladin (getvar "dimzin"))
  (setq laos (getvar "osmode"))
  (setq oldla (getvar "clayer"))
  (setq esty (tblsearch "style" (getvar "textstyle")))
  (if (not tl) (setq tl 1))
  (if (= (cdr (assoc 40 esty)) 0.0)
      (if (= (cdr (assoc 42 esty)) 0.0) (setq h 1) (setq h (cdr (assoc 42 esty)))  )
   	(progn
       	(setq h (cdr (assoc 40 esty)))
       	(command "style" (getvar "textstyle") "" 0.0 "" "" "" "")          
   	)
  )
  (if (not kl0) (setq kl0 2500))
  (setq tl1 (getreal (strcat "\nty le ban ve < 1/" (rtos tl 2 0) " >: 1/"))
            caot1 (getreal (strcat "\nCao text < " (rtos h 2 0) " >: "))
            klr (getreal (strcat "\n Khoi luong rieng < " (rtos kl0 2 2) " >: ")))
  (if tl1 (setq tl tl1))
  (if caot1 (setq h caot1))
  (if klr (setq kl0 klr) (setq klr kl0) )
  (command "undo" "be")
  (setq  k 0 tdt 0 cvt 0 klt 0)
  (setq ss (ssadd))
 
(setvar "dimzin" 0)
(setvar "OSMODE" 0)
(setq PT (getpoint "\nChon diem xuat bang thong ke dien tich (mep trai):"))
(setq  P1 (list (+ (car PT)(* 6 h)) (cadr PT))
P2 (list (+ (car PT)(* 22 h)) (cadr PT))
P3 (list (car PT) (- (cadr PT)(* 3 h)))
P4 (list (car P1) (cadr P3))
P5 (list (car P2) (cadr P3))
P6 (list (+ (car PT)(* 45 h)) (+ (cadr PT)(* 2 h)))
P7 (list (+ (car PT)(* 3 h)) (- (cadr PT)(* 1.5 h)))
P8 (list (+ (car PT)(* 14 h)) (- (cadr PT)(* 1.5 h)))
P9 (list (+ (car P2) (* 16 h)) (cadr P2))
P10 (list (+ (car P9) (* 16 h)) (cadr P9))
P11 (list (+ (car P10) (* 20 h)) (cadr P10))
P12 (list (+ (car P11) (* 16 h)) (cadr P11))
P13 (list  (car P9) (cadr P5))
P14 (list (car P10) (cadr P5))
P15 (list (car P11) (cadr P5))
P16 (list (car P12) (cadr P5))
P17 (list (+ (car P8) (* 16 h)) (cadr P8))
P18 (list (+ (car P17) (* 16 h)) (cadr P8))
P19 (list (+ (car P18) (* 18 h)) (cadr P8))
P20 (list (+ (car P19) (* 18 h)) (cadr P8))
);setq
(setvar "clayer" "khung duong")
(command  "pline" PT P12 P16 P3 "C"
"pline" P1 P4 "" "pline" P2 P5 "" "pline" p9 p13 "" "pline" p10 p14 "" "pline" p11 p15 "" "pline" p12 p16 "")
(setvar "clayer" "text")
(command "text" "m" P6 (* 1.35 h) 0 "BANG THONG KE TONG HOP"
"text" "m" P7 (* 1.2 H) 0 "STT"
"text" "m" P8 (* 1.2 h) 0 "TEN VUNG"
"TEXT" "M" P17 (* 1.2 h) 0 "CHU VI (M)"
"TEXT" "M" P18 (* 1.2 h) 0 "DIEN TICH (M2)"
"TEXT" "M" P19 (* 1.2 h) 0 "KHOI LUONG (KG)"
"TEXT" "M" P20 (* 1.2 h) 0 "GHI CHU"
);command
(setq PA  (getstring "\n Ban chon phuong an chon doi tuong < 1 or 2 > : "))
(if (= pa "1")
    (setq pt1 (getpoint "\n Chon mien tinh dien tich : "))
    (setq ep (car (setq e (entsel "\n Chon doi tuong la polyline kin")))
              pt2 (cadr e)  )
)
  (while (or (/= pt1 nil) (/= ep nil) )
     	(setq k (+ 1 k))
     	(if pt1
              (command "TEXT" "m" pt1 (* 1.2 h) 0 (rtos k 2 0))
     	)
     	(if ep
              (command "TEXT" "m" pt2 (* 1.2 h) 0 (rtos k 2 0))
     	)
(setq PT (list (car P3) (cadr P3) )
P1 (list (+ (car PT)(* 6 h)) (cadr PT))
P2 (list (+ (car PT)(* 22 h)) (cadr PT))
P3 (list (car PT) (- (cadr PT)(* 3 h)))
P4 (list (car P1) (cadr P3))
P5 (list (car P2) (cadr P3))
;;;;P6 (list (+ (car PT)(* 43 h)) (+ (cadr PT)(* 2 h)))
P7 (list (+ (car PT)(* 3 h)) (- (cadr PT)(* 1.5 h)))
P8 (list (+ (car PT)(* 14 h)) (- (cadr PT)(* 1.5 h)))
P9 (list (+ (car P2) (* 16 h)) (cadr P2))
P10 (list (+ (car P9) (* 16 h)) (cadr P9))
P11 (list (+ (car P10) (* 20 h)) (cadr P10))
P12 (list (+ (car P11) (* 16 h)) (cadr P11))
P13 (list  (car P9) (cadr P5))
P14 (list (car P10) (cadr P5))
P15 (list (car P11) (cadr P5))
P16 (list (car P12) (cadr P5))
P17 (list (+ (car P8) (* 16 h)) (cadr P8))
P18 (list (+ (car P17) (* 16 h)) (cadr P8))
P19 (list (+ (car P18) (* 18 h)) (cadr P8))
P20 (list (+ (car P19) (* 18 h)) (cadr P8))
);setq
                  (if  pt1
                      (progn
        (command "CECOLOR" 4 "-boundary" pt1 "" )
        (setvar "CECOLOR" lacol)
        (setq et (entlast))
        (ssadd et ss)
        (command "area" "e" "last")
                      )
                  )
                  (if ep
                      (command "area" "o" ep)
                  )
;;;;;;(setq et (entlast))
;;;;;;(ssadd et ss)
(setq dtcon (* (getvar "AREA") tl tl))
(setq tdt (+ dtcon tdt))
(setq cvcon (* (getvar "Perimeter") tl)
          cvt (+ cvt cvcon)
          klcon (* dtcon klr)
          klt (+ klt klcon)
          ten (strcat "\n VUNG " (rtos k 2 0))
)
(command "erase" ss "")
(setvar "clayer" "khung duong")
(command  "pline" PT P3 P16 P12 ""
"pline" P1 P4 "" "pline" P2 P5 "" "pline" p9 p13 "" "pline" p10 p14 "" "pline" p11 p15 "" "pline" p12 p16 "")
(setvar "clayer" "text")
(command "text" "m" P7 h 0 (rtos k 2 0)
"text" "m" P8 h 0 ten
"TEXT" "M" P17 (* 1.0 h) 0 (rtos cvcon 2 2)
"TEXT" "M" P18 (* 1.0 h) 0 (rtos dtcon 2 2)
"TEXT" "M" P19 (* 1.0 h) 0 (rtos klcon 2 2)
"TEXT" "M" P20 (* 1.0 h) 0 ten )
                  (if pt1
(setq pt1 (getpoint "\n chon mien tinh dien tich tiep theo hoac enter de ket thuc lenh..."))
                  )
                  (if ep
                      (setq ep (car (setq e (entsel "\n Chon polyline tiep theo hoac enter de ket thuc lenh ..."))) pt2 (cadr e)  )
                  )
);while
(setq ss nil)
(setvar "DIMZIN" ladin)
(setq  PT (list (car P3) (cadr P3))
P1 (list (+ (car PT)(* 6 h)) (cadr PT))
P2 (list (+ (car PT)(* 22 h)) (cadr PT))
P3 (list (car PT) (- (cadr PT)(* 3 h)))
P4 (list (car P1) (cadr P3))
P5 (list (car P2) (cadr P3))
;;;P6 (list (+ (car PT)(* 43 h)) (+ (cadr PT)(* 2 h)))
P7 (list (+ (car PT)(* 3 h)) (- (cadr PT)(* 1.5 h)))
P8 (list (+ (car PT)(* 14 h)) (- (cadr PT)(* 1.5 h)))
P9 (list (+ (car P2) (* 16 h)) (cadr P2))
P10 (list (+ (car P9) (* 16 h)) (cadr P9))
P11 (list (+ (car P10) (* 20 h)) (cadr P10))
P12 (list (+ (car P11) (* 16 h)) (cadr P11))
P13 (list  (car P9) (cadr P5))
P14 (list (car P10) (cadr P5))
P15 (list (car P11) (cadr P5))
P16 (list (car P12) (cadr P5))
P17 (list (+ (car P8) (* 16 h)) (cadr P8))
P18 (list (+ (car P17) (* 16 h)) (cadr P8))
P19 (list (+ (car P18) (* 18 h)) (cadr P8))
P20 (list (+ (car P19) (* 18 h)) (cadr P8))
);setq
(setvar "clayer" "khung duong")
(command  "pline" PT P3 P16 P12 ""
"pline" P1 P4 "" "pline" P2 P5 "" "pline" p9 p13 "" "pline" p10 p14 "" "pline" p11 p15 "" "pline" p12 p16 "")
(setvar "clayer" "text")
(command "text" "m" P7 (* 1.1 h) 0 "TONG"
"text" "m" P8 (* 1.1 h) 0 (strcat (rtos k 2 0) " VUNG")
"TEXT" "M" P17 (* 1.1 h) 0 (rtos cvt 2 2)
"TEXT" "M" P18 (* 1.1 h) 0 (rtos tdt 2 2)
"TEXT" "M" P19 (* 1.1 h) 0 (rtos klt 2 2)
"TEXT" "M" P20 (* 1.1 h) 0 (strcat (rtos k 2 0) " VUNG") )
(command "undo" "e")
(setvar "OSMODE" laos)
(setvar "clayer" oldla)
(setvar "cmdecho" 1)
(princ)
)
Hy vọng đúng ý bạn.

Riêng cái vụ khối lượng thì không thể có đơn vị là kg/m được nên mình đã tự sửa thành kg. Nếu bạn không thích thì tự sửa lại nhé.

 

Để kiểm soát được vùng lấy diện tích ngoài điền số mong Tác giả bổ sung thêm phần tô màu vùng chọn để không xảy ra những sai lầm khi tính diện tích. Xin chân thành cảm ơn.


<<

Filename: 386520_aaa.lsp
Tác giả: vbao
Bài viết gốc: 2100
Tên lệnh: tmax tmin
Lisp tìm giá trị max hoặc min trong text
Cải tiến chương trình của ssg, ta sẽ có 2 lệnh mới là TMax và TMin, sẽ tìm đối tượng text có giá trị min và max trong tập chọn.

Sau khi sử dụng lệnh và chọn...

>>
Cải tiến chương trình của ssg, ta sẽ có 2 lệnh mới là TMax và TMin, sẽ tìm đối tượng text có giá trị min và max trong tập chọn.

Sau khi sử dụng lệnh và chọn các đối tượng, đối tượng lớn nhất (hoặc nhỏ nhất) sẽ được high light.

(defun C:TMax (/ ss i V Vmax entht entmax)
 (setq	ss (ssget '((0 . "TEXT")))
i  0
 )
 (repeat (sslength ss)
   (setq V (atof (cdr (assoc 1 (entget (setq entht (ssname ss i)))))))    
   (if	(or (= i 0) (> V Vmax))
     (setq Vmax   V
    entmax entht
     )
   )
   (setq i (1+ i))
 )
 (command "redraw")
 (princ (strcat "\nMax = " (rtos Vmax)))
 (sssetfirst (ssadd entmax) (ssadd entmax))
 (princ)
)

(defun C:TMin (/ ss i V Vmin entht entmin)
 (setq	ss (ssget '((0 . "TEXT")))
i  0
 )
 (repeat (sslength ss)
   (setq V (atof (cdr (assoc 1 (entget (setq entht (ssname ss i)))))))    
   (if	(or (= i 0) (< V Vmin))
     (setq Vmin   V
    entmin entht
     )
   )
   (setq i (1+ i))
 )
 (command "redraw")
 (princ (strcat "\nMin = " (rtos Vmin)))
 (sssetfirst (ssadd entmin) (ssadd entmin))
 (princ)
)

 

một lần nữa xin cảm ơn các anh ssg, anh Nguyen Hoanh, đã nhiệt tình hướng dẫn và giúp tôi giải quyết vấn đề trên


<<

Filename: 2100_tmax_tmin.lsp
Tác giả: kunopro
Bài viết gốc: 222747
Tên lệnh: vt
Lisp vẽ mặt cắt cầu thang !

Lệnh là VT (vẽ thang)

 

(defun c:vt( / p c r sb oldos)  (setq    p (getpoint "\nVao diem dau tien: ")    c (getdist p...
>>

Lệnh là VT (vẽ thang)

 

(defun c:vt( / p c r sb oldos)  (setq    p (getpoint "\nVao diem dau tien: ")    c (getdist p "\nVao chieu cao bac: ")    r (getdist p "\nVao chieu rong bac: ")    sb (getint "\nVao so bac: ")    oldos (getvar "osmode")  )  (setvar "osmode" 0)    (command ".pline")  (command p)    (repeat sb    (command (strcat "@0," (rtos c)))    (command (strcat "@" (rtos r) ",0"))  )  (command "")  (setvar "osmode" oldos)  (princ))

Bác Hoành nhà ta thật là tuyệt vời..... Thanks bác rất nhiều @@


<<

Filename: 222747_vt.lsp
Tác giả: codered8x
Bài viết gốc: 94125
Tên lệnh: vtl1
Lisp rải taluy trên đường cong
Help me. Đây là Lisp dùng để rãi taluy của đường. Nó rất tiện lợi cho việc thể hiện mái dốc của đường đào hoặc đắp, nhưng có một khó khăn với tôi đó là nó...
>>
Help me. Đây là Lisp dùng để rãi taluy của đường. Nó rất tiện lợi cho việc thể hiện mái dốc của đường đào hoặc đắp, nhưng có một khó khăn với tôi đó là nó chỉ rãi được trên đường thẳng và trên đường pline và cung tròn còn trên đường spline thì bó tay.

Xin các Bác chỉnh sửa dùng cho với. Cám ơn trước nghe.

TL1: dùng để rãi trên đường thẳng và pline.

TL2: dùng để rãi trên cung tròn.

http://www.cadviet.com/upfiles/TALUY.lsp

Cái này chỉ vẽ được taluy trên đường line, pline mình thấy không có tác dụng, circle thì thấy yêu cầu lằng nhằng quá mà toàn viết tắt nên chả hiểu(PT1,PT2 là gì?).Ưu điểm là chọn được phía đặt taluy

 

 

--------------------------------

Đây là lisp tôi sưu tầm và chỉnh sửa lại chút ít, có thể rải taluy cho các loại line, pline, spline, arc, circle ...

(Mới dừng ở việc vẽ taluy cho 1 đường, phần vẽ mái taluy giữa 2 đường tôi chưa sửa xong)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;vtl;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun nsl ()
 (if (/= scale nil)
   (progn
     (setq thongbao (strcat "Ty le ban ve ?, <1/" (itoa scale) ">:"))
     (if (not (setq scaletmp (getint thongbao)))
(setq scaletmp scale)
     )
   )
   (progn
     (setq thongbao "Ty le ban ve ? <1/1000>:")
     (if (not (setq scaletmp (getint thongbao)))
(setq scaletmp 1000)
     )
   )
 )

 (setq scale scaletmp)

 (setq Defaultdist (* (* scale 2) 0.002))
 (if (setq tg (getreal	(strcat	"\nKhoang cach ky hieu ta luy <"
			(rtos Defaultdist 2 2)
			">:"
		)
       )
     )
   (setq Defaultdist tg)
 )

 (setq	chieutaluy1
 1
sodoan 0
 )
)

(defun nsl1 ()

 (setq
   ktdoantaluy1 2
   tg		 (getreal (strcat "\nChieu dai doan ngan<"
			  (rtos ktdoantaluy1 2 2)
			  ">:"
		  )
	 )
 )
 (if tg
   (setq ktdoantaluy1 tg)
 )
 (setq
   ktdoantaluy2 6
   tg		 (getreal (strcat "\nChieu dai doan dai<"
			  (rtos ktdoantaluy2 2 2)
			  ">:"
		  )
	 )
 )
 (if tg
   (setq ktdoantaluy2 tg)
 )
 (setq
   khoangcachtl 2
   tg		 (getreal (strcat "\nKhoang cach giua cac doan<"
			  (rtos khoangcachtl 2 2)
			  ">:"
		  )
	 )
 )
 (if tg
   (setq khoangcachtl tg)
 )
 (setq
   sodoanngan 3
   tg	       (getint (strcat "\nSo doan ngan trong 1 doan dai<"
		       (rtos sodoanngan 2 0)
		       ">:"
	       )
       )
 )
 (if tg
   (setq sodoanngan tg)
 )

)
(Defun PlMake (Plist)			;  Create polyline entities
 (entmake '((0 . "POLYLINE")))
 (setq	n  (length Plist)
ic 0
 )
 (while (< ic n)
   (entmake (list (cons 0 "VERTEX") (cons 10 (nth ic Plist))))
   (setq ic (1+ ic)
   )
 )
 (entmake '((0 . "SEQEND")))

)
;;;----------------------------------------------------------------
(defun ve1doantaluy (p1 p2 / pvt diemcu ktdoantaluy ketthuc)
 (setq pvt (+ (angle p1 p2) (* (/ pi 2) chieutaluy)))
 (setq ketthuc 1)
 (if (< sodoan sodoanngan)
   (progn
     (setq ktdoantaluy ktdoantaluy1)
     (setq sodoan (1+ sodoan))
   )
   (progn
     (setq ktdoantaluy ktdoantaluy2)
     (setq sodoan 0)
   )
 )
 (setq p2 (polar p1 pvt ktdoantaluy))
 (plmake (list p1 p2))
 (setq dem (1+ dem))
)

(Defun xddsd (com epl kc / e0 e p dsd)
 (setq e0 (entlast))
 (while e0
   (setq e e0)
   (setq e0 (entnext e0))
 )
 (command com epl kc)
 (setq e (entnext e))
 (while e
   (setq p (cdr (assoc 10 (entget e))))
   (if	p
     (setq dsd (cons p dsd))
   )
   (setq e (entnext e))
 )
 (command "_.Undo" 1)
 (setq dsd dsd)
)
				; ve ta luy cho 1 doi tuong
(Defun vetaluy (ep / le e ketthuc them dsd thutu)
 (setq dem 0)
 (setq e (entget (car ep)))
 (if (or (= (cdr (assoc 0 e)) "LWPOLYLINE")
  (= (cdr (assoc 0 e)) "POLYLINE")
  (= (cdr (assoc 0 e)) "SPLINE")
  (= (cdr (assoc 0 e)) "LINE")
  (= (cdr (assoc 0 e)) "ARC")
  (= (cdr (assoc 0 e)) "CIRCLE")
     )

   (setq ketthuc 1)
   (prompt "\nDoi tuong duoc chon khong hop le")
 )
 (if ketthuc
   (progn
     (setq thutu 0)
     (setq dsd (xddsd "_.Measure" ep khoangcachtl))
     (setq p1 (car dsd))
     (repeat (1- (length dsd))
(setq thutu (1+ thutu))
(setq p2 (nth thutu dsd))
(ve1doantaluy p1 p2)
(setq p1 p2)
     )
   )
 )
 (setq dem dem)
)

;;;==================================================
(Defun C:vtl1 (/ ep chon lai solan chon)

 (setvar "cmdecho" 0)
 (setvar "blipmode" 0)
 (command "undo" "g")
 (nsl)

 (setq ep 1)
 (while ep
   (setq solan	0
  chieutaluy 1
   )
   (setq ep (entsel "\nChon doi tuong ve ta luy..."))

   (if	ep
     (progn
(nsl1)
(setq solan (vetaluy ep))
(initget "Undo Change")
(while
  (setq chon (getkword "Undo/Change : "))
   (if (= chon "Undo")
     (command "_.Undo" solan)
   )
   (if (= chon "Change")
     (progn
       (nsl1)

       (setq chieutaluy -1)
       (command "_.Undo" solan)
       (setq solan (vetaluy ep))

     )
   )

  (initget "Undo Change")
)

     )
   )
 )
 (command "undo" "e")
)

Cái này vẽ được taluy trên cả line,spline,pline và cung tròn.Nhưng nhược điểm là không chọn được chiều đặt taluy.

-----------------------------------------------------------------

Đây là Lisp mà tôi hay dùng, mọi người cùng thưởng thức

;;; ======================== VE DUONG TALUY - LENH B1 (BATTER) =========================
;;; ================================================================================




=======
;;;================================== Testlay (Tao ten va mau cho layer moi===============================
(defun testlay (lay co / tam)
	(setq datalay (list ""))	  
			  (setq tbl (tblnext "layer" 1))
			  (while tbl
				  (setq tam (cdr (assoc 2 tbl)))
		(setq datalay (append datalay (list tam)))
				  (setq tbl (tblnext "layer"))
			   )
	(setq datalay (cdr datalay))
	(if (= (member lay datalay) nil)
 (command "LAYER" "n" lay "c" co lay  "s" lay "")
 (command "LAYER"   "s" lay "")
	)	
)
;; ============================================= Batter ================================================
(defun c:Batter()
  (setvar "cmdecho" 0)
  (setvar "blipmode" 0)
  (setvar "aunits" 0)
  (setvar "angbase" (/ pi 2))
  (setvar "angdir" 1)
  (if (not lint) (setq lint 10.0))
  (setq int (getdist (strcat "\nInterval <" (rtos lint 2 3) ">: ")))
  (if int (setq lint int) (setq int lint))
  (command "line" (list 0.0 0.0) (list 0.0 0.0001) "")
  (if (tblsearch "block" "tadtick")
	 (command "block" "tadtick" "y" (list 0.0 0.0) (entlast) "")
	 (command "block" "tadtick" (list 0.0 0.0) (entlast) "")
  )
  (while (setq refent (entsel "\nSelect reference line: "))
  (command "undo" "group")
  (redraw (car refent) 3)
  (initget 1 "Cut Fill")
  (setq reply (getkword "\nut or ill batter: "))
  (setq s (ssget))
  (command "measure" refent "b" "tadtick" "y" int)
  (setq p (ssget "p") cn 0)
  (if s
	 (progn
		(while (< cn (sslength p))
		   (setq en (entget (ssname p cn)) p0 (cdr (assoc 10 en)) pt1 p0 pt2 nil b (cdr (assoc 50 en)))
		   (entdel (ssname p cn))
		   (setq p1 (polar p0 (+ (/ pi 2) b) 0.0001))
		   (command "line" p0 p1 "")
		   (command "extend" s "" (list (entlast) p1) "")
		   (setq xent (entget (entlast)))
		   (setq xdist (distance (cdr (assoc 10 xent)) (cdr (assoc 11 xent))))
		   (if (not (equal xdist 0.0001 0.0001))
			  (setq pt2 (cdr (assoc 11 xent)))
			  (progn
				 (command "extend" s "" (list (entlast) p0) "")
				 (setq xent (entget (entlast)))
				 (setq xdist (distance (cdr (assoc 10 xent)) (cdr (assoc 11 xent))))
				 (if (not (equal xdist 0.0001 0.0001))
					(setq pt2 (cdr (assoc 10 xent)))
				 )
			  )
		   )
		   (entdel (entlast))
		   (if pt2
			  (if (= reply "Fill")
				 (if (= (rem cn 2) 0) (command "line" pt1 pt2 "")
					(command "line" pt1 (polar pt1 (angle pt1 pt2) (/ (distance pt1 pt2) 2)) "")
				 )
				 (if (= (rem cn 2) 0) (command "line" pt2 pt1 "")
					(command "line" pt2 (polar pt2 (angle pt2 pt1) (/ (distance pt2 pt1) 2)) "")
				 )
			  )
		   )
		   (setq cn (1+ cn))
		)
	 )
  )
  (command "undo" "en")
  )
  (setvar "blipmode" 1)
  (princ)
)
(prompt "\nDraw cut/fill batter slope lines.")
;====================== BAT1 (BATTER)===========================================
(defun c:B1( / mode)

(testlay "BONG" "8")
(setvar "osmode" 0)
(c:batter)
(setvar "blipmode" 0)
(setvar "osmode" 167)
)

Cái này phải vẽ 2 đường giới hạn đỉnh và chân của đường vẽ nét taluy, rất bất tiện

 

==>> Túm lại cái của snowman là ngon nhất nhưng làm sao thêm chức năng chọn chiều đặt taluy thì perfect!

 

Hàng về rồi...hihi

 

http://www.cadviet.com/upfiles/VTLW1.lsp

 

Thử nghiên cứu cái này đi.

 

1. Load vào CAD

2. Lệnh TL0 để khai báo tham số

3. Lệnh TL1 để vẽ đường taluy đơn

4. Lệnh TL2 để vẽ đường taluy đôi

Thêm cái này,vẽ pline tốt nhưng cũng k chọn được chiều.


<<

Filename: 94125_vtl1.lsp
Tác giả: Happyspringla2007
Bài viết gốc: 123692
Tên lệnh: tdt
Tính diện tích tạo nên từ những vùng giao nhau giữa 2 đường polyline
Tính 2 loại diện tích nằm giữa 2 polyline đây :

>>
Tính 2 loại diện tích nằm giữa 2 polyline đây :

;============================================================================!
;================================PFIEVXD-CADViet.com==============================
(Defun Dscon(TDlist gd1 gd2)
(Vl-remove-if '(lambda(x)(or(<=(car x)(car Gd1))(>=(car x)(car gd2)))) TDlist))
;---------------------------------------------------------------------------------
(Defun c:TDT(/ TDlist TDlist1 TDlist2 pl1 pl2 DT DT1 DT2
       TDlist11 TDlist22 i gd1 gd2 gd3 gd4 )
 (Setq Pl1     (Car(Entsel"\n Select First Pline :"))
Pl2     (Car(Entsel"\n Select Second Pline :"))
TDlist  (Acet-geom-intersectwith Pl1 pl2 0)
TDlist1 (Acet-geom-vertex-list PL1)
TDlist2 (Acet-geom-vertex-list Pl2)
n       (Length TDList)
i       0
DT1     0
DT2     0)
 (While (< i (- n 1))
   (Setq Gd1      (Nth i TDlist)
  Gd2      (NTh (1+ i) TDlist)
  TDlist11 (Dscon TDlist1 gd1 gd2)
  TDlist22 (Dscon TDlist2 gd1 gd2)
  TDlist3  (Append (list gd1) TDlist11 (list gd2) (Reverse TDlist22) (list gd1)))
   (Acet-pline-make (list TDlist3))
   (Command "AREA" "O" (Entlast))
   (Setq DT(Getvar "AREA"))
   (Command "ERASE" (Entlast)"")
   ;------------------------------------------------------------------------------
   (Setq Midpoint(Acet-geom-midpoint Gd1 Gd2))
   (Command "XLINE" "Ver" Midpoint "")
   (Setq gd3 (Acet-geom-intersectwith (Entlast) Pl1 0)
  gd4 (Acet-geom-intersectwith (Entlast) Pl2 0)
  )
   (If(>=(Cadr(Car gd3))(Cadr(Car gd4)))
     (Setq DT1(+ DT1 DT))
     (Setq DT2(+ DT2 DT))
     )
   (Command "ERASE" (Entlast)"")
   (Setq i(1+ i))
   )
 (Princ (Strcat"\n Dien tich loai 1 = " (Rtos DT1 2 2)))
 (Princ (Strcat"\n Dien tich loai 2 = " (Rtos DT2 2 2)))
 (Princ))
;================================PFIEVXD-CADViet.com===============================!

Xin bổ sung như sau! bạn xem và góp ý nhé!

(Defun C:TDT (/ TDlist TDlist1 TDlist2 pl1 pl2 DT DT1 DT2 TDlist11 TDlist22 i gd1 gd2 gd3 gd4

)

(Defun Dscon (TDlist gd1 gd2)

(Vl-remove-if '(Lambda (X) (Or (<= (Car X) (Car Gd1)) (>= (Car X) (Car gd2)))) TDlist)

)

(Setq Pl1 (Car(Entsel"\n Select First Pline :"))

Pl2 (Car(Entsel"\n Select Second Pline :"))

TDlist (Vl-sort (Acet-geom-intersectwith Pl1 pl2 0) (Function (Lambda (E1 E2) (< (Car E1) (Car E2)))))

TDlist1 (Vl-sort (Acet-geom-vertex-list PL1) (Function (Lambda (E1 E2) (< (Car E1) (Car E2)))))

TDlist2 (Vl-sort (Acet-geom-vertex-list Pl2) (Function (Lambda (E1 E2) (< (Car E1) (Car E2)))))

n (Length TDList)

i 0

DT1 0

DT2 0)

(While (< i (- n 1))

(Setq Gd1 (Nth i TDlist)

Gd2 (NTh (1+ i) TDlist)

TDlist11 (Dscon TDlist1 gd1 gd2)

TDlist22 (Dscon TDlist2 gd1 gd2)

TDlist3 (Append (list gd1) TDlist11 (list gd2) (Reverse TDlist22) (list gd1)))

(Acet-pline-make (list TDlist3))

(Command "AREA" "O" (Entlast))

(Setq DT(Getvar "AREA"))

(Command "ERASE" (Entlast)"")

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

(Setq Midpoint(Acet-geom-midpoint Gd1 Gd2))

(Command "XLINE" "Ver" Midpoint "")

(Setq gd3 (Acet-geom-intersectwith (Entlast) Pl1 0)

gd4 (Acet-geom-intersectwith (Entlast) Pl2 0)

)

(If(>=(Cadr(Car gd3))(Cadr(Car gd4)))

(Setq DT1(+ DT1 DT))

(Setq DT2(+ DT2 DT))

)

(Command "ERASE" (Entlast)"")

(Setq i(1+ i))

)

(Princ (Strcat"\n Dien tich loai 1 = " (Rtos DT1 2 2)))

(Princ (Strcat"\n Dien tich loai 2 = " (Rtos DT2 2 2)))

(Princ)

)


<<

Filename: 123692_tdt.lsp
Tác giả: whatcholingon
Bài viết gốc: 200908
Tên lệnh: ha
Nhờ viết lisp chọn nhanh text cùng nội dung

Đây bạn ơi! Lisp chọn text cùng nội dung.

(defun C:HA( / txt)
(setq txt (cdr (assoc 1 (entget (car (entsel "\nChon...
>>

Đây bạn ơi! Lisp chọn text cùng nội dung.

(defun C:HA( / txt)
(setq txt (cdr (assoc 1 (entget (car (entsel "\nChon Text mau: "))))))
(princ "\nChon nhom Text...")
(setq ss (ssget (list '(0 . "*TEXT") (cons 1 txt))))
(sssetfirst nil ss))

Mình thấy Lsp này cũng hay,

Lsp này có thể chỉnh sửa: Thay vì chọn đối tượng TEXT, mà là chọn đối tượng mẫu ( mọi đối tượng) sau đó chọn vùng thì có được không ah.


<<

Filename: 200908_ha.lsp
Tác giả: kiwi
Bài viết gốc: 50429
Tên lệnh: xy
Lấy toạ độ X,Y cùng lúc
Bạn thử lại với lisp này:

(defun C:XY( / p1 p2)
(setq
    p1 (getpoint "\nFirst point:")
    p2 (getpoint p1 "\nNext point:")
)
(setvar "dimtad" 1)
(command "leader" p1 p2 "a" (strcat...
>>
Bạn thử lại với lisp này:

(defun C:XY( / p1 p2)
(setq
    p1 (getpoint "\nFirst point:")
    p2 (getpoint p1 "\nNext point:")
)
(setvar "dimtad" 1)
(command "leader" p1 p2 "a" (strcat (rtos (car p1)) "\\P" (rtos (cadr p1))) "")
(princ)
)

 

Muốn bao nhiêu chữ số thập phân, bạn vào Format - Units - Length - Precision... (phải thiết lập Units trước khi dùng XY, và chỉ cần 1 lần)

cảm ơn bác nhiều lắm , em làm được rồi


<<

Filename: 50429_xy.lsp
Tác giả: thanhduan2407
Bài viết gốc: 102340
Tên lệnh: ft df dfx dx
Lisp căn lề text: Left, Center, Right và Fit (giống word)
Thêm lệnh DX: sắp xếp text theo hàng ngang (Đưa các text về cùng toạ độ Y, giữ nguyên toạ độ X)

(defun c:ft()
(setq txt (ssget '((0 ....
>>
Thêm lệnh DX: sắp xếp text theo hàng ngang (Đưa các text về cùng toạ độ Y, giữ nguyên toạ độ X)

(defun c:ft()
(setq txt (ssget '((0 . "*TEXT"))))
(setq mau (entget (car (entsel "\nChon text chuan"))))
(command "undo" "begin")
(setq oldos (getvar "osmode"))
(setq olcol (getvar "CEColor"))
(setq ollay (getvar "Clayer"))
(setq olstyle (getvar "textstyle"))
(setq TB  (textbox mau) LC  (car TB) RC (cadr TB) di (distance LC RC) i 0)
(setq h (cdr(assoc 40 mau)))
(setq x1 (cdr(assoc 10 mau)))
(setq x2 (list (+ (car x1) (* di 0.5) (* -0.03 h)) (cadr x1)))
(setq x3 (list (+ (car x1) di (* -0.06 h)) (cadr x1)))
(setq canle (cond (canle) ("Left")))
(initget "Left Center Right Fit")
(setq canle (cond ((getkword (strcat "\Vi tri can le <" canle ">"))) (canle)))
(repeat (sslength txt)
(setq txt_ent (entget (ssname txt i)))
(setq txt_val (cdr(assoc 1 txt_ent)))
(setq txt_st (cdr(assoc 7 txt_ent)))
(setq txt_lay (cdr(assoc 8 txt_ent)))
(setq txt_h (cdr(assoc 40 txt_ent)))
(setq txt_fctr (cdr(assoc 41 txt_ent)))
(setq txt_clr (cdr(assoc 62 txt_ent)))
(setq y1 (cdr(assoc 10 txt_ent)))
(if (cdr(assoc 43 txt_ent)) (setq txt_fctr 1 y1 (list (car y1) (- (cadr y1) txt_h))))
(setq pt1 (list (car x1) (cadr y1)))
(setq pt2 (list (car x2) (cadr y1)))
(setq pt3 (list (car x3) (cadr y1)))
(command "-style" txt_st "" "" txt_fctr "" "" "" "" "clayer" txt_lay "color" txt_clr "osmode" 0)
(if (eq canle "Left") (command "text" pt1 txt_h 0 txt_val))
(if (eq canle "Center") (command "text" "C" pt2 txt_h 0 txt_val))
(if (eq canle "Right") (command "text" "R" pt3 txt_h 0 txt_val))
(if (eq canle "Fit") (command "text" "F" pt1 pt3 txt_h txt_val))
(setq i (+ i 1))
(command "color" "bylayer")
);repeat
(setvar "textstyle" olstyle)
(setvar "Clayer" ollay)
(setvar "CECOLOR" olcol)
(setvar "osmode" oldos)
(command "erase" txt "")
(prompt"\n by Thaistreetz - huuthais@yahoo.com\n")
(command "undo" "end")
);defun
;====================================================================
;dan deu khoang cach cac hang text theo phuong Y
;====================================================================
(defun ss2ent (ss / sodt index lstent)
(setq 	sodt (if ss (sslength ss) 0)
index 0)
(repeat sodt
(setq 	ent (ssname ss index)
index (1+ index)
lstent (cons ent lstent)
);setq
);repeat
(reverse lstent)
)
(defun c:df()
(setq oldos (getvar "osmode"))
(setq 	ss (ssget '((0 . "*TEXT")))
lst (ss2ent ss)
lst (vl-sort lst '(lambda (e1 e2) (< (cadr (assoc 10 (entget e1))) (cadr (assoc 10 (entget e2))))))
lst (vl-sort lst '(lambda (e1 e2) (> (caddr (assoc 10 (entget e1))) (caddr (assoc 10 (entget e2))))))
);setq
(command "undo" "begin")
(setvar "osmode" 15359)
(setq kc (getdist "\n Nhap khoang cach giua cac text"))
(setq ddau (cdr(assoc 10 (entget(car lst)))) i 0 a2 (ssadd))
(setq mau (entget (car (entsel "\nChon text chuan"))))
(setq ptmau (cdr(assoc 10 mau)))
(setq ym (cadr ptmau))
(foreach e lst
(setq ent (entget e))
(setq dcuoi (cdr(assoc 10 ent)))
(setq yi (cadr dcuoi))
(setq ddauu (list (car dcuoi) (- (cadr ddau) (* i kc))))
(if (= yi ym) (setq ptgoc (list (car dcuoi) (- (cadr ddau) (* i kc)))))
(setvar "osmode" 0)
(command "move" e "" dcuoi ddauu)
(setq 	a2 (ssadd e a2))
(setq i (1+ i))
);foreach
(command "move" a2 "" ptgoc ptmau)
(setvar "osmode" oldos)
(prompt"\n by Thaistreetz - huuthais@yahoo.com\n")
(command "undo" "end")
(Princ)
)
;======================================================================
;dan deu khoang cach cac text theo phuong X
;======================================================================
(defun c:dfx()
(setq oldos (getvar "osmode"))
(setq 	ss (ssget '((0 . "*TEXT")))
lst (ss2ent ss)
lst (vl-sort lst '(lambda (e1 e2) (< (cadr (assoc 10 (entget e1))) (cadr (assoc 10 (entget e2))))))
lst (vl-sort lst '(lambda (e1 e2) (> (caddr (assoc 10 (entget e1))) (caddr (assoc 10 (entget e2))))))
);setq
(command "undo" "begin")
(setvar "osmode" 15359)
(setq kc (getdist "\n Nhap khoang cach giua cac text"))

(setq ddau (cdr(assoc 10 (entget(car lst)))) i 0 di 0 a2 (ssadd))
(setq mau (entget (car (entsel "\nChon text chuan"))))
(setq ptmau (cdr(assoc 10 mau)))
(setq xm (car ptmau))
(foreach e lst
(setq ent (entget e))
(setq pti (cdr(assoc 10 ent)))
(setq xi (car pti))
(setq ddauu (list (+ (car ddau) di (* i kc)) (cadr ddau)))
(if (= xi xm) (setq ptgoc (list (+ (car ddau) di (* i kc)) (cadr ddau))))
(setq TBi  (textbox ent) LCi  (car TBi) RCi (cadr TBi) dii (distance LCi RCi) di (+ di dii))
(setvar "osmode" 0)
(command "move" e "" pti ddauu)
(setq 	a2 (ssadd e a2))
(setq i (1+ i))
);foreach
(command "move" a2 "" ptgoc ptmau)
(setvar "osmode" oldos)
(prompt"\n by Thaistreetz - huuthais@yahoo.com\n")
(command "undo" "end")
(Princ)
)
;==================================================================
;Sap xep text thang hang (co cung tung do Y)
;==================================================================
(defun c:dx()
(setq oldos (getvar "osmode"))
(setq txt (ssget '((0 . "TEXT"))))
(command "undo" "begin")
(setq ym (cadr (cdr(assoc 10 (entget (car (entsel "\nChon text chuan")))))) i 0)
(repeat (sslength txt)
(setq txt_pt (cdr(assoc 10 (entget (ssname txt i)))))
(setq ptcuoi (list (car txt_pt) ym))
(setvar "osmode" 0)
(command "move" (ssname txt i) "" txt_pt ptcuoi)
(setq i (+ i 1))
);repeat
(setvar "osmode" oldos)
(prompt"\n by Thaistreetz - huuthais@yahoo.com\n")
(command "undo" "end")
(Princ)
)

Cảm ơn bác Thaistreetz rất nhiều. Lisp của bác rất hay. Em muốn hỏi bác một chút là khi em dãn các text theo phương ngang, em rất muốn các text dãn cách theo một giá trị khoảng cách mà mình nhập vào (từ tọa độ của text trước đến tọa độ của text kế tiếp cách nhau một khoảng cách). Nếu mình nhập giá trị khoảng cách hơi nhỏ thì các text có thể trùng đè lên nhau cũng được, miễn là các text dãn khoảng cách đều nhau. Em vướng vào trường hợp này khi vẽ mặt trắc dọc. Bác có thể chỉnh sửa giúp em được không ạ? Vẫn là lisp ft_df_dfx_dx.lsp của bác đó. Cảm ơn bác rất nhiều.


<<

Filename: 102340_ft_df_dfx_dx.lsp
Tác giả: only102
Bài viết gốc: 405188
Tên lệnh: ctg
Sửa định dạng font trong MTEXT

Thachphathien sử dụng code này thử nhé :

 

(defun c:ctg(/ doc sset chuoi vitri)
;copyright by Tue_NV
(setq ss...
>>

Thachphathien sử dụng code này thử nhé :

 

(defun c:ctg(/ doc sset chuoi vitri)
;copyright by Tue_NV
(setq ss (ssget '((0 . "*TEXT"))))
(vl-load-com)
(setq doc (vla-get-activedocument(vlax-get-acad-object)))
(defun pos (sub st / l1 l2 index)
;Thank Mr Hoanh for this function
(setq index 1
l1 (strlen sub)
l2 (strlen st)
)
(while
(and (<= (+ index l1 -1) l2) (/= sub (substr st index l1)))
(setq index (1+ index))
)
(if (= sub (substr st index l1))
index
nil
)
);;;end defun POS
;;;Main function
(vlax-for x (setq sset (vla-get-activeselectionset doc))
(setq chuoi (vla-get-textstring x))
(setq vitri (1+ (pos ";" chuoi)))
(vla-put-textstring x (substr chuoi vitri (- (strlen chuoi) vitri)))
)
(vla-delete sset)
(princ)
)

Đăng nhập để like cho bạn :D . Mình hay gặp phải tình huống trong 1 Mtext có nhiều style khác nhau, phải sửa rất lâu. Tuy lisp này vẫn phải chọn từng Mtext một nhưng cũng đã nhanh hơn rất nhiều. Cám ơn bạn nhé emoji_u1f44d.pngemoji_u1f44d.pngemoji_u1f44d.png


<<

Filename: 405188_ctg.lsp
Tác giả: doanduyhung
Bài viết gốc: 56671
Tên lệnh: rep
Hỏi cách chuyển đổi vị trí tọa độ đầu cuối của 1 polyline
Có thể Doanduyhung lấy ví dụ không điển hình nên mọi người đã hiểu nhầm. Trong một số trường hợp, chiều của polyline (liên quan đến điểm xuất phát của...
>>
Có thể Doanduyhung lấy ví dụ không điển hình nên mọi người đã hiểu nhầm. Trong một số trường hợp, chiều của polyline (liên quan đến điểm xuất phát của polyline) là quan trọng. Với polyline chỉ gồm 2 điểm thì đơn giản là rotate 180 độ tại trung điểm là coi như xong. Nhưng với polyline có nhiều điểm hơn thì không làm được như vậy, nếu rotate (hay align) thì chiều polyline thay đổi nhưng kéo theo các đỉnh cũng bị dịch chuyển so với hình gốc.

 

Các bạn thử dùng lisp này xem sao. Lệnh là REP (REverse Polyline)

(defun c:rep( / c10 tt)
 (setq 
tt (entget (car (entsel "\nHay pick vao mot Polyline: ")))
c10 (reverse (vl-remove-if '(lambda (x) (/= (car x) 10)) tt))
tt (mapcar '(lambda (x) (if (= 10 (car x)) (setq e (car c10) c10 (cdr c10) e e) x)) tt)
 )
 (entmod tt)
 (princ)
)
(vl-load-com)

Lisp này chỉ áp dụng cho các polyline không chứa arc.

Thank bác nhé để mình mò thêm code cho polyline co chứa arc xem sao.

Mục đích cái này để mình phát triển thiết kế tuyến đường trên bình đồ thôi.

Thank bác nhiều


<<

Filename: 56671_rep.lsp
Tác giả: nam_ktd
Bài viết gốc: 264280
Tên lệnh: colorx colorxref colorxl colorxrefl
Đổi màu tất cả các đối tượng trên bản vẽ thành một màu duy nhất

 

Cái lisp này mình sưu tầm được trên mạng đã lâu. Nay thấy bạn có nhu cầu mình port lên bạn xem có vư ý không...

>>

 

Cái lisp này mình sưu tầm được trên mạng đã lâu. Nay thấy bạn có nhu cầu mình port lên bạn xem có vư ý không nhé.

;;; Posted Vladimir Azarko (VVA);;; ;;;;http://www.cadtutor.net/forum/showthread.p...=533&page=2(defun C:COLORX	(/ doc col)  (vl-load-com)  (setq doc (vla-get-activedocument (vlax-get-acad-object)))  (vla-startundomark doc)  (mip:layer-status-save)  (if (setq col (acad_colordlg 7 t))    (ChangeAllObjectsColor doc col) ;_ col — color number  ) ;_ end of if  (mip:layer-status-restore)  (vla-endundomark doc)  (princ)) ;_ end of defun(defun C:COLORXREF (/ doc col)  (vl-load-com)  (alert    "\This lisp change color xref\nONLY ON A CURRENT SESSION"  ) ;_ end of alert  (setq doc (vla-get-activedocument (vlax-get-acad-object)))  (vla-startundomark doc)  (mip:layer-status-save)  (if (setq col (acad_colordlg 7 t))    (ChangeXrefAllObjectsColor doc col) ;_ col — color number  ) ;_ end of if  (mip:layer-status-restore)  (vla-endundomark doc)  (princ)) ;_ end of defun(defun C:COLORXL (/ doc col)  (vl-load-com)  (setq doc (vla-get-activedocument (vlax-get-acad-object)))  (vla-startundomark doc)  (if (setq col (acad_colordlg 7 t))    (ChangeAllObjectsColor doc col) ;_ col — color number  ) ;_ end of if  (vla-endundomark doc)  (princ)) ;_ end of defun(defun C:COLORXREFL (/ doc col)  (vl-load-com)  (alert    "\This lisp change color xref\nONLY ON A CURRENT SESSION"  ) ;_ end of alert  (setq doc (vla-get-activedocument (vlax-get-acad-object)))  (vla-startundomark doc)  (if (setq col (acad_colordlg 7 t))    (ChangeXrefAllObjectsColor doc col) ;_ col — color number  ) ;_ end of if  (vla-endundomark doc)  (princ)) ;_ end of defun(defun mip:layer-status-restore	()  (foreach item	*MIP_LAYER_LST*    (if	(not (vlax-erased-p (car item)))      (vl-catch-all-apply	'(lambda ()	   (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))	   (vla-put-freeze	     (car item)	     (cdr (assoc "freeze" (cdr item)))	   ) ;_ end of vla-put-freeze	 ) ;_ end of lambda      ) ;_ end of vl-catch-all-apply    ) ;_ end of if  ) ;_ end of foreach  (setq *MIP_LAYER_LST* nil)) ;_ end of defun(defun mip:layer-status-save ()  (setq *MIP_LAYER_LST* nil)  (vlax-for item (vla-get-layers		   (vla-get-activedocument (vlax-get-acad-object))		 ) ;_ end of vla-get-layers    (setq *MIP_LAYER_LST*	   (cons (list item		       (cons "freeze" (vla-get-freeze item))		       (cons "lock" (vla-get-lock item))		 ) ;_ end of cons		 *MIP_LAYER_LST*	   ) ;_ end of cons    ) ;_ end of setq    (vla-put-lock item :vlax-false)    (if	(= (vla-get-freeze item) :vlax-true)      (vl-catch-all-apply	'(lambda () (vla-put-freeze item :vlax-false))      ) ;_ end of vl-catch-all-apply    ) ;_ end of if  ) ;_ end of vlax-for) ;_ end of defun(defun ChangeXrefAllObjectsColor (Doc Color / tmp txtstr)  (vlax-for Blk	(vla-get-Blocks Doc)    (cond      ((or (= (vla-get-IsXref Blk) :vlax-true)	   (and	(= (vla-get-IsXref Blk) :vlax-false)		(wcmatch (vla-get-name Blk) "*|*")	   ) ;_ end of and       ) ;_ end of or       (vlax-for Obj Blk	 (if (and (vlax-write-enabled-p Obj)		  (vlax-property-available-p Obj 'Color)	     ) ;_ end of and	   (vla-put-Color Obj Color)	 ) ;_ end of if	 (if (and (vlax-write-enabled-p Obj)		 (vlax-property-available-p Obj 'TextString)	    ) ;_ end of and	  (progn	    (setq txtstr		   (if (vlax-method-applicable-p Obj 'FieldCode)		       (vla-FieldCode Obj)		       (vlax-get-property Obj 'TextString))		  )	    (setq tmp 0)	     (while (setq tmp (VL-STRING-SEARCH "\\C" txtstr tmp))	      (setq txtstr	      (vl-string-subst		(strcat (substr txtstr (1+ tmp) 2)(itoa Color) ";")		(substr txtstr (1+ tmp) (- (1+ (VL-STRING-SEARCH ";" txtstr tmp)) tmp))		txtstr		tmp)		    )	      (setq tmp (+ tmp 3))	      )	    (vla-put-Textstring Obj txtstr)	    )	) ;_ end of if	 (if (and (vlax-write-enabled-p Obj)		  (= (vla-get-ObjectName obj) "AcDbBlockReference")		  (= (vla-get-HasAttributes obj) :vlax-true)	     ) ;_ end of and	   (foreach att	(vlax-safearray->list			  (vlax-variant-value (vla-GetAttributes obj))			) ;_ end of vlax-safearray->list	     (if (and (vlax-write-enabled-p att)		      (vlax-property-available-p att 'Color)		 ) ;_ end of and	       (vla-put-Color att Color)	     ) ;_ end of if	   ) ;_ end of foreach	 ) ;_ end of if	 (if (and (vlax-write-enabled-p Obj)		  (wcmatch (vla-get-Objectname Obj) "*Dimension*,AcDb*Leader")	     ) ;_ end of and	   (progn	     (vl-catch-all-apply 'vla-put-ExtensionLineColor (list Obj Color))	     (vl-catch-all-apply 'vla-put-TextColor (list Obj Color))	     (vl-catch-all-apply 'vla-put-DimensionLineColor (list Obj Color))	     (if (vlax-property-available-p Obj 'LeaderLineColor)	       (progn		 (setq tmp (vla-getinterfaceobject(vlax-get-acad-object)(strcat "AutoCAD.AcCmColor."		(substr (getvar "ACADVER") 1 2))))		 (vla-put-colorindex  tmp  Color)		 (vl-catch-all-apply 'vla-put-LeaderLineColor (list Obj tmp))		 )	       )	   ) ;_ end of progn	 ) ;_ end of if       ) ;_ end of vlax-for      )      ((= (vla-get-IsLayout Blk) :vlax-true)       (vlax-for Obj Blk	 (if	   (and	(vlax-write-enabled-p Obj)		(vlax-property-available-p Obj 'Color)		(vlax-property-available-p Obj 'Path)		(wcmatch (strcase (vla-get-ObjectName Obj)) "*BLOCK*")	   ) ;_ end of and	    (vla-put-Color Obj Color)	 ) ;_ end of if       ) ;_ end of vlax-for      )      (t nil)    ) ;_cond  ) ;_ end of vlax-for  (vl-cmdf "_redrawall")) ;_ end of defun(defun ChangeAllObjectsColor (Doc Color / txtstr tmp txt count)  (vlax-for Blk	(vla-get-Blocks Doc)    (if	(= (vla-get-IsXref Blk) :vlax-false)      (progn	(setq count 0 txt (strcat "Changed " (vla-get-name Blk)))	(grtext -1 txt)      (vlax-for	Obj Blk	(setq count (1+ count))	(if (zerop(rem count 10))(grtext -1 (strcat txt " : " (itoa count))))	(if (and (vlax-write-enabled-p Obj)		 (vlax-property-available-p Obj 'Color)	    ) ;_ end of and	  (vla-put-Color Obj Color)	) ;_ end of if	(if (and (vlax-write-enabled-p Obj)		 (vlax-property-available-p Obj 'TextString)	    ) ;_ end of and	  (progn	    (setq txtstr		   (if (vlax-method-applicable-p Obj 'FieldCode)		       (vla-FieldCode Obj)		       (vlax-get-property Obj 'TextString))		  )	    (setq tmp 0)	    (while (setq tmp (VL-STRING-SEARCH "\\C" txtstr tmp))	      (setq txtstr	      (vl-string-subst		(strcat (substr txtstr (1+ tmp) 2)(itoa Color) ";")		(substr txtstr (1+ tmp) (- (1+ (VL-STRING-SEARCH ";" txtstr tmp)) tmp))		txtstr		tmp)		    )	      (setq tmp (+ tmp 3))	      )	    (vla-put-Textstring Obj txtstr)	    )	) ;_ end of if	(if (and (vlax-write-enabled-p Obj)		 (= (vla-get-ObjectName obj) "AcDbBlockReference")		 (= (vla-get-HasAttributes obj) :vlax-true)	    ) ;_ end of and	  (foreach att (vlax-safearray->list			 (vlax-variant-value (vla-GetAttributes obj))		       ) ;_ end of vlax-safearray->list	    (if	(and (vlax-write-enabled-p att)		     (vlax-property-available-p att 'Color)		) ;_ end of and	      (vla-put-Color att Color)	    ) ;_ end of if	  ) ;_ end of foreach	) ;_ end of if        (if (and (vlax-write-enabled-p Obj)		  (wcmatch (vla-get-Objectname Obj)  "*Dimension*,AcDb*Leader")	     ) ;_ end of and	   (progn	     (vl-catch-all-apply 'vla-put-ExtensionLineColor (list Obj Color))	     (vl-catch-all-apply 'vla-put-TextColor (list Obj Color))	     (vl-catch-all-apply 'vla-put-DimensionLineColor (list Obj Color))	     (if (vlax-property-available-p Obj 'LeaderLineColor)	       (progn		 (setq tmp (vla-getinterfaceobject(vlax-get-acad-object)(strcat "AutoCAD.AcCmColor."		(substr (getvar "ACADVER") 1 2))))		 (vla-put-colorindex  tmp  Color)		 (vl-catch-all-apply 'vla-put-LeaderLineColor (list Obj tmp))		 )	       )	   ) ;_ end of progn	 ) ;_ end of if      ) ;_ end of vlax-for      )    ) ;_ end of if  ) ;_ end of vlax-for (vl-cmdf "_redrawall")) ;_ end of defun(princ  "\nType ColorX, COLORXREF, ColorXL, COLORXREFL  in command line") ;_ end of princ

Bác cho hỏi câu lệnh sử dụng cái lip "Colorx_colorxref_colorxl_colorxrefl.lsp" này như thế nào vậy, em load về ap về cad mà không biết sử dụng như thế nào? Thanks.


<<

Filename: 264280_colorx_colorxref_colorxl_colorxrefl.lsp
Tác giả: vuvu93
Bài viết gốc: 399803
Tên lệnh: ca
Lisp kết hợp lệnh Array và Copy

Rất cảm ơn Ketxu đã có 1 số góp ý để Lisp được hoàn thiện hơn.

Lệnh này Copy_Array các đối tượng, kể cả...

>>

Rất cảm ơn Ketxu đã có 1 số góp ý để Lisp được hoàn thiện hơn.

Lệnh này Copy_Array các đối tượng, kể cả Text (Mtext). Riêng Text chứa số thì có thể tăng/giảm theo gia số, nó chấp nhận cả số có tiền và/hoặc hậu tố.

Nếu có nhiều Text số được chọn thì chỉ 1 Text số chọn sau cùng được tăng/giảm. Số chữ số thập phân (nếu có) sẽ lấy theo Text chọn.

; Doan Van Ha CADViet.com
; Copy-Array cac doi tuong ke ca Text (Mtext), rieng Text co chua so thi tang giam theo gia so, chap nhan so co tien to va hau to.
; Neu co nhieu Text chua so duoc chon thi chi 1 Text chon sau cung duoc tang/giam. So chu so thap phan (neu co) lay theo Text chon.
; P/S (01-03-2012): bo sung them so chu so 0 dau num de phu hop voi text mau. VD: "CN: 01" tang thanh "CN: 02"...
(defun C:CA (/ dsdt dt dt1 dt2 p1 p2 sl x kwrd strt strp num sym ds daup giaso)
 (vl-load-com)
 (command "undo" "be")
 (setq osm (getvar "osmode") cmd (getvar "cmdecho"))
 (princ "\nChon cac doi tuong can Copy-Array...")
 (setq dsdt (vl-remove-if 'listp (mapcar 'cadr (ssnamex (setq dt (ssget)))))
       	dt1 dt p1 (getpoint "\nDiem goc: ") p2 (getpoint p1 "\nDiem den: ") sl (getint "\nSo lan: ") x 1)
 (setvar "osmode" 0) (setvar "cmdecho" 0)
 (foreach n dsdt
  (if (or (= "TEXT" (cdr (assoc 0 (entget n)))) (= "MTEXT" (cdr (assoc 0 (entget n)))))
   (if (KT_NUM (cdr (assoc 1 (entget n))))
	(setq dt2 n))))
 (if dt2 (setq dt1 (ssdel dt2 dt)))
 (if dt2
  (progn
   (initget "Y N")
   (setq kwrd (getkword "\nBan muon Text tang dan ?   ") giaso (getreal "\nGia so: "))
   (setq x 1)
   (repeat (1- sl)
	(command ".copy" dt2 "" p1 (polar p1 (angle p1 p2) (* (distance p1 p2) x)))
	(if (eq kwrd "Y")
 	(progn
  	(CHIA3 (cdr (assoc 1 (entget dt2))))
  	(setq daup (if (not (vl-string-search "." (cadr ds))) 0 (- (strlen (cadr ds)) (vl-string-search "." (cadr ds)) 1)))
  	(entmod (subst (cons 1 (strcat (car ds) (THEM0 (cadr ds) (rtos (+ (atof (cadr ds)) (* x giaso)) 2 daup)) (caddr ds))) (assoc 1 (entget (entlast))) (entget (entlast))))
  	(entupd (entlast))))
	(setq x (1+ x)))))
 (if dt1
  (progn
   (setq x 1)
   (repeat (1- sl)
	(command ".copy" dt1 "" p1 (polar p1 (angle p1 p2) (* (distance p1 p2) x)))
	(setq x (1+ x)))))
 (command "undo" "e")
 (setvar "osmode" osm) (setvar "cmdecho" cmd)
 (princ))
;----- Chia text ra tiento_num_hauto.
(defun CHIA3 (str / trai phai lstt lstn)
 (setq lstt (vl-string->list str) lstn (reverse lstt))
 (while lstt
  (cond ((or (< (car lstt) 48) (> (car lstt) 57)) (setq trai (cons (car lstt) trai) lstt (cdr lstt)))
         	(T (setq lstt nil))))
 (while lstn
  (cond ((or (< (car lstn) 48) (> (car lstn) 57)) (setq phai (cons (car lstn) phai) lstn (cdr lstn)))
         	(T (setq lstn nil))))
 (setq ds (list (vl-list->string (reverse trai))
                    	(if (= (strlen str) (strlen (vl-list->string (reverse trai)))) "" (vl-string-right-trim (vl-list->string phai) (vl-string-left-trim (vl-list->string trai) str)))
                    	(if (= (strlen str) (strlen (vl-list->string (reverse trai)))) "" (vl-list->string phai)))))
;----- Kiem tra 1 text co chua num hay khong?
(defun KT_NUM(str / ds kt)
 (foreach n (vl-string->list str)
  (if (and (>= n 48) (<= n 57)) (setq kt T)))
 kt)
 ;----- Thong ke so chu so truoc dau thap phan.
(defun KT_FIX(str / m)
 (setq m 0)
 (while (and (> (strlen str) 0) (/= (substr str 1 1) "."))
  (setq m (1+ m) str (substr str 2)))
 m)
;----- Them so chu so 0 vao dau text cho phu hop.
(defun THEM0(strt strs)
 (while (> (- (KT_FIX strt) (KT_FIX strs)) 0)
  (setq strs (strcat "0" strs)))
 strs)
P/S: sửa 07/02/2012 để không còn dùng các hàm Acet.

P/S: sửa 01/03/2012 để thêm số chữ số 0 vào đầu Num của Text để phù hợp với Text gốc.

 

Xin lỗi vì đã up lại bài viết cũ. Cảm ơn bác rất nhiều ạ,em muốn không có hộp thoại"Bạn có muốn Text tăng dần" mà mặc định nó luôn là Yes thì thay lệnh ntn ạ,em mò hổi mà k ra vì e k biết gì về lập trình. Cảm ơn bác


<<

Filename: 399803_ca.lsp
Tác giả: hungtv0102
Bài viết gốc: 117879
Tên lệnh: gpmb
LISP GPMB
Bạn thử lại code này nhé:

(DEFUN C:gpmb(/ TH SS Index PtIns Ent PtM PtL PtR SSL SSR LenSSL LenSSR LstPtXL LstPtXR
	  XL XR YL YR I PtDimLine) 
(ACET-ERROR-INIT (LIST...
>>
Bạn thử lại code này nhé:

(DEFUN C:gpmb(/ TH SS Index PtIns Ent PtM PtL PtR SSL SSR LenSSL LenSSR LstPtXL LstPtXR
	  XL XR YL YR I PtDimLine) 
(ACET-ERROR-INIT (LIST (LIST "OSMODE" 0 "CLAYER" "DIM" "CMDECHO" 0) T))
(setq TH (getstring "\nChoòn trýõÌng hõòp: "))
(setq ss (ssget "X" '((0 . "INSERT") (2 . "Dau_co")))
  Index 0)
 (while (setq Ent (ssname ss Index))
(setq PtIns (cdr (assoc 10 (entget ent)))	
  PtM (polar PtIns (/ pi 2) -10))
(command "Zoom" "c" PtM 25)
(setq PtL (polar PtM pi 20);Dieu chinh cho nay cho phu hop
  PtR (polar PtM 0 20)
  PtM (polar PtM (/ pi 2) 1)
  SSL (ssget "c" PtM PtL '((0 . "LINE") (8 . "ENTTNTHIETKE")))
  SSR (ssget "c" PtM PtR '((0 . "LINE") (8 . "ENTTNTHIETKE")))
  Index (1+ Index))
(setq LenSSL (sslength SSL)
  I 0
  LstPtXL Nil)
(while (< I LenSSL)
  (Setq LstPtXL (append LstPtXL (list(cadr (assoc 10 (entget (ssname SSL I)))))) I (1+ I))
)
(Setq XL (nth 0 (vl-sort LstPtXL '<)))
(setq LenSSR (sslength SSR)
  I 0
  LstPtXR Nil)
(while (< I LenSSR)
  (Setq LstPtXR (append LstPtXR (list(cadr (assoc 10 (entget (ssname SSR I)))))) I (1+ I))
)
(Setq XR (nth 0 (vl-sort LstPtXR '>)))
(setq I 0)
(while (< I LenSSL)
  (if (= (cadr (assoc 10 (entget (ssname SSL I)))) XL)
(setq YL  (caddr (assoc 10 (entget (ssname SSL I)))))
  )
  (setq I (1+ I))
)
(setq I 0)
(while (< I LenSSR)
  (if (= (cadr (assoc 10 (entget (ssname SSR I)))) XR)
(setq YR  (caddr (assoc 10 (entget (ssname SSR I)))))
  )
  (setq I (1+ I))
)	
(setq PtL (polar (list XL YL 0.0) pi 1.5))
(if (= TH "1")
  (setq PtR (polar (list XR YR 0.0) 0 1.5))
  (setq PtR (list XR YR 0.0))
)
(command "Insert" "GPMB" PtL "" "" "" )
(command "Insert" "GPMB" PtR "" "" "")
(command "mirror" "l" "" PtR (polar PtR (/ pi 2) 5) "y")	
(setq PtM (polar PtM (/ pi 2) 5)
  PtL (list (car PtL) (cadr PtM) 0.0)
  PtR (list (car PtR) (cadr PtM) 0.0) 
  PtDimLine (polar PtM (/ Pi 2) 2))
(command "_dimlinear" PtL PtM PtDimLine)
(command "_dimlinear" PtM PtR PtDimLine)  
 )
 (command "zoom" "e")
 (acet-error-restore)
)

Có thay đổi: Bạn chỉ cần tạo một khối mốc lộ giới Trái với tên GPMB, tôi dx bổ sung chức năng Mirror để chuyển nó sang bên phải.

Lưu ý: - Điểm chèn (Insert Point) của Block đặt trong Block đừng để xa tít mù tắp như cái Block GPMB ban đầu cảu bạn. Vì rất khó xác định điểm chèn Block trên mặt đất tự nhiên nên tôi chỉ xác định được cao độ của chân đường đắp hoặc đỉnh đường đào thôi.

- Vùng chọn các đối tượng tôi tính từ tâm ra mỗi phía 20m nên nếu các trắc ngang có khoảng cách từ tim đến chân đường đắp hoặc đỉnh đường đào lớn hơn 20m thì sẽ ko xác định được, nếu có chỗ nào lớn hơn thì chuyển riêng trắc đó vào một file và chỉnh các dòng như chú thích trong code cho phù hợp, không chỉnh tổng thể vì sẽ dễ bị chọn nhầm sang các trắc khác.

 

Chào bác Holetrang và các Bác !

Tôi thấy cái lisp bác viết rất hay và hữu ích cho anh em làm GT – Đường. Tuy nhiên để lisp có thể vận dụng trong nhiều trường hợp hơn . Bác có thể phát triển lisp thêm nhiều lựa chọn hơn ví dụ như sau:

1. Chọn Trường hợp GPMB bên trái – phải – hai bên (T/P/2B).

2. Chọn khoảng cách GPMB tư chân ta luy (nhập gia trị).

3. Chọn Khoảng cách vẽ cọc GPMB (nhập KC).

 

(Ghi chú: vì thông thường không phải cọc nào cũng chèn Block GPMB như lisp hiện tại.

mà khoảng 50 – 100 m mới chèn 1 Block GPMB. Khoảng cách này có thể chọn dựa vào lý trình TN đầu tiện nếu trong trường hợp các TN tiếp theo cách TN đầu không đúng KC nhập vào thì có thể Block GPMB có thể chèn vào TN ngần với KC đấy nhất.)

 

Kính mong bác Hoaletrang và các Bác Pro Cadviet cố ngắng Phát triển giúp anh em vì cái này anh em làm GT rất cần hiện tại anh em vẫn phải làm tay các thao tác này rất lâu và vất vả.

Chân thành cảm ơn!


<<

Filename: 117879_gpmb.lsp
Tác giả: Hoangvulandscape
Bài viết gốc: 152891
Tên lệnh: tkh
Lisp thống kê diện tích Hatch theo Layer

Mình không nhận các chữ pro của bạn được, vì mình không phải thế ^^.Và lisp viết theo yêu cầu của Hoangvu, vì vậy bạn không nên nói như...

>>

Mình không nhận các chữ pro của bạn được, vì mình không phải thế ^^.Và lisp viết theo yêu cầu của Hoangvu, vì vậy bạn không nên nói như nào là pro hơn, mà đó chỉ là cách bạn cảm thấy tiện hơn cho công việc của bạn thôi.Mà việc đó bạn dùng Qselect cũng được :)

Lisp sửa lại theo yêu cầu của bạn ( cũng vì thế mà đã chọn là tính hết, khỏi chọn vùng luôn )

 

(defun c:tkh (/ lst msp pt ss lay ar txtsiz pt ent)
 (if (> (atof (substr (getvar "ACADVER") 1 4)) 16.1)
 (progn
 (vl-load-com)
 (acet-sysvar-set (list "cmdecho" 0))
 (grtext -1 "S\U+01A1n T\U+00F9ng' Lisp")  
 (if (setq ent (car (entsel "\nCh\U+1ECDn Hatch \U+0111i\U+1EC3n h\U+00ECnh : ")))
 (progn
  (setq ss (ssget "X" (list (cons 0 "HATCH")(cons 8 (vla-get-layer (vlax-ename->vla-object ent))))))    
     (foreach e (mapcar 'vlax-ename->vla-object (st-ss->ent ss))
	(setq lay (vlax-get-property e 'Layer)) 
       (if (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-get-area (list e))))
(setq ar (*  0.000001 (vlax-get-property e 'Area)))
(progn
(setq ar 0)(princ (strcat "\nC\U+00F3 Hatch thu\U+1ED9c layer " lay " kh\U+00F4ng t\U+00EDnh \U+0111\U+01B0\U+1EE3c di\U+1EC7n t\U+00EDch.\n\U+0110\U+00E3 highlight v\U+00E0 t\U+00EDnh di\U+1EC7n t\U+00EDch b\U+1EB1ng 0"))
(redraw (vlax-vla-object->ename e) 3)
)
)
       (if (not (assoc lay lst))
         (setq lst (cons (cons lay ar) lst))
         (setq lst (subst (cons lay (+ ar (cdr (assoc lay lst))))
                          (assoc lay lst) lst))))
     (setq lst (vl-sort lst '(lambda (x y) (< (car x) (car y))))

           txtsiz (* (getvar "dimtxt")(getvar "dimscale"))
           msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) i -1)

     (while (setq e (nth (setq i (1+ i)) lst)) 
       (wtxt_l (strcat (car e) " : " (rtos (cdr e) 2 2) "m2") '(0 0 0))
(setq pt (ACET-SS-DRAG-MOVE (ssadd (entlast)) '(0 0 0) (strcat "\n\U+0110i\U+1EC3m \U+0111\U+1EB7t ghi ch\U+00FA t\U+1ED5ng di\U+1EC7n t\U+00EDch Hatch thu\U+1ED9c layer " (car e))))
(command ".move" (entlast) "" '(0 0 0) pt)
)
(princ "\n\U+0110\U+00E3 th\U+1EF1c hi\U+1EC7n xong !")
)
   (alert "Kh\U+00F4ng c\U+00F3 Hatch n\U+00E0o \U+0111\U+01B0\U+1EE3c ch\U+1ECDn !"))
)
(alert "Phi\U+00EAn b\U+1EA3n CAD c\U+1EE7a b\U+1EA1n kh\U+00F4ng h\U+1ED7 tr\U+1EE3 t\U+00EDnh di\U+1EC7n t\U+00EDch Hatch !")
)
 (acet-sysvar-restore)(princ))
 (defun st-ss->ent (ss / n e l)
 (setq n -1)
 (while (setq e (ssname ss (setq n (1+ n))))
   (setq l (cons e l))
 )
)
(defun wtxt_l(txt p / sty d h1 h2 wf h);;;Write txt on graphic screen at p
(setq    sty (getvar "textstyle")
d (tblsearch "style" sty)
h1 (cdr (assoc 40 d))
h2 (cdr (assoc 42 d))
wf (cdr (assoc 41 d)))
(if (> h1 0) (setq h h1) (setq h h2))
(entmake (list (cons 0 "TEXT") (cons 7 sty) (cons 40 h) (cons 41 wf)(cons 72 1)(cons 11 p) (cons 1 txt) (cons 10 p))))

Cảm ơn bạn đã nhiệt tình giúp đỡ anh em tụi mình. Tuy nhiên yêu cầu của bạn 3d có lẽ hơi dư, vì các lý do sau:

- bản vẽ cảnh quan các lớp hacth đan xen nhau (như giữa thảm cỏ có vài mảng hoa...), đồng thời một số lớp cực lớn, do đó nếu chạy một lần ra hết có thể rất là nặng, máy yếu hay hatch bị lỗi sẽ rất lâu hoặc treo máy.

- Ứng dụng quan trọng nhất mà mình yêu cầu ở lisp này ko phải chỉ để tính DT mà quan trọng nhất là ra text chú thích vật liệu cho đối tượng bản vẽ nhanh hơn mà lẽ ra mình phải lọ mọ điền thủ công như trước đây rất mất thời gian.

- Dùng lisp này bạn phải chú ý kiểm properties từng mảng hatch ngay khi hatch xong xem có thông số DT ko, vì nếu nó bị lỗi thì sẽ thiếu DT (do đó đề nghị Ketxu bổ sung thông báo lỗi nếu có 1 mảng nào đó bị lỗi, hoặc nếu thêm chức năng highlight mảng đó ln thì càng tốt).

- Nếu chỉ cần tính tổng diện tích 1 loại hatch, bạn chỉ cần set các mảng hatch cùng loại chung 1 layer, sau đó dùng lệnh layiso để chỉ hiển thị mỗi lớp đó, rồi chọn tất cả, chọn xem properties là xong. Nếu có lớp nào đó lỗi thì sẽ ko ra DT, co đó ko sợ mất DT. Lưu ý là hình như phải từ cad 2004 trở lên thì phải.

Cuối cùng xin cảm ơn sự giúp đỡ nhiệt tình của các bạn, cảm ơn rất nhiều.


<<

Filename: 152891_tkh.lsp
Tác giả: vbao
Bài viết gốc: 3886
Tên lệnh: xscale xsc
Scale đối tượng một chiều
Đây là đọan code scale đối tượng một chiều

Lệnh là XSC hoặc XSCALE

 

;Scale the mot chieu
(DEFUN EXCUTE()
 (setq oldvalue (getvar...
>>
Đây là đọan code scale đối tượng một chiều

Lệnh là XSC hoặc XSCALE

 

;Scale the mot chieu
(DEFUN EXCUTE()
 (setq oldvalue (getvar "CMDECHO"))
 (setvar "CMDECHO" 0)
 (princ "Chon doi tuong can scale: ")
 (setq ss (ssget))
 (setq P0 (getpoint "\nChon diem goc: "))
 (initget 1 "X Y X S")
 (setq C (getkword "\nScale theo ? :"))
 (setq hs (getreal "Cho biet he so scale: "))
 (DELBLOCK "vkc_temp")
 (CREATEBLOCK ss P0)  
 (Command "-Insert" "vkc_temp" C hs P0 "")   
 (setq dt (entlast))
 (Command "Explode" dt)
 (setvar "CMDECHO" oldvalue)
 (princ)
)
(DEFUN CREATEBLOCK(ss P)
 (command "-Block" "vkc_temp" P ss "")
)

(DEFUN DELBLOCK (bname)
 (if (IsExistBlock bname)
(Command "-Purge" "B" bname "Y" "Y")	
 )
)
(DEFUN IsExistBlock(bname / kq)
 (setq kq Nil)
 (setq n (length LiBlk))
 (setq i 0)
 (while (< i n)
(if (= bname (nth i LiBlk))
  (progn
(setq i n)
(setq kq T)
  )	
)
(setq i (1+ i))
 )
 kq
)
(DEFUN CREALIBLK (/ NL)
 (setq LiBlk (List))
 (setq NL (tblnext "BLOCK" T))  
 (while NL	
(setq LiBlk (append LiBlk (list (cdr (assoc 2 NL)))))
(setq NL (tblnext "BLOCK"))
 )
 (setq LiBlk (Acad_strlsort LiBlk))
)
(DEFUN C:XSCALE()
 (CREALIBLK)
 (EXCUTE)
)
(DEFUN C:XSC()
 (CREALIBLK)
 (EXCUTE)
)

 

tôi gặp lỗi khi sử dụng: lần 1 scale theo phương X = ok, sau đó cũng các block này nếu tiếp tục scale theo phương khác thì gặp lỗi :

Command: XSC Chon doi tuong can scale:

Select objects: Specify opposite corner: 5 found

 

Select objects:

 

Chon diem goc:

Scale theo ?<X/Y/Z/S> :Y

Cho biet he so scale: 2

 

 

Command:

XSC Chon doi tuong can scale:

Select objects: P

5 found

 

Select objects:

 

Chon diem goc:

Scale theo ?<X/Y/Z/S> :X Cho biet he so scale: 5

Unknown command "-PURGE". Press F1 for help.

Unknown command "B". Press F1 for help.

Unknown command "VKC_TEMP". Press F1 for help.

Unknown command "Y". Press F1 for help.

Unknown command "Y". Press F1 for help.

 

Yes or No, please.

; error: Function cancelled

Redefine it? <N>:

 

nhờ vndesperados xwm lại giúp. Thanks


<<

Filename: 3886_xscale_xsc.lsp
Tác giả: proconeng86
Bài viết gốc: 295473
Tên lệnh: sd
lisp tính tổng số đai trong dim

 

Mình "cố tình" làm thế vì BV mẫu bạn đưa ra & những thông tin bạn cấp ko đủ để mình lọc Dim style

Nếu muốn chạy...

>>

 

Mình "cố tình" làm thế vì BV mẫu bạn đưa ra & những thông tin bạn cấp ko đủ để mình lọc Dim style

Nếu muốn chạy trơn tru nữa thì bạn cần cung cấp thông tin đầy đủ từ đầu :D

Nếu chấp nhận bỏ qua dim style ko phù hợp (ko có hs chuyển đổi đơn vị) thì dùng cái này

;; Lisp cong gia tri Dim, phuc vu tinh tong so cot dai theo y/c:
;;http://www.cadviet.com/forum/topic/102605-yeu-cau-lisp-tinh-tong-so-dai-trong-dim/
(defun c:SD (/ i tong ss ent info ds ds_name hs text_dim start end n)
;;sum dim
(setq i -1
	  j 0
	  tong 0)
(prompt "\n Chon Dim can tinh tong: ")
(setq ss (ssget '((0 . "DIMENSION"))))
(while (and ss (< i (1- (sslength ss))))
	(setq ent (ssname ss (setq i (1+ i)))
		  info (entget ent)
		  ds (cdr (assoc 3 info))
		  ds_name (tblobjname "dimstyle" ds)
		  hs (cdr (assoc 143 (entget ds_name)))
	)
	(cond ((null hs) (setq n 0 j (1+ j)))
		  ((= (cdr(assoc 1 info)) "") (setq n (fix (+ 0.5 (* (cdr(assoc 42 info)) hs)))))
		  (t (setq text_dim  (cdr(assoc 1 info))
				   start (vl-string-search "[" text_dim)
				   end (vl-string-search "%%C" text_dim)
				   n (atoi (substr text_dim (+ 2 start) (- end start 1)))
				   )
			)
	)
	(setq tong (+ n tong))
)
(alert (strcat "Tong cong " (itoa (1+ (- i j))) " dim la: " (itoa tong) " dai"))
(princ)
)

 

Lisp này hết bị lỗi khi chọn dim không có đai rồi nhưng bạn sửa thêm cho mình là nếu có nhiều loại đai khác nhau (ví dụ trong file đính kèm có 2 loại đai phi6 và phi10) thì tính tổng từng loại đường kính và đưa ra bảng thông báo

Mình cám ơn nhiều

http://www.cadviet.com/upfiles/3/9928_yeu_cau_lisp_tinh_so_dai_trong_nhieu_khoang_dim_2.dwg


<<

Filename: 295473_sd.lsp
Tác giả: dauquangminh
Bài viết gốc: 162169
Tên lệnh: b2pl b2t
1 Lisp vẽ đường polyline nối baseponit của các block và

Yêu cầu của bạn thiếu mô tả dữ liệu đầu vào, sơ qua yêu cầu và hình ảnh minh họa (không phải ai cũng có điều kiện dơnload về để...

>>

Yêu cầu của bạn thiếu mô tả dữ liệu đầu vào, sơ qua yêu cầu và hình ảnh minh họa (không phải ai cũng có điều kiện dơnload về để đọc mà => yêu cầu của bạn sẽ bị lãng quên) Hi vọng lần sau bạn rút kinh nghiệm

Còn đây là lisp bạn yêu cầu. Mình bổ sung dữ kiện : đối tượng bắt đầu đường đi

Lệnh :

- Yêu cầu 1 : b2pl :

+ Chọn các Block cần vẽ đường Pline qua, chọn Block đầu => Lisp tìm đường đi theo quy luật điểm thứ n sẽ gần điểm n-1 nhất và kẻ Pline qua đó

- Yêu cầu 2 : b2t

+ Chọn các Block cần ghi text, Block bắt đầu, Khoảng cách từ Text tới Block, Giá trị bắt đầu, Gia số => Lisp sẽ đánh số với gia số và quy luật như trên với mỗi Block

Chúc bạn vui

(defun c:b2pl (/ ss estart dump)
(grtext -1 "Free lisp from CadViet @Ketxu")
(setvar "nomutt" 1)(prompt "Ch\U+1ECDn c\U+00E1c Block mu\U+1ED1n k\U+1EBB Pline :")
(setq ss (ssget (list (cons 0 "INSERT")))
	dump (setvar "nomutt" 0) 
	estart (car (entsel "\nCh\U+1ECDn \U+0111\U+1ED1i t\U+01B0\U+1EE3ng \U+0111\U+1EA7u :"))
	)
(ST:Entmake-Pline
(ST:List-Sort-ByDistance
	(ST:Ss->ListBasePoint ss)
	(vl-position (ST:Ent-Dxf 10 estart) (ST:Ss->ListBasePoint ss))
)
	(getvar "clayer")
	4
	Nil
)
)




(defun c:b2t (/ ss estart tH dump)
(grtext -1 "Free lisp from CadViet @Ketxu")
(setvar "nomutt" 1)(prompt "Ch\U+1ECDn c\U+00E1c Block mu\U+1ED1n k\U+1EBB Pline :")
(or #a (setq #a 2))
(or #start (setq #start 1))
(or #inc (setq #inc 1))

(setq ss (ssget (list (cons 0 "INSERT")))
	dump (setvar "nomutt" 0)
	estart (car (entsel "\nCh\U+1ECDn \U+0111\U+1ED1i t\U+01B0\U+1EE3ng \U+0111\U+1EA7u :")) 
	a1 (getreal (strcat "\nKho\U+1EA3ng c\U+00E1ch t\U+1EEB Text t\U+1EDBi BasePoint c\U+1EE7a Block < " (rtos #a 2 1) " >: ") )
	start1 (getreal (strcat "\nS\U+1ED1 b\U+0103t \U+0111\U+1EA7u : < " (rtos #start 2 1) " >: ")) 
	inc1 (getreal (strcat "\nGia s\U+1ED1 < " (rtos #inc 2 1) " >: ") 		)
	tH (* 5 (getvar "dimtxt")(getvar "dimscale"))
)
(if a1 (setq #a a1))
(if start1 (setq #start start1))
(if inc1 (setq #inc inc1))

(mapcar
(function
(lambda (x )
(wtxt_l (rtos  #start 2 0) (mapcar '+ x (list 0 #a 0)) tH)(setq #start (+ #start #inc)))) 
(ST:List-Sort-ByDistance
	(ST:Ss->ListBasePoint ss)
	(vl-position (ST:Ent-Dxf 10 estart) (ST:Ss->ListBasePoint ss))
)

)
)

;;;;;;;;;;;;; Local Functions 

(defun wtxt_l(txt p h)(entmakex (list (cons 0 "TEXT") (cons 7 (getvar "textstyle")) (cons 40 h)(cons 1 txt) (cons 10 p))))
(defun ST:Ent-Dxf (dxfCode Ent)(if (= (type Ent) 'ENAME)(cdr (assoc dxfCode (entget Ent))) nil))
(defun ST:Ss->ListBasePoint (ss / n l)
;31-7-2011 @Ketxu
 (setq n (sslength ss))
 (while (setq e (ssname ss (setq n (1- n))))
   (setq l (cons (ST:Ent-Dxf 10 e) l))
 )  
)
(defun ST:Entmake-Pline (list_pt Layer Color isClosed / Polylist)
;31-7-2011 @Ketxu
(setq Polylist 
(list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline")
   (cons 8 Layer) 
   (cons 43 0) 
   (cons 62 Color) 
   (cons 90 (length list_pt))
(cons 70 (cond ((= isClosed T) 1)(T 0)))
)
Polylist (append Polylist (mapcar '(lambda (coord) (cons 10 coord)) list_pt)))
(entmakex PolyList)
)
(defun ST:List-Sort-ByDistance (lst start / lstRT 1st item lstDis)
;31-7-2011 @Ketxu
(setq 1st (nth start lst) lstRT (list 1st) lst (append lstRT (vl-remove 1st lst)))
(while (> (length lst) 1)
(setq lst (vl-remove (setq item (nth (1+ (vl-position (setq mindis (apply 'min (setq lstDis (cdr (mapcar '(lambda(x) (distance 1st x)) lst))))) lstDis)) lst)) lst))
(setq lstRT (cons item lstRt))
(setq 1st (car lstRT))
)
(reverse lstRT)
)

Cảm ơn anh ketxu rất nhiều. Lisp 1 chạy rất tốt ạ, còn lisp 2 là lisp điền text ấy, anh có thể thêm một mục để người dùng nhập chiều cao chữ được không ạ, vì chiều cao chữ khi xuất ra lúc thì 0.9, lúc thì 10...


<<

Filename: 162169_b2pl_b2t.lsp

Trang 237/330

237