Jump to content
InfoFile
Tác giả: hiepttr
Bài viết gốc: 388271
Tên lệnh: dong7
[Yêu Cầu] Cắm Cọc Gpmb Trên 2 Mép Ngoài Taluy Trên Bình Đồ

Nghe bác xúi bậy làm thử thế này thì tiết kiệm được 547millisecs so với DONG6 ở trên :D :D :D

p/s:

Bác cho hỏi khhông biết mình suy lụn thế này có đúng ko ? :D :D  :D

 

- Để vòng lặp có thể "thoát ngang" khi tìm thấy tên cọc >>> Chỉ có thể là while

- Không nên dùng nth thì trung thành với car, setq, cdr vậy (mấy...

>>

Nghe bác xúi bậy làm thử thế này thì tiết kiệm được 547millisecs so với DONG6 ở trên :D :D :D

p/s:

Bác cho hỏi khhông biết mình suy lụn thế này có đúng ko ? :D :D  :D

 

- Để vòng lặp có thể "thoát ngang" khi tìm thấy tên cọc >>> Chỉ có thể là while

- Không nên dùng nth thì trung thành với car, setq, cdr vậy (mấy thằng này chắc ko dính chấu tốc độ chứ bác nhỉ ^^ )

:D :D :D

(defun c:DONG7 ( / lst_va old ss_coc ss lst_name tim tlt tlp lst_ten_coc lst_ten_coc2 lst_coc mid_pnt ten ob trai phai mid_pt fn pw c last_piles)
;
(vl-load-com)
;
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nQuet chon BD de lay ten coc !")
(setq ss_coc (ssget '((0 . "LINE") (8 . "Texttencoc"))))
(if ss_coc 
	(progn
		(princ "\n Chon MEPTLT, MEPTLP, tim tuyen !")
		(setq ss (ssget '((8 . "MEPTLT,MEPTLP,TUYEN"))))
		(setq lst_name (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
		(setq tim (car (vl-remove-if-not '(lambda(x) (= "TUYEN" (cdr (assoc 8 (entget x))))) lst_name))
			tlt (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLT" (cdr (assoc 8 (entget x))))) lst_name)))
			tlp (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLP" (cdr (assoc 8 (entget x))))) lst_name))))
		(command ".zoom" "o" ss_coc "")
		(setq	lst_ten_coc (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss_coc)))
				lst_ten_coc (mapcar '(lambda (x) (list x (get_text_coc x 6 13))) lst_ten_coc))
		(setq lst_coc (ssget "_F" (lst_point_fence tim) '((0 . "LINE") (8 . "ENTCOC"))))
		(setq lst_coc (vl-remove-if 'listp (mapcar 'cadr (ssnamex lst_coc))))
		;-----------------------
		(setq t1 (getvar 'millisecs))
		;;==================
		(setq lst_coc 
			(mapcar 
				'(lambda (x) 
					(setq	mid_pnt (mid (vlax-curve-getStartpoint x) (vlax-curve-getEndpoint x))
							lst_ten_coc2 lst_ten_coc)
					(while (and lst_ten_coc2 (not (setq find (find_piles (car (setq ten (car lst_ten_coc2))) mid_pnt 50))))
						(setq lst_ten_coc2 (cdr lst_ten_coc2))
					)	  ;while
					(if find (list x mid_pnt (last ten)) (list x mid_pnt "No name"))
				)
				lst_coc)
		)
		;;====================
		(setq t2 (getvar 'millisecs))
		(princ (strcat "\nDoan find_piles chay het " (rtos (- t2 t1)) "millisecs"))
		;;-----------------------
		(setq fn (getfiled "Chon file de xuat ket qua" "" "csv" 1))
		(setq pw (open fn "w"))
		(write-line "STT,Ten coc,K/c le,Trai,,,Phai" pw)
		(write-line ",,,K/cach den tim,Y,X,K/cach den tim,Y,X" pw)
	;;xong tieu de
		(setq c (car lst_coc))
			(setq 	mid_pt (cadr c)
					last_piles mid_pt
					trai (car (vl-sort (H:inter-group3 (setq ob (vlax-ename->vla-object (car c))) tlt) '(lambda (x y) (< (distance x mid_pt) (distance y mid_pt)))))
					phai (car (vl-sort (H:inter-group3 ob tlp) '(lambda (x y) (< (distance x mid_pt) (distance y mid_pt)))))
			)
			(Ket_insert "cocmoc" trai 1 0)
			(Ket_insert "cocmoc" phai 1 0)
			(make_dim_al mid_pt trai)
			(make_dim_al mid_pt phai)
			(write-line (strcat "," (last c) "," "," (rtos (distance mid_pt trai) 2 3) "," (rtos (cadr trai) 2 3) "," (rtos (car trai) 2 3)
											"," (rtos (distance mid_pt phai) 2 3) "," (rtos (cadr phai) 2 3) "," (rtos (car phai) 2 3)) pw)
	;xong dong 1	
		(foreach c (cdr lst_coc)
			(setq 	mid_pt (cadr c)
					trai (car (vl-sort (H:inter-group3 (setq ob (vlax-ename->vla-object (car c))) tlt) '(lambda (x y) (< (distance x mid_pt) (distance y mid_pt)))))
					phai (car (vl-sort (H:inter-group3 ob tlp) '(lambda (x y) (< (distance x mid_pt) (distance y mid_pt)))))
			)
			(Ket_insert "cocmoc" trai 1 0)
			(Ket_insert "cocmoc" phai 1 0)
			(make_dim_al mid_pt trai)
			(make_dim_al mid_pt phai)
			(write-line (strcat "," (last c)"," (rtos (distance mid_pt last_piles) 2 3) "," (rtos (distance mid_pt trai) 2 3) "," (rtos (cadr trai) 2 3) "," (rtos (car trai) 2 3)
											"," (rtos (distance mid_pt phai) 2 3) "," (rtos (cadr phai) 2 3) "," (rtos (car phai) 2 3)) pw)
			(setq last_piles mid_pt)
		)
		(close pw)
	)
	(princ "\nKhong chon duoc line ten coc !")
)
(mapcar 'setvar lst_va old)
(princ)
)
;;;==============================================================
(defun mid (p1 p2) (mapcar '* (mapcar '+ p1 p2) '(0.5 0.5 0.5)))
;;;;==============================================================
(defun H:inter-group3(ob1 ob2 / modul res)
(cond 
	((null (setq modul (vlax-invoke ob1 'intersectwith ob2 acExtendThisEntity))) nil)
	((= (length modul) 3) (list modul))
	(t 
		(while (> (length modul) 0)
			(setq	res (cons (list (car modul) (cadr modul) (caddr modul)) res)
					modul (cdddr modul)
			)
		)
		(reverse res)
	)
)
)
;;;;===================================================================
(defun lst_point_fence (pl / info lst_bug lst_point i arc_len fence pre fence1)
(setq	info (entget pl '("*"))
		lst_bug (vl-remove-if-not '(lambda(x) (= 42 (car x))) info)
		lst_point (vl-remove-if-not '(lambda(x) (= 10 (car x))) info)
		i 0)
(while (< i (length lst_bug))
	(cond 
		((/= 0 (cdr (nth i lst_bug)))
			(setq	fence (cons (cdr (nth i lst_point)) fence)
					arc_len (abs (- (setq start (vlax-curve-getDistAtPoint pl (cdr(nth i lst_point)))) (vlax-curve-getDistAtPoint pl (cdr (nth (setq i (1+ i)) lst_point)))))
					
			)
			(repeat 3 
				(setq 	fence (cons (vlax-curve-getPointAtDist pl (setq start (+ start (/ arc_len 4)))) fence))
			)
		)
		(t (setq 
				fence (cons (cdr (nth i lst_point)) fence)
				i (1+ i))
		)
	)
)
(setq	pre (car fence)
		fence1 (list pre))
(foreach p (cdr fence)
	(cond ((not (equal 0 (distance p pre) 1e-3)) 
			(setq	fence1 (cons p fence1)
					pre p))
	)
)
fence1
)
;;;===============================================================
(defun get_text_coc (ent h w / info dau_line cuoi_line pt1 pt2 pt3 pt4 ss)
;ham lay text ten coc thuoc layer "Texttencoc" khi co line vach chi gan text
;h, w: chieu cao, rong cuar window vung chon
(setq	dau_line (cdr (assoc 10 (setq info (entget ent))))
		cuoi_line (cdr (assoc 11 info))
		pt1 (polar cuoi_line (+ (setq ang_line (angle dau_line cuoi_line)) (* 0.5 pi)) (* 0.5 w))
		pt2 (polar pt1 ang_line h)
		pt3 (polar pt2 (- ang_line (* 0.5 pi)) w)
		pt4 (polar cuoi_line (- ang_line (* 0.5 pi)) (* 0.5 w))
)
(setq ss (ssget "_WP" (list pt1 pt2 pt3 pt4) '((0 . "TEXT") (8 . "Texttencoc"))))
(if ss (cdr (assoc 1 (entget (ssname ss 0)))) "No_name")
)
;;;===================================================================
(defun find_piles (line_piles_name pnt_piles lim / st end)
;Tu line ten coc, tim thay point tim coc trong gioi han khoang cach (dien ten coc)
(setq	st (vlax-curve-getStartpoint line_piles_name)
		end (vlax-curve-getEndpoint line_piles_name))
(if (and (<= (distance end pnt_piles) lim) (or (equal (angle end st) (angle end pnt_piles) 7e-3) (equal pi (abs (- (angle end st) (angle end pnt_piles))) 7e-3))) T)
)
;;;===========================================================
(defun make_dim_al(pnt1 pnt2 / )
(setq lst
(list
	'(0 . "DIMENSION")
	'(100 . "AcDbEntity") 
	'(8 . "dim") 
	'(100 . "AcDbDimension") 
	(cons 10 pnt2) 
	(cons 11 (mid pnt1 pnt2))
	'(70 . 33) 
	'(1 . "") 
	'(100 . "AcDbAlignedDimension") 
	(cons 13 pnt1) 
	(cons 14 pnt2) 
))
(entmake lst)
)
;=============================================================
(defun Ket_insert (bname p s r)
;Insert simple static block
;Ten  point scale rotation
(entmake
	(list
		'(0 . "INSERT")      
		(cons 2 bname)
		(cons 10 p)
		(cons 41 s)(cons 42 s)(cons 43 s)      
		(cons 50 r)
	)	  ; list
)
)
;=======================

<<

Filename: 388271_dong7.lsp
Tác giả: hiepttr
Bài viết gốc: 388320
Tên lệnh: scd
Nhờ Viết Lisp Đánh Số Cột Đèn Có Phân Pha!

OK ! :D

Đã update lisp theo ý bạn và sự chỉ điểm của bác ndtnv

 

p/s:

Dẫu biết bạn chỉ có tối đa điện 3 pha A B C.

Nhưng mình đang luyện bài nên nếu bạn muốn thì code trên có thể nâng lên thành n pha :D

 

>>> Cảm ơn bác ndtnv đã chỉ điểm, mình học được khá nhiều từ bác !

;;;lisp danh so cot den
(defun c:SCD( / st str...
>>

OK ! :D

Đã update lisp theo ý bạn và sự chỉ điểm của bác ndtnv

 

p/s:

Dẫu biết bạn chỉ có tối đa điện 3 pha A B C.

Nhưng mình đang luyện bài nên nếu bạn muốn thì code trên có thể nâng lên thành n pha :D

 

>>> Cảm ơn bác ndtnv đã chỉ điểm, mình học được khá nhiều từ bác !

;;;lisp danh so cot den
(defun c:SCD( / st str lst_pha i p vi_tri chu str1)
(vl-load-com)
(setq	#tu (NGT #tu "1" getstring "Tu chieu sang so")
		#lo (NGT #lo "1" getstring "Lo so")
		#st (NGT #st 1 getint "STT cot dau tien")
		st (1- #st)
		str (strcat "TCS" #tu "/L" #lo "/")
		)
;;;========+++++++++++
;Thay doi, them bot lst_pha o day:
(setq lst_pha '("A" "B" "C"))
;;;=======++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;;
(defun add_space (str) (strcat str " "))
(defun add_solidus (str) (strcat str "/"))
(initget 1 (strcat (apply 'strcat (mapcar 'add_space (reverse (cdr (reverse lst_pha))))) (last lst_pha)))
(setq #pha (NGT #pha "A" getkword (strcat "Pha dau tien [" (apply 'strcat (mapcar 'add_solidus (reverse (cdr (reverse lst_pha))))) (last lst_pha) "]")))
;;;========
(setq #text_h (NGT #text_h 2.5 getint "Chieu cao chu"))
(setq i -1)
(while (setq p (getpoint "\nPick: "))
	(setq i (1+ i)
		  st (1+ st)
		  vi_tri (vl-position (strcase #pha) lst_pha)
		  chu (nth (rem (+ i vi_tri) (length lst_pha)) lst_pha)
		  str1 (strcat str (itoa st) chu)
		  )
	(MakeText p str1 #text_h 0 "L" nil nil 2 nil)
)	;while
)
;;;==================================================
(defun NGT(a mac_dinh ham str_nhac / modul)
;;Nhan gia tri
(or a (setq a mac_dinh))
(setq a (cond
	((= "" (setq modul (ham (strcat "\n" str_nhac " <" (vl-princ-to-string a) ">: ")))) a)
	(modul)
	(a)
	)
	)
)
;;;=================================================
(defun MakeText (point string Height Ang justify Style Layer Color xdata / Lst)
; Ang: Radial	
(setq Lst (list '(0 . "TEXT")
				(cons 8 (if Layer Layer (getvar "Clayer")))									
				(cons 62 (if Color Color 256))									
				(cons 10 point)									
				(cons 40 Height)									
				(cons 1 string)									
				(if Ang (cons 50 Ang))									
				(cons 7 (if Style Style (getvar "Textstyle")))									
				(cons -3 (if xdata (list xdata) nil)))				
				justify (strcase justify))	
				(cond ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))				
					  ((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))				
					  ((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))				
					  ((= justify "TL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))))				
					  ((= justify "TC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))))				
					  ((= justify "TR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))))					
					  ((= justify "ML") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))))				
					  ((= justify "MC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))))				
					  ((= justify "MR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))))				
					  ((= justify "BL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))))				
					  ((= justify "BC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))))				
					  ((= justify "BR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1)))))
					  )	
					  (entmakex Lst)
);end
;=================================

<<

Filename: 388320_scd.lsp
Tác giả: duy782006
Bài viết gốc: 388467
Tên lệnh: vmb
Nhờ Viết Lisp: Mặt Bích Trong Kết Cấu Thép

Thử xem sao: Lệnh là VMB

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(Defun duy:xd_listngngancach<kytu (chuoi kytu / chuoi kytu ckq) 
(setq lkq nil)
(setq bdd 1) 
(setq b 1)
(setq l (fix (strlen chuoi)))
(repeat l
(setq a (substr chuoi b 1))
(cond
((= a kytu) 
(setq dkt (substr chuoi bdd (- b bdd)))
(setq lkq (append lkq (list dkt)))
(setq bdd (+ b 1)) 
)
)
(setq b (+ b 1))
)
(setq dkt (substr chuoi bdd...
>>

Thử xem sao: Lệnh là VMB

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(Defun duy:xd_listngngancach<kytu (chuoi kytu / chuoi kytu ckq) 
(setq lkq nil)
(setq bdd 1) 
(setq b 1)
(setq l (fix (strlen chuoi)))
(repeat l
(setq a (substr chuoi b 1))
(cond
((= a kytu) 
(setq dkt (substr chuoi bdd (- b bdd)))
(setq lkq (append lkq (list dkt)))
(setq bdd (+ b 1)) 
)
)
(setq b (+ b 1))
)
(setq dkt (substr chuoi bdd (+ (- l bdd) 1)))
(setq lkq (append lkq (list dkt)))
lkq)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:vmb ()
(setq matbich (getstring "\nNhap kich thuoc mat bich <Cao * Rong>"))
(setq daimatbich (atoi (car (duy:xd_listngngancach<kytu matbich "*"))))
(setq rongmatbich (atoi (cadr (duy:xd_listngngancach<kytu matbich "*"))))
(setq diemve (getpoint "Diem tren ben trai mat bich"))
(command ".RECTANG" "_non" diemve "_non" (list (+ (car diemve) rongmatbich) (- (cadr diemve) daimatbich)) )
(or canhngang (setq canhngang 100))
(setq canhngang (cond ((getreal (strcat "\nKhoang cach ngang giua 2 cot bolon < " (rtos canhngang 2 2) " >:")))(canhngang)))
(setq bulong (getstring "\nNhap khoang cach doc tinh tu tren xuong <khoang1 + khoang2 +...+ khoangn"))
(setq khoangbulong (duy:xd_listngngancach<kytu bulong "+"))
(setq khoangvebulong 0.0)
(foreach khoangbulonghh khoangbulong 
(setq khoangvebulong (+ khoangvebulong  (atoi khoangbulonghh)))
(command ".insert" "BU LONG" "_non"  (list (+ (+ (car diemve) (/ rongmatbich 2)) (/ canhngang 2)) (- (cadr diemve) khoangvebulong)) 0.01 0.01 0)
(command ".insert" "BU LONG" "_non"  (list (- (+ (car diemve) (/ rongmatbich 2)) (/ canhngang 2)) (- (cadr diemve) khoangvebulong)) 0.01 0.01 0)
)
(princ)
)

<<

Filename: 388467_vmb.lsp
Tác giả: pphung183
Bài viết gốc: 388494
Tên lệnh: test
Nh? Vi?t Lisp T?a ?? Theo File ?ính Kem

Các cột trong file csv không phải lúc nào cũng phân cách bằng ","

Tham khảo Lee Mac

(setq sep (cond ((vl-registry-read "HKEY_CURRENT_USER\\Control Panel\\International" "sList")) (",")))

 

Nếu hiepttr chưa sửa lisp thì mở file csv bằng notepad, thay "," bằng

>>

Các cột trong file csv không phải lúc nào cũng phân cách bằng ","

Tham khảo Lee Mac

(setq sep (cond ((vl-registry-read "HKEY_CURRENT_USER\\Control Panel\\International" "sList")) (",")))

 

Nếu hiepttr chưa sửa lisp thì mở file csv bằng notepad, thay "," bằng ";" rồi save lại

Để phân cột file .csv, nó phụ thuộc vào Decimal symbol. Nghĩa là khi ô màu đỏ là dấu "." thì biến (setq sep ","), khi ô màu đỏ là dấu "," thì biến (setq sep ";")

tất nhiên ô màu xanh là ăn theo (nếu Decimal symbol là "." thì Digit grouping là "," là ngược lại)

Bạn Test thử Lisp của Lee khi thay đổi Decimal symbol để kiểm nghiệm trong trường hợp này thì có lẽ Lee đã nhầm lẫn :)

;; Write CSV  -  Lee Mac
;; Writes a matrix list of cell values to a CSV file.
;; lst - [lst] list of lists, sublist is row of cell values
;; Returns T if successful, else nil
(defun LM:writecsv ( lst csv / des sep )
(if (setq des (open csv "w")) (progn
(setq sep (cond ( (vl-registry-read "HKEY_CURRENT_USER\\Control Panel\\International" "sList")) (",")))    
(foreach row lst (write-line (LM:lst->csv row sep) des)) (close des) t)))
;; Concatenates a row of cell values to be written to a CSV file.
;; lst - [lst] list containing row of CSV cell values
;; sep - [str] CSV separator token
(defun LM:lst->csv (lst sep) 
(if (cdr lst) (strcat (LM:csv-addquotes (car lst) sep) sep (LM:lst->csv (cdr lst) sep))
(LM:csv-addquotes (car lst) sep) )) 
(defun LM:csv-addquotes (str sep / pos) 
(cond ((wcmatch str (strcat "*[`" sep "\"]*")) (setq pos 0)    
(while (setq pos (vl-string-position 34 str pos)) (setq str (vl-string-subst "\"\"" "\"" str pos)
pos (+ pos 2)) ) (strcat "\"" str "\"") ) (str) )) ;;;;;
(defun c:test ( / ss fn in lst)
(if (and (setq ss (ssget '((0 . "POINT"))))
(setq fn (getfiled "Create Output File" "" "csv" 1)) ) (progn (repeat (setq in (sslength ss)) 
(setq lst (cons (mapcar 'rtos (cdr (assoc 10 (entget (ssname ss (setq in (1- in))))))) lst)) )
(if (LM:WriteCSV (reverse lst) fn) (startapp "explorer" fn)) )) (princ)) 

127397_csv_1.png


<<

Filename: 388494_test.lsp
Tác giả: tien2005
Bài viết gốc: 388728
Tên lệnh: cut
Nhờ Sửa Lại Lisp Cut

Bạn dùng lisp này

(defun c:CUT (/ p1 p2 p3 p4 p5 p6 pm lst)
  (prompt "\nExpansion symbol. ")
  (or #dist (setq #dist 0))
  (if (and (setq p1 (getpoint "\nFirst point : "))
	   (setq p2 (getpoint "\nSecond point : " p1))
	   (setq #dist
		  (cond
		    ((getdist (strcat "\nHow big ? <" (rtos #dist 2 2) ">: ")
		     )
		    )
		    (#dist)
		  )
	   )
      )
    (progn
      (setq p1 (trans p1 1 0)
	    p2 (trans p2 1 0)
	    pm (polar p1 (angle p1...
>>

Bạn dùng lisp này

(defun c:CUT (/ p1 p2 p3 p4 p5 p6 pm lst)
  (prompt "\nExpansion symbol. ")
  (or #dist (setq #dist 0))
  (if (and (setq p1 (getpoint "\nFirst point : "))
	   (setq p2 (getpoint "\nSecond point : " p1))
	   (setq #dist
		  (cond
		    ((getdist (strcat "\nHow big ? <" (rtos #dist 2 2) ">: ")
		     )
		    )
		    (#dist)
		  )
	   )
      )
    (progn
      (setq p1 (trans p1 1 0)
	    p2 (trans p2 1 0)
	    pm (polar p1 (angle p1 p2) (/ (distance p1 p2) 2))
	    ;p3 (polar pm (+ (angle p1 p2) (/ pi 2)) (/ #dist 2))
	    ;p4 (polar pm (- (angle p1 p2) (/ pi 2)) (/ #dist 2))
	    ;p5 (polar pm (angle p1 p2) (/ #dist 6))
	    ;p6 (polar pm (angle p2 p1) (/ #dist 6))

	    p5 (polar pm (angle p1 p2) (/ #dist 2))
	    p6 (polar pm (angle p2 p1) (/ #dist 2))
	    p3 (polar p6 (+ (angle p6 p5) (/ pi 2)) (/ #dist 3))
	    p4 (polar p5 (+ (angle p5 p6) (/ pi 2)) (/ #dist 3))
      )
      (setq Lst	(list '(0 . "LWPOLYLINE")
		      '(100 . "AcDbEntity")
		      '(100 . "AcDbPolyline")
		      (cons 90 6)
		      (cons 70 0)
		)
      )
      (foreach PP (list p1 p6 p3 p4 p5 p2)
	(setq Lst (append Lst (list (cons 10 PP))))
      )
      (entmakex Lst)
    )
  )
  (princ)
)

<<

Filename: 388728_cut.lsp
Tác giả: duy782006
Bài viết gốc: 388716
Tên lệnh: vmb
Nhờ Viết Lisp: Mặt Bích Trong Kết Cấu Thép
グラハム 時計 スーパーコピー n級

Filename: 388716_vmb.lsp
Tác giả: pphung183
Bài viết gốc: 374761
Tên lệnh: edt
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Mình hay dùng lisp này để sữa nhanh các đối tượng có Text :) :

(defun c:edt (/ ent subent tn) 
(setq ent (entsel "\nPick chon Text : ")) 
(setq subent (car (nentselp (cadr ent))))
(setq tn (lisped (cdr (assoc 1 (entget subent)))))
(entmod (subst (cons 1 tn) (assoc 1 (entget subent)) (entget subent)))
(entupd (car ent))
(princ))


Filename: 374761_edt.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 369343
Tên lệnh: ha
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Chúc mừng em đã hoàn thành tác phẩm. Tặng em hàm này, viết trau chuốt hơn, và tốc độ chắc chắn sẽ nhanh hơn các hàm ở trên.

; Doc va sap xep 1 file *.txt thanh 1 list gom cac nhom khac nhau.
(defun C:HA (/ fn group)
 (setq group "COC")
 (if (setq fn (getfiled "Select File" (getvar "dwgprefix") "txt" 8))
  (HA fn group)))
(defun HA (fn group / fr line lst1 lst2) 
 (setq fr (open...
>>

Chúc mừng em đã hoàn thành tác phẩm. Tặng em hàm này, viết trau chuốt hơn, và tốc độ chắc chắn sẽ nhanh hơn các hàm ở trên.

; Doc va sap xep 1 file *.txt thanh 1 list gom cac nhom khac nhau.
(defun C:HA (/ fn group)
 (setq group "COC")
 (if (setq fn (getfiled "Select File" (getvar "dwgprefix") "txt" 8))
  (HA fn group)))
(defun HA (fn group / fr line lst1 lst2) 
 (setq fr (open (findfile fn) "r"))
 (while (setq line (read-line fr))
  (if (vl-string-search group line)
   (setq lst2 (append lst2 (list lst1))
         lst1 (list (read (vl-string-trim "\t" (vl-string-trim group line)))))
   (setq lst1 (Rcons (Ptr->L line) lst1))))
 (close fr)
 (cdr (append lst2 (list lst1))))
(defun Rcons (ele lis)
 (reverse (cons ele (reverse lis))))
(defun Ptr->L(ptr)
 (read (strcat "(" ptr ")")))

<<

Filename: 369343_ha.lsp
Tác giả: nguyentieu
Bài viết gốc: 388333
Tên lệnh: tdt tcd
[Nhờ sửa lisp] Đo tổng chiều dài đối tượng trên Autocad 2015

Xem qua code TDT và TCD là giống nhau nhưng ở Cad2015 thì TCD bị đơ cũng lạ nhỉ? :wub:

Bạn thử thay (command "lengthen" ent "") bằng

>>

Xem qua code TDT và TCD là giống nhau nhưng ở Cad2015 thì TCD bị đơ cũng lạ nhỉ? :wub:

Bạn thử thay (command "lengthen" ent "") bằng (command "area" "o" ent) xem sao :)

 

Tình hình là sau khi thay dòng lệnh như bác pphung183 thì ok rồi. Em cảm ơn bác nhiều nhé.

Em up lại để mọi người dùng

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/120974-nho-sua-lisp-do-tong-chieu-da-i-doi-tuong-tra-n-autocad-2015/page-2
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/59317-nho-chi-nh-su-a-lisp-ti-nh-to-ng-die-n-ti-ch-va-chu-vi-ca-c-hi-nh/
(defun c:tdt(/ dt sdt gt tgt id pt1)
  (setq dt (ssget
  	'((-4 . "<OR")
   (0 . "CIRCLE")
   (0 . "*POLYLINE")
   (-4 . "OR>")
     	))
 )
  (setq
 sdt (sslength dt)
 id 0
 tgt 0)
(testcaochu)
  (repeat sdt
	(setq ent (ssname dt id)
   id (1+ id)
   )
	(command "area" "o" ent "")
	(setq gt (getvar "area"))
	(setq tgt (+ tgt gt))
	(princ)
	)
(setq pt1 (getpoint "\nchon diem ghi chu:"))
  (command "text" "j" "mc" pt1 (rtos caochu) "0" (strcat(rtos (/ tgt 1000000) 2 1) "m2"))
  (princ)
  )
;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:tcd(/ DT SDT TCD PT1)
  (setq dt (ssget '((-4 . "<OR")
   (0 . "CIRCLE")
   (0 . "ELLIPSE")
   (0 . "SPLINE")
   (0 . "ARC")
   (0 . "LINE")
   (0 . "*POLYLINE")
   (-4 . "OR>")
		))
)
(testcaochu)
  (setq sdt (sslength dt))
  (setq
  	index 0
  	tcd 0
  	)
  (repeat sdt
	(setq
  	ent (ssname dt index)
  	index (1+ index)    
  	)    
	(command "area" "o" ent)
	(setq cd (getvar "perimeter"))
	(setq tcd (+ tcd cd))
	)
  (setq pt1 (getpoint "\nchon diem ghi chu:"))
  (command "text" "j" "mc" pt1 (rtos caochu) "0" (strcat(rtos (/ tcd 1000) 2 1) "m"))
  (princ)
  )
;;;;;;;;;;;;;;;;;;
(defun testcaochu()
  (if (not caochu1)
	(setq caochu (getdist "\nchieu cao chu? :"))
	(setq caochu (getdist (strcat "chieu cao chu <" (rtos caochu1) ">:")))
	)
  (if (= caochu nil) (setq caochu caochu1))
  (setq caochu1 caochu)

<<

Filename: 388333_tdt_tcd.lsp
Tác giả: ketxu
Bài viết gốc: 305341
Tên lệnh: dxf%3F al%3F
Mã Dxf các đối tượng trong CAD

Chính xác. Và ket hay gọi nó như sau :

 

(defun chm(f)(or (help f)(startapp "hh.exe" f)))
(defun c:dxf?()(chm "acad_dxf.chm"))
(defun c:al?()(chm "acad_alr.chm"))
;.....

Filename: 305341_dxf%3F_al%3F.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 390192
Tên lệnh: dl
[yêu cầu] Lisp thay đổi chiều cao text của dimstyle cực nhanh !

CÓ AI GIẢI GIÚP MÌNH BÀI TOÀN NÀY VỚI

SAU KHI DIM KÍCH THƯỚC XONG MÌNH MUỐN LẤY SÔ KÍCH THƯỚC ĐÓ CHO VÀO 1 BANG TRONG CAD LUÔN. DIM KÍCH THƯỚC XONG MÌNH CỨ PHẢI COPY RỒI PASTE LÂU QUÁ. CÒN NHẬP BẰNG TAY ĐÔI KHI VẪN BỊ SAI. 

Hề hề hề,

Chưa hiểu cái bảng của bạn ra sao...

>>

CÓ AI GIẢI GIÚP MÌNH BÀI TOÀN NÀY VỚI

SAU KHI DIM KÍCH THƯỚC XONG MÌNH MUỐN LẤY SÔ KÍCH THƯỚC ĐÓ CHO VÀO 1 BANG TRONG CAD LUÔN. DIM KÍCH THƯỚC XONG MÌNH CỨ PHẢI COPY RỒI PASTE LÂU QUÁ. CÒN NHẬP BẰNG TAY ĐÔI KHI VẪN BỊ SAI. 

Hề hề hề,

Chưa hiểu cái bảng của bạn ra sao cả....

Bạn có thể tham khảo lisp dưới đây và chế biến cho hợp ý bạn nhé.

http://www.cadviet.com/upfiles/5/5194_dimline.lsp

 

(defun c:DL ( / ans e dt pt )
(setq ans (getstring "\n Chon dimlinear <Y or N> : "))
(if (= (strcase ans) "Y") 
(command "_dimlinear" (getpoint "\n Nhap diem dau cua kich thuoc can do")
                                          (getpoint "\n Nhap diem cuoi cua kich thuoc can do") 
                                          (getpoint "\n Nhap diem dat cua kich thuoc can do"))
(command "_dimaligned" (getpoint "\n Nhap diem dau cua kich thuoc can do")
                                          (getpoint "\n Nhap diem cuoi cua kich thuoc can do") 
                                          (getpoint "\n Nhap diem dat cua kich thuoc can do"))
)
(setq e (entlast)
         es (entget e)
         dt (rtos (cdr (assoc 42 es)) 2 2)
         pt (getpoint "\n Nhap diem dat cua text kich thuoc")  )
(command "text" "J" "MC" "non" pt 2 0 dt)
(princ)
)

<<

Filename: 390192_dl.lsp
Tác giả: nguyentieu
Bài viết gốc: 388020
Tên lệnh: tdt tcd
[Nhờ sửa lisp] Đo tổng chiều dài đối tượng trên Autocad 2015

Chào cả nhà,

 

Hôm nay search topic này đúng ngay chỗ bữa giờ e lăn tăn. Chẳng là e đang dùng cái lisp TDT TCD, hjx, kể từ khi xài qua thằng Cad 16 thì TDT vẫn ok, trong khi thằng TCD lại "đơ". Bác nào fix giúp em lỗi này với nhé, thanks  :)

;; free lisp from cadviet.com
;;; this lisp was downloaded from...
>>

Chào cả nhà,

 

Hôm nay search topic này đúng ngay chỗ bữa giờ e lăn tăn. Chẳng là e đang dùng cái lisp TDT TCD, hjx, kể từ khi xài qua thằng Cad 16 thì TDT vẫn ok, trong khi thằng TCD lại "đơ". Bác nào fix giúp em lỗi này với nhé, thanks  :)

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/59317-nho-chi-nh-su-a-lisp-ti-nh-to-ng-die-n-ti-ch-va-chu-vi-ca-c-hi-nh/
(defun c:tdt(/ dt sdt gt tgt id pt1)
  (setq dt (ssget
  	'((-4 . "<OR")
   (0 . "CIRCLE")
   (0 . "*POLYLINE")
   (-4 . "OR>")
     	))
 )
  (setq
 sdt (sslength dt)
 id 0
 tgt 0)
(testcaochu)
  (repeat sdt
	(setq ent (ssname dt id)
   id (1+ id)
   )
	(command "area" "o" ent "")
	(setq gt (getvar "area"))
	(setq tgt (+ tgt gt))
	(princ)
	)
(setq pt1 (getpoint "\nchon diem ghi chu:"))
  (command "text" "j" "mc" pt1 (rtos caochu) "0" (strcat(rtos (/ tgt 1000000) 2 1) "m2"))
  (princ)
  )
;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:tcd(/ DT SDT TCD PT1)
  (setq dt (ssget '((-4 . "<OR")
   (0 . "CIRCLE")
   (0 . "ELLIPSE")
   (0 . "SPLINE")
   (0 . "ARC")
   (0 . "LINE")
   (0 . "*POLYLINE")
   (-4 . "OR>")
		))
)
(testcaochu)
  (setq sdt (sslength dt))
  (setq
  	index 0
  	tcd 0
  	)
  (repeat sdt
	(setq
  	ent (ssname dt index)
  	index (1+ index)    
  	)    
	(command "lengthen" ent "")
	(setq cd (getvar "perimeter"))
	(setq tcd (+ tcd cd))
	)
  (setq pt1 (getpoint "\nchon diem ghi chu:"))
  (command "text" "j" "mc" pt1 (rtos caochu) "0" (strcat(rtos (/ tcd 1000) 2 1) "m"))
  (princ)
  )
;;;;;;;;;;;;;;;;;;
(defun testcaochu()
  (if (not caochu1)
	(setq caochu (getdist "\nchieu cao chu? :"))
	(setq caochu (getdist (strcat "chieu cao chu <" (rtos caochu1) ">:")))
	)
  (if (= caochu nil) (setq caochu caochu1))
  (setq caochu1 caochu)
  )
  


<<

Filename: 388020_tdt_tcd.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 390440
Tên lệnh: cpd
Xin Lisp Copy Tăng Giảm Theo Độ Dốc

Không phải tiết kiệm lời mà tưởng nói như vậy là hiểu rồi chứ. 

Trong diễn đàn có lisp copy tăng giảm với một hằng số cho trước. nhưng mình muốn một  lisp copy tăng giảm theo độ dốc cho trước.

Nó có dạng kiểu như thế này: Ta copy một số từ điểm A đến điểm B. Đầu tiên nó...

>>

Không phải tiết kiệm lời mà tưởng nói như vậy là hiểu rồi chứ. 

Trong diễn đàn có lisp copy tăng giảm với một hằng số cho trước. nhưng mình muốn một  lisp copy tăng giảm theo độ dốc cho trước.

Nó có dạng kiểu như thế này: Ta copy một số từ điểm A đến điểm B. Đầu tiên nó tự nhận text tại điểm A, sau đó ta nhập dộ dốc cần copy, sau đó copy đến điểm B,  lisp tự nhận khoảng cách từ A đến B và cộng hoặc trừ với khoảng chênh lệch do độ dốc từ A đến B.

VD như sau: Từ A đến B có độ dốc 2%. điểm A có cao độ 10m, khoảng cách từ A đến B là 10m (cái khoảng cách này là mình VD thôi, còn  lisp trong bài toán nó sẽ tự nhận khi copy từ A sang B). Như vậy khi copy từ A đến B sẽ cho giá trị tại điểm B là: 10.2m (B = 10+2%*10 = 10.2m) và cứ thế ta copy đến điểm C, D ... nó sẽ tự cho các kết quả

 Lisp này theo mình nghĩ giống  lisp copy tăng giảm trên diễn đàn nhưng khác là thông số nhập vào là % tăng giảm theo độ dốc và  lisp tự nhận khoảng cách trong quá trình ta copy.

AE ai rành về  lisp có thể giúp mình với. Mình cảm ơn nhiều!

Hề hề hề,

Gửi bạn cái này để bạn tham khảo. Không biết có đúng ý bạn không. Nếu đúng thì tốt và nếu không đúng càng tốt hơn bởi bạn sẽ hiểu rằng không phải mọi người đều giỏi như bạn.. Vì thế bạn cần có bản vẽ để mô tả chính xác điều bạn cần nhé.

http://www.cadviet.com/upfiles/5/5194_copycaodo.lsp

(defun c:cpd (/ oldos h els els1 txt dd dd1 h1 p0 p1 )
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq  h (atof (cdr (assoc 1 (setq els (entget (setq txt (car (entsel "\n Chon text cao do bat dau: "))))))))           
         dd 0.0  )
(if (or (= (cdr (assoc 0 els)) "MTEXT") (and (= (cdr (assoc 0 els)) "TEXT") (= (cdr (assoc 72 els)) 0) (= (cdr (assoc 73 els)) 0)))
     (setq p0 (cdr (assoc 10 els)))
     (setq p0 (cdr (assoc 11 els)))
)
(command "undo" "be")
(while (setq p1 (getpoint p0 "\n Nhap diem tiep theo"))
        (if (not (setq dd1 (getreal "\n Nhap do doc tiep theo: ")))
            (setq dd1 dd)   )
        (setq len (distance p0 p1)
                  h1 (+ h (* len dd1))  )
        (command "copy" txt "" p0 p1)
        (setq txt (entlast)
                  els1 (entget txt)
                  els1 (subst (cons 1 (rtos h1 2 2)) (assoc 1 els1) els1) )
        (entmod els1)
        (setq p0 p1 h h1 dd dd1)
)
(command "undo" "e")
(setvar "osmode" oldos)
(princ)
)
             

<<

Filename: 390440_cpd.lsp
Tác giả: Tue_NV
Bài viết gốc: 105832
Tên lệnh: glb
Hướng dẫn lập trình Lisp


Của bạn được sửa lại

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


Chào bác SSG
Em đã tìm ra code của bác Nguyễn Hoành viết về cái này



Hiên tại em chưa hiểu rõ về ss2ent còn vl-sort sau khi search trong help đã hiểu đại khái rồi. Có vài điều chưa hiểu xin hỏi bác 1 tí
- Sao mình dùng ...(caddr (assoc 10 (entget e1)))..., nhưng trong help dùng (
>>


Chào bác SSG
Em đã tìm ra code của bác Nguyễn Hoành viết về cái này



Hiên tại em chưa hiểu rõ về ss2ent còn vl-sort sau khi search trong help đã hiểu đại khái rồi. Có vài điều chưa hiểu xin hỏi bác 1 tí
- Sao mình dùng ...(caddr (assoc 10 (entget e1)))..., nhưng trong help dùng (:cheers:
Cám ơn bác nhiều lắm.
<<

Filename: 49548_test.lsp
Tác giả: ketxu
Bài viết gốc: 390835
Tên lệnh: foo
[Hỏi, Thủ Thuật] Tìm Và Thay Thế Đối Tượng Trong Cad

Hàng loạt như thế này thì code lisp là ngon xơi nhất. Nếu không thì cũng phải làm khoảng 3 bước
Bạn đọc kỹ bài của bác Anti lazy, có lý đó :)
Lần này chữa cháy cho bạn bằng code ngắn, test thử trên máy mình ok
(defun c:foo()
	(foreach e (acet-ss-to-list (ssget '((0 . "LINE")(8 . "S5"))))
		(entmake (list '(0 . "INSERT")
						(cons 2 "S5")
						(cons 10 (apply...
>>
Hàng loạt như thế này thì code lisp là ngon xơi nhất. Nếu không thì cũng phải làm khoảng 3 bước
Bạn đọc kỹ bài của bác Anti lazy, có lý đó :)
Lần này chữa cháy cho bạn bằng code ngắn, test thử trên máy mình ok
(defun c:foo()
	(foreach e (acet-ss-to-list (ssget '((0 . "LINE")(8 . "S5"))))
		(entmake (list '(0 . "INSERT")
						(cons 2 "S5")
						(cons 10 (apply 'acet-geom-midpoint (acet-geom-extents e)))											
				)
		)
		(entdel e)
	) (princ)
)

<<

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

Bác cho em xem tí ... ti code.

Em chưa thấy là em chưa tin ạ,

cái zụ này người trong cuộc thường không tĩnh táo cho lắm, lúc nào cũng nói là "em chả làm gì cả mà nó cứ ...gây hậu quả nghiêm trọng".

Hề hề hề,

Muốn code thì có code đây:

 

Lưu ý rằng trong hàm...

>>

Bác cho em xem tí ... ti code.

Em chưa thấy là em chưa tin ạ,

cái zụ này người trong cuộc thường không tĩnh táo cho lắm, lúc nào cũng nói là "em chả làm gì cả mà nó cứ ...gây hậu quả nghiêm trọng".

Hề hề hề,

Muốn code thì có code đây:

 

Lưu ý rằng trong hàm (alert ....) nếu thay (itoa (loga2 (1+ i))) bằng hàm (itoa i) sẽ thấy sự khác nhau giữa giá trị của i và số bước đệ quy thực tế.

(defun chua ( a / b b1 b2 b3 b4  )
;;;;;(setq i 0)
(while (not (equal a 6174 0.1))
(setq  ;;;;;a (getint "\n Nhap so co 4 chu so: ")
          b (itoa a)
          b1 (+ (atoi (substr b 1 1)) 0.1)
          b2 (+ (atoi (substr b 2 1)) 0.2)
          b3 (+ (atoi (substr b 3 1)) 0.3)
          b4 (+ (atoi (substr b 4 1)) 0.4)
          bls1 (vl-sort (list b1 b2 b3 b4) '(lambda (x y) (>= x y)))
          bls2 (vl-sort (list b1 b2 b3 b4) '(lambda (x y) (<= x y)))
          bmax (atoi (strcat (itoa (fix (nth 0 bls1))) (itoa (fix (nth 1 bls1))) (itoa (fix (nth 2 bls1))) (itoa (fix (nth 3 bls1)))))
          bmin (atoi (strcat (itoa (fix (nth 0 bls2))) (itoa (fix (nth 1 bls2))) (itoa (fix (nth 2 bls2))) (itoa (fix (nth 3 bls2)))))
          a (- bmax bmin)   )
(setq i (1+ i))
(if (>= a 1000)
    (progn
           (chua a)
          
    )
    (progn
          (if (>= a 100)
              (setq a (* a 10))
              (setq a (* a 100))
          )
          (chua a)
          
    )
)
 
)
a
 
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:test (/ a i)
(setq i 0)
(setq a (getint "\n Nhap so tu nhien co 4 chu so: "))
(chua a)
(alert (strcat "\n So " (itoa a) " tro thanh So cua chua 6174 sau " (itoa (loga2 (1+ i))) " buoc lap"))
)
;;;;;;;;;;;;;;;;;
(defun loga2 ( a / )
(setq i 0)
(while (/= a  1)
(setq  a (/ a 2)
           i (1+ i)  )
)
i
)  
 

<<

Filename: 390958_test.lsp
Tác giả: pphung183
Bài viết gốc: 386738
Tên lệnh: gd
Lisp L?c ???ng Th?ng Theo ?? D?c!

Test th? cho ý ki?n  :) :

(defun c:gd (/ wtxt ss x y ent obj ht h i m sp ep ang x1 y1 x2 y2 dodoc pt) 
(defun wtxt (txt p ang) (vl-load-com)
(entmakex (list (cons 0 "TEXT") (cons 7 (getvar "textstyle")) (cons 1 txt) (cons 10 p) 
(cons 11 p) (cons 72 1) (cons 73 2) (cons 40 ht) (cons 50 ang))) ) ;;;;;
(princ "\nChon cac doi tuong Line or Pline khong co Arc...")
(setq ss (ssget '((0 . "Line,lwpolyline"))))
(setq x (getreal "\n Nhap ty le theo truc x: ") y...
>>

Test th? cho ý ki?n  :) :

(defun c:gd (/ wtxt ss x y ent obj ht h i m sp ep ang x1 y1 x2 y2 dodoc pt) 
(defun wtxt (txt p ang) (vl-load-com)
(entmakex (list (cons 0 "TEXT") (cons 7 (getvar "textstyle")) (cons 1 txt) (cons 10 p) 
(cons 11 p) (cons 72 1) (cons 73 2) (cons 40 ht) (cons 50 ang))) ) ;;;;;
(princ "\nChon cac doi tuong Line or Pline khong co Arc...")
(setq ss (ssget '((0 . "Line,lwpolyline"))))
(setq x (getreal "\n Nhap ty le theo truc x: ") y (getreal "\n Nhap ty le theo truc y: ")
ht (getreal "\n Hay nhap chieu cao text: ") 
h (getreal "\n Hay nhap khoang cach tu text toi pline: ") h (+ (/ ht 2) h))
(foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
(setq obj (vlax-ename->vla-object ent))
(cond ((eq (vla-get-ObjectName obj) "AcDbPolyline")
(setq i 0 m (vlax-curve-getendparam ent))
(while (< i m) (setq sp (vlax-curve-getPointatparam ent i)
ep (vlax-curve-getPointatparam ent (1+ i)) ang (angle sp ep) x1 (car sp) y1 (cadr sp)
x2 (car ep) y2 (cadr ep)) (if (/= (car sp) (car ep)) (setq dodoc (* (abs (/ (/ (- y2 y1) y) 
(/ (- x2 x1) x)))) dodoc (strcat (rtos dodoc 2 2))) (setq dodoc (rtos (/ pi 2) 2 2)) )
(cond ((< (car sp) (car ep)) (setq pt (vlax-curve-getpointatparam ent (+ i 0.5)))
(wtxt dodoc (list (- (car pt) (* h (sin ang))) (+ (cadr pt) (* h (cos ang)))) ang) ) 
((> (car sp) (car ep)) (setq pt (vlax-curve-getpointatparam ent (+ i 0.5)))
(wtxt dodoc (list (+ (car pt) (* h (sin ang))) (- (cadr pt) (* h (cos ang)))) (+ pi ang)) )
((equal (car sp) (car ep) 1e-3) (setq pt (vlax-curve-getpointatparam ent (+ i 0.5)))
(wtxt dodoc (list (+ (car pt) h) (cadr pt)) (/ pi 2)) ))
(setq i (1+ i)) ))
(T (setq sp (vlax-get obj 'StartPoint)
ep (vlax-get obj 'EndPoint) ang (angle sp ep) x1 (car sp) y1 (cadr sp)
x2 (car ep) y2 (cadr ep) pt (mapcar '(lambda (a b) (/ (+ a b) 2.)) sp ep)) 
(if (/= (car sp) (car ep)) (setq dodoc (* (abs (/ (/ (- y2 y1) y) 
(/ (- x2 x1) x)))) dodoc (strcat (rtos dodoc 2 2))) (setq dodoc (rtos (/ pi 2) 2 2)) )
(cond ((< (car sp) (car ep)) 
(wtxt dodoc (list (- (car pt) (* h (sin ang))) (+ (cadr pt) (* h (cos ang)))) ang) )
((equal (car sp) (car ep) 1e-3) (wtxt dodoc (list (+ (car pt) h) (cadr pt)) (/ pi 2)) ) 
((wtxt dodoc (list (+ (car pt) (* h (sin ang))) (- (cadr pt) (* h (cos ang)))) (+ pi ang)) )))))
(princ))


<<

Filename: 386738_gd.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 390985
Tên lệnh: csa%C2%A0
Xin Lisp Copy Tăng Giảm Theo Độ Dốc

 

Hề hề hề,

Gửi bạn cái này để bạn tham khảo. Không biết có đúng ý bạn không. Nếu đúng thì tốt và nếu không đúng càng tốt hơn bởi bạn sẽ hiểu rằng không phải mọi người đều giỏi như bạn.. Vì thế bạn cần có bản vẽ để mô tả chính xác điều bạn cần nhé.

>>

 

Hề hề hề,

Gửi bạn cái này để bạn tham khảo. Không biết có đúng ý bạn không. Nếu đúng thì tốt và nếu không đúng càng tốt hơn bởi bạn sẽ hiểu rằng không phải mọi người đều giỏi như bạn.. Vì thế bạn cần có bản vẽ để mô tả chính xác điều bạn cần nhé.


cái này của bạn Bình và bạn Mạnh là trúng rồi đó, nó chính là như vậy. Nhưng có một cái bất tiện là khi ta chọn vào text đầu tiên, nó chọn luôn điểm gốc của text làm điểm 1. Hai bạn chỉnh giúp lại một xíu là khi chọn text xong rồi ta chọn tiếp điểm gốc, sau đó mới copy đến điểm số 2. Mình sơ họa bằng cad bạn nào biết giúp mình với, cảm ơn nhiềuhttp://www.cadviet.com/upfiles/5/148940_vd.dwg

* B​ắt đầu có dấu hiệu bớt giỏi rồi đó!

* Sửa lại lisp cho bạn và bổ sung chức năng rải 1 lần nhiều cao độ, với cùng độ dốc và khoảng cách lưới đều nhằm giảm bớt thao tác

* Cần chú ý rằng: Nếu bạn bớt giỏi đi một xíu thì lisp cũng bớt ngu đi một xíu ... :D

(defun c:csa  (/ make_elev dis ent new npt poi slo txt val orp n)
 (defun make_elev  ()
  (setq dis (distance orp npt)
        new (rtos (+ val (* dis slo 0.01 n)) 2 2))
  (entmakex (append (vl-remove-if '(lambda (x) (member (car x) '(-1 1 5 10 330 410))) ent)
                    (list (cons 1 new) (cons 10 (polar poi (angle orp npt) (* dis n)))))))
 (or def_slope (setq def_slope 0))
 (setq slo (getreal (strcat "\nNhap do doc <" (rtos def_slope 2 2) "%>: ")))
 (if (not slo)
  (setq slo def_slope)
  (setq def_slope slo))
 (princ "\nChon cao do goc TEXT or MTEXT!")
 (if (and (setq txt (ssget "_+.:E:S" '((0 . "*TEXT")))) (setq orp (getpoint "\nChon diem goc: ")))
  (progn (setq ent (entget (ssname txt 0))
               val (distof (cdr (assoc 1 ent)))
               poi (cdr (assoc 10 ent)))
         (or val
             (and (princ "\nKhong lay duoc gia tri cao do tu Text!")
                  (setq val (getreal "\nNhap gia tri cao do goc <0>: ")))
             (setq val 0))
         (if (setq npt (getpoint "\nDiem tiep theo: " orp))
          (progn (initget 6)
                 (or (setq n (getint "\nSo doi tuong can tao [1 or Enter de chon tung diem]: ")) (setq n 1))
                 (if (> n 1)
                  (repeat n (make_elev) (setq n (1- n)))
                  (progn (make_elev) (while (setq npt (getpoint "\nDiem tiep theo: " orp)) (make_elev))))))))
 (princ))

<<

Filename: 390985_csa%C2%A0.lsp
Tác giả: duongsatdn
Bài viết gốc: 15050
Tên lệnh: atd
Chương trình Hổ trợ cad 2004
Có gì mà khó nhỉ. Down từ Mega chỉ phiền là nhập mã số xong và chờ 45 giây thôi. Dùng IDM tốt!

Filename: 15050_atd.lsp

Trang 200/330

200