Jump to content
InfoFile
Tác giả: ketxu
Bài viết gốc: 321351
Tên lệnh: xx
Sắp xếp thẳng hàng

Bản thân ket nhiều khi muốn sắp xếp các nhóm đối tượng cho ngay ngắn theo hàng lối, thường toàn kẻ Xline để gióng (hoặc kết hợp F11) rồi move.  Thật kỳ lạ >"<

Trong khi đoạn code ngắn như thế này giúp tăng tốc bao nhiêu. Ý tưởng của ReachAndre trên Augi

 

P/s : Tự gióng theo khoảng cách gần nhất giữa Delta X và Delta Y nhé ^^

 

(defun...
>>

Bản thân ket nhiều khi muốn sắp xếp các nhóm đối tượng cho ngay ngắn theo hàng lối, thường toàn kẻ Xline để gióng (hoặc kết hợp F11) rồi move.  Thật kỳ lạ >"<

Trong khi đoạn code ngắn như thế này giúp tăng tốc bao nhiêu. Ý tưởng của ReachAndre trên Augi

 

P/s : Tự gióng theo khoảng cách gần nhất giữa Delta X và Delta Y nhé ^^

 

(defun c:xx (/ p pt d xd yd s)
(command "undo" "Mark")
(while (not (setq p (getpoint "\n\U+0110i\U+1EC3m chu\U+1EA9n :: "))))
(while
	(setq s (ssget))
		(while(not(setq pt (getpoint "\n\U+0110i\U+1EC3m gi\U+00F3ng :" p))))
		(setq 	xd (abs (- (car pt) (car p)))
				yd (abs (- (cadr pt) (cadr p)))
				d	(cond 	((> xd yd)(list (car pt) (cadr p) (caddr pt)))
							((< xd yd)(list (car p) (cadr pt) (caddr pt)))
					)
		)
		(command "_move" s "" "non" pt "non" d)
)
(command "undo" "end")
(princ)

https://www.youtube.com/watch?v=UKkXtIzMLS8


<<

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

- hi bạn thông cảm, sáng giờ bị sếp dí chưa kip sữa cho bạn ^^, giờ mới rãnh xem, bạn xem nhoc sữa vậy vừa ý chưa hì  :P

;===============================================================================================================
(defun K:style (MyStyle MyFont)
(entmake (list    (cons 0 "STYLE")    
(cons 100 "AcDbSymbolTableRecord")    
(cons 100 "AcDbTextStyleTableRecord")    
(cons 2 MyStyle)    (cons 3 ...
>>

- hi bạn thông cảm, sáng giờ bị sếp dí chưa kip sữa cho bạn ^^, giờ mới rãnh xem, bạn xem nhoc sữa vậy vừa ý chưa hì  :P

;===============================================================================================================
(defun K:style (MyStyle MyFont)
(entmake (list    (cons 0 "STYLE")    
(cons 100 "AcDbSymbolTableRecord")    
(cons 100 "AcDbTextStyleTableRecord")    
(cons 2 MyStyle)    (cons 3  MyFont)    
(cons 70 0))))
;;;;;
;============================
;;--------------------------------------
(defun K:layer (ten clr)
(if (null (tblsearch "LAYER" ten))
(entmakex (list 
               '(0 . "LAYER")
               '(100 . "AcDbSymbolTableRecord")
               '(100 . "AcDbLayerTableRecord")
			   '(70 . 0)
                (cons 2 ten)
                (cons 62 clr))
)
)
)
;;;;;;;;;;-------------------------------------------
;;;;;;;;;;;============================================================
(defun Makepline (listpoint closed Layer Linetype LTScale 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))
	'(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 MakeLine (PT1 PT2 Layer Linetype LTScale xdata)
	(entmakex (list '(0 . "LINE")
	(cons 8 (if Layer Layer (getvar "Clayer")))
	(cons 6 (if Linetype Linetype "bylayer"))
	(cons 48 (if LTScale LTScale 1))
	(cons 10 PT1)	(cons 11 PT2)
	(cons -3 (if xdata (list xdata) nil))))) 
;;;;;;--------------------------------------------------------------------------------------------
;ham tao text 2
(defun taotext (point height string justify layer textstyle mau / lst)
(setq lst (list '(0 . "TEXT")
                              (cons 10 point)
							  (cons 40 height)
							  (cons 1 string)
							  (cons 8 (if layer layer (getvar "clayer")))
							  (cons 7 (if textstyle textstyle (getvar 'textstyle)))
							  (cons 62 (if mau mau 256))
							  
			)
			justify (strcase justify))
		(cond   ((= justify "L") (setq Lst (append Lst (list (cons 72 0) (cons 11 point)))))
		        ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))
				((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))
				((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))
				)
	(entmakex Lst)
  );end mktext
;--------------------------------------
(alert "LSP xuat bang thong ke goc canh , lenh: KKP")
;;----------------------------------------------------------------------------------------------
(defun c:kkp(/ ss ename lst lstcanh lstgoc dem p1 p2 p3 d ang1 ang2 goc kdo dau i k m f j pt1 pt2 pt3 pt4 pt5 pt6 pt7 pt8 pt9 goc270 pt tt ll gg ptt pll pgg old canh kgoc)
  (vl-load-com)
  (setq old (getvar 'osmode))
  (setvar 'osmode 0)
  (if (null (tblsearch "style" "ARIAL-bang")) (K:style "ARIAL-bang" "arial.ttf"))
  (K:layer "bang-goccanh" 4)
  (prompt "chon PLine:")
  (setq ss (ssget "+.:E:S" '((0 . "*POLYLINE"))))
(if ss
(progn
;--------------------------------------------------------------------
  (setq ename (ssname ss 0))
  (setq lst (acet-geom-vertex-list ename))
  (setq lstcanh nil
	     lstgoc nil)
;================================================
  (setq p1 (car lst)
	dem 1)
;===============================================================
  (while (< dem  (length lst))
    (setq p2 (nth dem lst))
    (setq d (distance p1 p2))
    (setq lstcanh (append lstcanh (list d)))
    (setq p1 p2
	  dem (1+ dem))
    (princ)
    )
(setq bdau 1)
(foreach x lst
 (taotext (polar x (/ pi 2) 0.5) 0.8 (itoa bdau) "M" "bang-goccanh" "ARIAL-bang" 1)
 (setq bdau (1+ bdau))
 )
;==================================================================================
  (setq p1 (car lst)
	dem 1)
;===============================================================================
  (while (< dem  (1- (length lst)))
    (setq p2 (nth  dem lst))
    (setq p3 (nth  (1+ dem) lst))
    (setq ang1 (angle p2 p1)
	  ang2 (angle p2 p3))
    (setq goc (abs (- ang1 ang2)))
    (if (> goc PI)
      (setq goc (- (* 2 pi) goc))
      )
;================================================================================
    (setq kdo (* (/ goc pi) 180.0))
    (setq lstgoc (append lstgoc (list kdo)))
;====================================================================================
    (setq p1 p2
	  dem (1+ dem))
   )
;========================================================================================
(setq pt (getpoint "\nChon diem dat bang:"))
(if (/= pt nil)
(progn
(setq pt1 (mapcar '+ pt (list 45.0 0.0 0.0))
      pt2 (mapcar '+ pt (list 0.0 -4.0 0.0))
      pt3 (mapcar '+ pt (list 45.0 -4.0 0.0))
	  pt4 (mapcar '+ pt (list 5.0 0.0 0.0))
	  pt5 (mapcar '+ pt (list 25.0 0.0 0.0)))
;--------------------------------------------------
(taotext (mapcar '+ pt (list 2.5 -2.0 0.0)) 1.8 "TT" "M" "bang-goccanh" "ARIAL-bang" nil)
(taotext (mapcar '+ pt (list 15.0 -2.0 0.0)) 1.8 "L" "M" "bang-goccanh" "ARIAL-bang" nil)
(taotext (mapcar '+ pt (list 35.0 -2.0 0.0)) 1.8 "GOC" "M" "bang-goccanh" "ARIAL-bang" nil)
(makeline pt2 pt3 nil nil nil nil)
;-----------------------------------------------------
(setq i 1)
(while (<= i (length lst))
(progn
;--------------------------
(setq tt (list 2.5 (- (* -5.0 i) 2.0) 0.0))
(setq ptt (mapcar '+ pt tt))
;--------------------------------
;------------------------------
(taotext ptt 1.8 (itoa i) "M" nil nil 4)
(setq i (1+ i))
)
) ; end while
;===============================================
(setq k 0 m 1)
(repeat (- (length lst) 1)
(setq ll (list 15.0 (- (* -5.0 m) 4.5) 0.0))
(setq pll (mapcar '+ pt ll))
(setq canh (nth k lstcanh))
(taotext pll 1.8 (rtos canh 2 3) "M" "bang-goccanh" "ARIAL-bang" nil)
(setq m (1+ m))
(setq k (1+ k))
)
;==============================================
(setq f 0 j 1)
(repeat (- (length lst) 2)
(setq gg (list 35.0 (- (* -5.0 j) 7.0) 0.0))
(setq pgg (mapcar '+ pt gg))
(setq kgoc (nth f lstgoc))
(taotext pgg 1.8 (chuyendo kgoc) "M" "bang-goccanh" "ARIAL-bang" nil)
(setq f (1+ f))
(setq j (1+ j))
)
;----------------------------------------
(setq goc270 (- 0 (/ PI 2)))
(setq pt6 (polar pt goc270 (+ 4 (+ (* 5.0 (length lst)) 3.0)))
      pt7 (polar pt1 goc270 (+ 4 (+ (* 5.0 (length lst)) 3.0)))
	  pt8 (polar pt5 goc270 (+ 4 (+ (* 5.0 (length lst)) 3.0)))
	  pt9 (polar pt4 goc270 (+ 4 (+ (* 5.0 (length lst)) 3.0))))
(makeline pt4 pt9 nil nil nil nil)
(makeline pt5 pt8 nil nil nil nil)
(makepline (list pt pt1 pt7 pt6) 1 nil nil nil nil)
;=============================================
) ;end progn if
) ; end if pt
); end progn ss
(alert "ban chua chon Pline nao")
) ;end if ss	  
;========================================================================================
(alert "Xong ^^")
(setvar 'osmode old)
(princ)
); end Kkp
;===================================================================================
;========================chuyen sang do phut giay
(defun chuyendo(so / done kphgiay kphut kgiay xong)
(setq done (fix so))
(setq kphgiay (* (- so done) 60)) ;14,76
(setq kphut (fix kphgiay)) ; 14
(setq kgiay (rtos (* (- kphgiay kphut) 60) 2 0)) ;46"
(setq xong (strcat (itoa done) "%%d" (itoa kphut) "'" kgiay "''"))
)


<<

Filename: 321418_kkp.lsp
Tác giả: Tot77
Bài viết gốc: 321403
Tên lệnh: cpt
viết lisp copy nhảy cao độ tự động như hình vẽ kèm theo

Bạn thử cái này. muốn  bao nhiêu số lẻ thì trước khi chạy đánh luprec rồi cho số số lẻ.

(defun c:cpt (/ ss a b dis eg)
  (prompt "\nChon cac text:")
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "*TEXT"))))))
a (getpoint "\nTu diem:")
b (getpoint a  "\nDen diem:")
dis (distance a b)
  )
  (setvar 'cmdecho 0)
  (princ (strcat "\nKhoang cach " (rtos dis)))
  (foreach v ss
   ...
>>

Bạn thử cái này. muốn  bao nhiêu số lẻ thì trước khi chạy đánh luprec rồi cho số số lẻ.

(defun c:cpt (/ ss a b dis eg)
  (prompt "\nChon cac text:")
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "*TEXT"))))))
a (getpoint "\nTu diem:")
b (getpoint a  "\nDen diem:")
dis (distance a b)
  )
  (setvar 'cmdecho 0)
  (princ (strcat "\nKhoang cach " (rtos dis)))
  (foreach v ss
    (command "copy" v "" "non" a "non" b)
    (setq  eg (entget (entlast)))
    (entmod (subst (cons 1 (rtos (+ dis (atof (cdr (assoc 1 eg)))))) (assoc 1 eg) eg))
  )
  (setvar 'cmdecho 1) (princ)
)

<<

Filename: 321403_cpt.lsp
Tác giả: nhoclangbat
Bài viết gốc: 321473
Tên lệnh: dmd
sửa lisp đổi màu đối tượng

- nhoc thì ko rành về dim, viết lsp đơn giản nhưng cũng hơi thủ công bạn xem thừ ^^

p/s: up hộ bạn ^^

(defun c:dmd(/ mau kdim)
(vl-load-com)
(setvar 'cmdecho 0)
(setq mau (getint "\nNh\U+1EADp m\U+00E3 m\U+00E0u mu\U+1ED1n \U+0111\U+1ED5i:"))
(setq kdim (entget (car (nentsel "\nCh\U+1ECDn \U+0111\U+00FAng text dim:"))))
(entmod (subst (cons 62 mau) (assoc 62 kdim) kdim))
(vl-cmdf "regen")
(setvar 'cmdecho...
>>

- nhoc thì ko rành về dim, viết lsp đơn giản nhưng cũng hơi thủ công bạn xem thừ ^^

p/s: up hộ bạn ^^

(defun c:dmd(/ mau kdim)
(vl-load-com)
(setvar 'cmdecho 0)
(setq mau (getint "\nNh\U+1EADp m\U+00E3 m\U+00E0u mu\U+1ED1n \U+0111\U+1ED5i:"))
(setq kdim (entget (car (nentsel "\nCh\U+1ECDn \U+0111\U+00FAng text dim:"))))
(entmod (subst (cons 62 mau) (assoc 62 kdim) kdim))
(vl-cmdf "regen")
(setvar 'cmdecho 1)
(princ)
)

 


<<

Filename: 321473_dmd.lsp
Tác giả: trinhhoanghieu090
Bài viết gốc: 321478
Tên lệnh: vd1
https://twitter.com/Healty_Pills

Thầy ketxu ơi, em không phải dân cơ khí nên mấy cái công thức tính khối lượng sau đây đành bó tay, thầy cho giúp công thức với, phải biết công thức mới viết code được chứ

 

d. Tạo hàm tính khối lượng một thanh thép tròn biết KLR 7850 kg/m3, chiều dài 1 thanh 11,7 m, đối số là đường kính thép

e. Tạo hàm tính khối lượng thanh thép hộp hình vuông...
>>

Thầy ketxu ơi, em không phải dân cơ khí nên mấy cái công thức tính khối lượng sau đây đành bó tay, thầy cho giúp công thức với, phải biết công thức mới viết code được chứ

 

d. Tạo hàm tính khối lượng một thanh thép tròn biết KLR 7850 kg/m3, chiều dài 1 thanh 11,7 m, đối số là đường kính thép

e. Tạo hàm tính khối lượng thanh thép hộp hình vuông với 2 đối số : chiều dài cạnh (ngoài) và bề dày. KLR và chiều dài lấy như trên

f. Tạo hàm tính khối lượng thanh thép hộp hình vuông với 2 đối số : chiều dài cạnh (ngoài) và chiều dài cạnh trong. KLR và chiều dài lấy như trên.Tái sử dụng hàm e

trong ví dụ:

;Vi du 1
;Tinh trung binh cong 2 so nguyen nhap vao
(defun c:vd1(/ a b)
  (setq a (getint "\n Nhap so a:" ) )
  (setq b (getint "\n Nhap so b:" ) )
  ( trungbinhcong a b )
)
;Ham tinh so trung binh cong 2 so
;Doi so:
;	x: integer hoac real
;	y: integer hoac real
; 	tra ve : gia tri trung binh cong 2 so nay
( defun trungbinhcong (x y)
( * (+ x y) 0.5 )
)

Số lượng a, b và x, y có bắt buộc phải bằng nhau không?  ví dụ mình nhập vào 3 đối số a, b, c mà chỉ có 2 biến x, y hoặc ngược lại chỉ có 2 đối số a,b mà có tận 3 biến x, y, z thi se the nao

Và khái niệm biến cục bộ, biến toàn cục là chỉ đúng cho trong nội bộ 1 file autolisp chứa chương trình đó chứ, trong bài là vidu1.lsp? còn khi mình có nhiều file autolisp khác nhau, có thể tên biến toàn cục giống nhau thì sao, điều trên còn đúng nữa không (ví dụ khi chạy file a.lsp giá trị biến toàn cục x= 3, sau đó  gọi lệnh trong file b.lsp cũng có biến toàn cục x, lúc đó giá trị x còn bằng 3 nữa không?

 

Khi em sửa lại lsp như thế này thì vẫn chạy bình thường, cách viết như thế này có nên không vì khi viết lsp mà khai nhiều tên đối số, biến quá thì sẽ rất khó nhớ. Ẹm là chúa hay quên :unsure:

;Vi du 1
;Tinh trung binh cong 2 so nguyen nhap vao
(defun c:vd1(/ a b)
  (setq a (getint "\n Nhap so a:" ) )
  (setq b (getint "\n Nhap so b:" ) )
  ( trungbinhcong a b )
)
;Ham tinh so trung binh cong 2 so
;Doi so:
;	a: integer hoac real
;	b: integer hoac real
; 	tra ve : gia tri trung binh cong 2 so nay
( defun trungbinhcong (a b)
( * (+ a b) 0.5 )
)

<<

Filename: 321478_vd1.lsp
Tác giả: Tot77
Bài viết gốc: 321474
Tên lệnh: cl ck
sửa lisp đổi màu đối tượng

Lsp của nhoc phải nhấp ngay cái dimtext thì nó mới làm.

Sửa cái lsp của chủ thớt.

(defun changecolor (en col)
  (if (= (cdr (assoc 0 (entget en))) "DIMENSION")
    (vlax-for item (vla-item (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object)))
  (cdr (assoc 2 (entget en))))
      (if (= "AcDbMText" (vla-get-ObjectName item)) (vla-put-Color item col))
    )
    (command "change" en "" "P" "c"...
>>

Lsp của nhoc phải nhấp ngay cái dimtext thì nó mới làm.

Sửa cái lsp của chủ thớt.

(defun changecolor (en col)
  (if (= (cdr (assoc 0 (entget en))) "DIMENSION")
    (vlax-for item (vla-item (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object)))
  (cdr (assoc 2 (entget en))))
      (if (= "AcDbMText" (vla-get-ObjectName item)) (vla-put-Color item col))
    )
    (command "change" en "" "P" "c" col "")
  )
)
 
(defun c:cl (/ m ss)
  (command "undo" "be") (setvar 'cmdecho 0)
  (princ "\nChon doi tuong muon doi mau:")
  (setq ss (ssget))
  (princ "\nChon mau muon doi :") (setq m (acad_colordlg 7))
  (mapcar '(lambda (x) (changecolor x m)) (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
  (vl-cmdf "regen")
  (command "undo" "end") (setvar 'cmdecho 1)
  (setvar "MODEMACRO" "**KTS_DUY**")
  (princ)
)
 
(defun c:ck (/ m ss)
  (command "undo" "be") (setvar 'cmdecho 0)
  (princ "\nChon doi tuong muon doi mau:")
  (setq ss (ssget))
  (setq m (getint "\nChon mau muon doi: "))
  (mapcar '(lambda (x) (changecolor x m)) (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
  (vl-cmdf "regen")  
  (command "undo" "end") (setvar 'cmdecho 1)
  (setvar "MODEMACRO" "**KTS_DUY**")
  (princ)
)
 

<<

Filename: 321474_cl_ck.lsp
Tác giả: Tot77
Bài viết gốc: 321588
Tên lệnh: cpt
viết lisp copy nhảy cao độ tự động như hình vẽ kèm theo

Vòng lặp đây, muốn dứt thì enter.

(defun c:cpt (/ ss a b dis eg)
  (princ (strcat "\nHien tai la " (itoa (getvar 'luprec)) " so le."))
  (prompt "\nChon cac text:")
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "*TEXT"))))))
a (getpoint "\nTu diem:")
  )
  (setvar 'cmdecho 0)
  
  (while (setq b (getpoint a  "\nDen diem "))
    (setq dis (distance a b))
    (princ (strcat "cach " (rtos dis)))
 ...
>>

Vòng lặp đây, muốn dứt thì enter.

(defun c:cpt (/ ss a b dis eg)
  (princ (strcat "\nHien tai la " (itoa (getvar 'luprec)) " so le."))
  (prompt "\nChon cac text:")
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "*TEXT"))))))
a (getpoint "\nTu diem:")
  )
  (setvar 'cmdecho 0)
  
  (while (setq b (getpoint a  "\nDen diem "))
    (setq dis (distance a b))
    (princ (strcat "cach " (rtos dis)))
    (foreach v ss
      (command "copy" v "" "non" a "non" b)
      (setq  eg (entget (entlast)))
      (entmod (subst (cons 1 (rtos (+ dis (atof (cdr (assoc 1 eg)))))) (assoc 1 eg) eg))
    )
  )
  (setvar 'cmdecho 1) (princ)
)

<<

Filename: 321588_cpt.lsp
Tác giả: ketxu
Bài viết gốc: 321571
Tên lệnh: vct
Chương 6 : Bài Tập

Đa số các bạn viết code rất rối, đến lúc phải sửa lỗi rất mệt. Cố gắng tập thói quen viết hàm để vừa tận dụng, vừa dễ dàng biết sai ở đâu để sửa lỗi riêng từng hàm

Ví dụ bài trên, mình đã cố tình đặt bài tập viết chuỗi text trước để mọi người tái sử dụng trong bài 8, nhưng k thấy ai làm :)

 

Đây là 1 form mẫu cho bạn tham khảo :

>>

Đa số các bạn viết code rất rối, đến lúc phải sửa lỗi rất mệt. Cố gắng tập thói quen viết hàm để vừa tận dụng, vừa dễ dàng biết sai ở đâu để sửa lỗi riêng từng hàm

Ví dụ bài trên, mình đã cố tình đặt bài tập viết chuỗi text trước để mọi người tái sử dụng trong bài 8, nhưng k thấy ai làm :)

 

Đây là 1 form mẫu cho bạn tham khảo :

(defun c:vct( / ) ;/ ......
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;===================== Khu vuc ham tu tao =============================;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Tao list point can ve tu P goc, kich thuoc w h, so bac n
(defun _pL(p w h n / l p1)
	(setq l (list p))
	(repeat n
			(setq 	p1 	(mapcar '+ p (list 0 h 0)) 
					p 	(mapcar '+ p (list w h 0))
					l 	(append l (list p1 p))
			)
	)
)
;Ham ve	cau thang tu list point lay o _pL	
(defun _mCT(l)(apply 'command (append (list "Pline") l (list ""))))

;Tao list point can viet chu tu list point ve bac lay o _pL
(defun _tL(l / rt)
	(setq i -1)
	(repeat (/ (length l) 2)
			(setq rt (append rt (list (nth (setq i (+ i 2)) l))))
	)
rt
)
;Ham danh so tu chieu cao chu, list point lay o _tL
(defun _mT(h l / i)
	(setq i 0)
	(mapcar '(lambda(p)(command "text" p h 0 (rtos (setq i (1+ i)) 2 0))) l)
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;===================== Khu vuc lenh chinh =============================;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

	;Thiet dat bien he thong
	; Hoi nguoi dung co muon danh so hay khong, dat vao bien isT?, gia su chieu cao chu = h/2
	; Hoi nguoi dung chon method nao
	;1 : Kich thuoc + so bac :
	;	+ Get w h n, hText lay bang 1/4	
	;2 : Be rong bac, so bac, chieu cao nha :
	;	+ Get 	w, n
	;			h = chieu cao nha / so bac
	;3 : So bac, goc nghieng thang, chieu cao nha
	;	+ Get 	n
	;			h = chieu cao nha / so bac
	;			w = h/tan
	;Cuoi cung moi ve va viet chu :
	;	(_mCT (setq l (_pL (getpoint "\nPick:") w h n)))
	; 	(if isT? (_mT h/2 (_tL l)))
)

 

P/s : bài trên luuhavinh sai cả cách dùng cond nữa.


<<

Filename: 321571_vct.lsp
Tác giả: haanh
Bài viết gốc: 321636
Tên lệnh: fpoptions pipeline pipedim trimheads exportshc importshc
LISP VẼ ĐƯỜNG ỐNG 3D trên AutoCAD

1.Về ve.lsp

Nói chung hiepttr đã tạo sẵn cái khung lsp rồi, tôi chỉ có thêm mắm muối cho xôm tụ thôi. Còn tại sao có dòng ĐK dài lê thê là vì khi mới thử lsp của hiepttr, vì là dân "ngoại đạo" với các loại ông nên nó cứ báo sai số liệu đòi nhập lại hoài, ghét quá mới thêm cái đó vào cho dễ chọn thội....

>>

1.Về ve.lsp

Nói chung hiepttr đã tạo sẵn cái khung lsp rồi, tôi chỉ có thêm mắm muối cho xôm tụ thôi. Còn tại sao có dòng ĐK dài lê thê là vì khi mới thử lsp của hiepttr, vì là dân "ngoại đạo" với các loại ông nên nó cứ báo sai số liệu đòi nhập lại hoài, ghét quá mới thêm cái đó vào cho dễ chọn thội. Chứ chắc dận "nôi đạo" như haanh thì chẳng cần, nhắm mắt cũng biết ống fi mấy rồi.

2. Về tko_tkc

haanh thích union cũng chẳng có gì, chọn hết 1 loại ống trong bản vẽ rồi union nó lại.Dĩ nhiên khi đó thống kê trên toàn bộ bản vẽ chứ không phải 1 nhóm.

3. Cadviet dạo này cũng có ma rồi sao?  :o  :o

Mấy hôm rày bận việc quá , em không vào diễn đàn được.... Em cảm ơn bác Tot77 rất vô cùng nhiều vì bác đã viết lisp "CKC" bắn  trúng yêu cầu của em! :) :) :)

Nếu ví việc vẽ đường ống trên AutoCAD giống như việc gặt lúa thì việc bác đã cho thêm gia vị mắm muối tương gừng ớt xả vào để Em_lisp của anh Hiệp trở thành máy gặt đập liên hợp chính  là " niềm ao ước bấy lâu nay đã thỏa nỗi chờ mong"  , bác Tot77 ạ!

Bác không phải lăn tăn gì về việc em đã viết:"VE.Lisp của bác rất hoành tráng khi hiện ra hình một dãy chữ số chỉ đường kính ống trên dòng Command hiền hòa và thơ mộng!" nhé. Vì các loại ống theo tiêu chuẩn Đức, Nhật Bản và Đài Loan có nhiều loại đường kính khác nhau, mà trí nhớ của con người có hạn....dành để nhớ nhiều cái đáng nhớ hơn là  việc phải nhớ ống DN50 có đường kính là Ø bao nhiêu, bác ạ!

 

Em đang nghĩ cách diễn đạt rõ ràng và dễ hiểu để nhờ các bác viết giúp em ít nhất là hai Em_lip nữa,  sao cho công hữu ích bị tổn thất không được vượt quá   giới hạn ức chế cho phép ≤

Đây là lisp vẽ đường ống,  em mới sưu tầm được, gửi lên đây để bác nào rảnh sẽ tham khảo và tìm hiểu trước, em sẽ nhờ các bác sau:

 

;The contents of this file are subject to the Mozilla Public License
;Version 1.1 (the "License"); you may not use this file except in compliance
;with the License. You may obtain a copy of the License at
;http://www.mozilla.org/MPL/
;
;Software distributed under the License is distributed on an "AS IS" basis,
;WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
;the specific language governing rights and limitations under the License.
;
;The Original Code is: igneus.lsp
;This file is Copyright (c) 2006 Igneus Incorporated

;------------------------------------------------------------------------------
; The Igneus Incorporated Cad Utilities Collection
;
; History:
;     0.7.0 : April 24, 2006
;           : Initial public release
;
;     0.7.1 : October 12, 2006
;           : Metric support
;
; Commands added to CAD program
; -----------------------------
;
;           fpOptions       : set options for other commands
;           Pipedim         : draws size and length text for a line(s)
;           PipeLine        : A 'line' command with pipe dimensioning
;           TrimHeads       : Trim lines to edge of heads - don't use before
;                             ExportSHC.
;           ExportSHC       : produces a TSHC readable file from cad drawing
;           ImportSHC       : inputs a previously exported file and changes
;                           : pipe sizes accordingly
;
;------------------------------------------------------------------------------

;;;
;;;  FpOptions
;;;
;;;  Description
;;;  -----------
;;;  Sets options used by cad utilities collections and saves to
;;;  file.
;;;

(defun c:fpoptions( / s)
  ; Call initialization function
  (igneus_init)
  ; get tolerance
  (if (<= 0 (setq s (getreal (strcat "\nSet endpoint tolerance <" (rtos igneus_tolerance) ">:")))) (setq igneus_tolerance s))
  ; get branchline layer
  (setq igneus_BranchLayer (igneus_getLayName (strcat "Branchline piping layer <" igneus_BranchLayer ">:") igneus_BranchLayer))
  ; get main piping layer
  (setq igneus_MainLayer (igneus_getLayName (strcat "Main piping layer <" igneus_MainLayer ">:") igneus_MainLayer))
  ; get sprinkler head layer
  (setq igneus_HeadLayer (igneus_getLayName (strcat "Sprinkler head layer <" igneus_HeadLayer ">:") igneus_HeadLayer))
  ; get pipe dimensioning layer
  (setq igneus_PipeDimLayer (igneus_getLayName (strcat "Pipe dimensioning layer <" igneus_PipeDimLayer ">:") igneus_PipeDimLayer))
  ; get node label layer
  (setq igneus_NodeDimLayer (igneus_getLayName (strcat "Node labeling layer <" igneus_NodeDimLayer ">:") igneus_NodeDimLayer))
  ; select drawing units
  (setq igneus_BaseUnit (igneus_getintD (strcat "\nA length of 1.0 in the drawing is a - 1)Inch  2)Foot  3)Millimeter  4)Meter  <" (itoa igneus_baseUnit) ">:") igneus_baseUnit))
  ; Foot or inch base unit always results in Foot-Inch pipe length dimensioning
  (if (< igneus_BaseUnit 3)
    (progn
      ; get additional information for foot-inch dimensioning
      (setq igneus_LengthDimUnit 1)
      ; get 1/4 characters
      (setq igneus_oneQuarter (igneus_getstringD (strcat "Enter characters to use for '1/4' <" igneus_oneQuarter ">:") igneus_oneQuarter T))
      ; get 1/2 characters
      (setq igneus_oneHalf (igneus_getstringD (strcat "Enter characters to use for '1/2' <" igneus_oneHalf ">:") igneus_oneHalf T))
      ; get 3/4 characters
      (setq igneus_threeQuarter (igneus_getstringD (strcat "Enter characters to use for '3/4' <" igneus_threeQuarter ">:") igneus_threeQuarter T))
      ; get foot inch seperator
      (setq igneus_footchar (igneus_getstringD (strcat "Enter foot inch seperator character <" igneus_footchar ">:") igneus_footchar nil))
    )
    (progn
      ; select metric unit for length dimensioning
      (if (= 1 igneus_LengthDimUnit) (setq igneus_LengthDimUnit 2))
      (setq igneus_LengthDimUnit (igneus_getintD (strcat "\nDimension pipe lengths as - 2)Millimeter  3)Meter <" (itoa igneus_LengthDimUnit) ">:") igneus_LengthDimUnit))
    )
  )
  ; write options to "igneus.ini"
  (setq s (open "igneus.cfg" "w"))
  (write-line ";;; Igneus Cad Utilities configuration file" s)
  (write-line (strcat "(setq igneus_tolerance " (rtos igneus_tolerance 2 2) ")") s)
  (write-line (strcat "(setq igneus_BranchLayer \"" igneus_BranchLayer "\")") s)
  (write-line (strcat "(setq igneus_MainLayer \"" igneus_MainLayer "\")") s)
  (write-line (strcat "(setq igneus_HeadLayer \"" igneus_HeadLayer "\")") s)
  (write-line (strcat "(setq igneus_PipeDimLayer \"" igneus_PipeDimLayer "\")") s)
  (write-line (strcat "(setq igneus_NodeDimLayer \"" igneus_NodeDimLayer "\")") s)
  (write-line (strcat "(setq igneus_oneQuarter \"" igneus_oneQuarter "\")") s)
  (write-line (strcat "(setq igneus_oneHalf \"" igneus_oneHalf "\")") s)
  (write-line (strcat "(setq igneus_threeQuarter \"" igneus_threeQuarter "\")") s)
  (write-line (strcat "(setq igneus_footchar \"" igneus_footchar "\")") s)
  (write-line (strcat "(setq igneus_curPipeSize " (rtos igneus_curPipeSize 2 2) ")") s)
  (write-line (strcat "(setq igneus_BaseUnit " (itoa igneus_baseUnit) ")") s)
  (write-line (strcat "(setq igneus_LengthDimUnit " (itoa igneus_LengthDimUnit) ")") s)
  (close s)
  (igneus_end)
)

;;;
;;; PipeLine
;;;
;;; Description
;;; -----------
;;; Behaves as a LINE command but places lines in the branch line piping layer
;;; and dimensions each line using the chosen pipe size
;;;

(defun c:pipeline( / pt lastPt )
  ; Initialize
  (igneus_init)
  ; get pipe size
  (if (setq s (getreal (strcat "\nEnter pipe size <" (rtos igneus_curPipeSize 2 2) ">:")))
    (setq igneus_curPipeSize s))
  ; get starting point
  (if (setq lastPt (getpoint "\nSelect starting point of pipe:"))
    (while (setq pt (getpoint lastPt "\nselect end of pipe piece:"))
      (progn
        (if  (entmake (list (cons 0 '"LINE") (cons 8 igneus_branchLayer) (append '(10) lastPt) (append '(11) pt)))
          (pipedim_entity (entlast) igneus_curPipeSize igneus_footChar))
        (setq lastPt pt))))
  (igneus_end)
)

;;;
;;;  PipeDim
;;;
;;;  Description
;;;  -----------
;;;  PIPEDIM creates length and size dimension text for each pipe selected.
;;;

(defun c:pipedim( / pipedim_ss j)
  ; Call initialization function
  (igneus_init)
  ; get pipe size to use
  (if (null igneus_curPipeSize) (setq igneus_curPipeSize 1.0))
  (setq j igneus_curPipeSize)
  (if (null (setq igneus_curPipeSize (getReal (strcat '"Enter pipe size <" (rtos igneus_curPipeSize 2 2) '">:"))))
    (setq igneus_curPipeSize j))
  ; Let the use select the pipe to dimension
  (princ "\nSelect pipe to dimension")
  (setq pipedim_ss (ssget))

  ;;; Dimension each line in the selection set
  (setq j 0)
  (while (< j (ssLength pipedim_ss))
    (if (= '"LINE" (cdr (assoc 0 (entget (ssname pipedim_ss j)))))
      (pipedim_entity (ssname pipedim_ss j) igneus_curPipeSize igneus_footchar))
    (setq j (+ j 1)) )
  (igneus_end)
)

;;;
;;;  TrimHeads
;;;
;;;  Description
;;;  -----------
;;;  Trims all pipe in the branchline and main layers against all
;;;  blocks in the sprinkler head layer.  This is not a true trim
;;; but sets endpoints of lines within the tolerance value to a
;;; block to the radius distance away from the center of the block
;;;

(defun c:TrimHeads( / tolerance trimRadius ssHeads ssPipe iHead iPipe eHead ePipe newX newY)
  ; Call initialization function
  (igneus_init)
  ; get sprinkler head block names
  (if (= "" (setq bNames (getstring "\nEnter sprinkler head block name(s) to trim against:"))) (quit))
  ; get trimming radius
  (while (= nil (setq trimRadius (getReal "\nEnter trimming radius:"))))
  ; create sprinkler head selection set
  (if (= nil (setq ssHeads (ssget "X" (list (cons 0 "INSERT") (cons 2 bNames)))))
    (progn
      (princ "\nNo sprinkler head blocks found.")
      (quit)))
  ; creat pipe selection set
  (if (= nil (setq ssPipe (ssget "X" (list (cons 0 "LINE") (cons 8 (strcat igneus_mainLayer "," igneus_branchLayer))))))
    (progn
      (princ (strcat "\nNo pipe found in layers " igneus_mainLayer " or " igneus_branchLayer))
      (quit)))
  ; cycle through each pipe with each head and trim if necessary
  (setq iHead 0)
  (while (< iHead (ssLength ssHeads))
    (setq eHead (entget (ssName ssHeads iHead)))
    (setq iPipe 0)
    (while (< iPipe (ssLength ssPipe))
      (setq ePipe (entget (ssName ssPipe iPipe)))
      ; check for line start point within head radius
      (if (>= igneus_tolerance (distance (cdr (assoc 10 ePipe)) (cdr (assoc 10 eHead))))
        (progn
          ; trim the line from start point
          (setq pAngle (angle (cdr (assoc 10 eHead)) (cdr (assoc 11 ePipe))))
          (setq newX (+ (cadr (assoc 10 eHead)) (* trimRadius (cos pAngle))))
          (setq newY (+ (caddr (assoc 10 eHead)) (* trimRadius (sin pAngle))))
          ; modify the line
          (entmod (subst (list 10 newX newY (last (assoc 10 ePipe))) (assoc 10 ePipe) ePipe))))
      ; check for line end point within head radius
      (if (>= igneus_tolerance (distance (cdr (assoc 11 ePipe)) (cdr (assoc 10 eHead))))
        (progn
          ; trim the line from end point
          (setq pAngle (angle (cdr (assoc 10 eHead)) (cdr (assoc 10 ePipe))))
          (setq newX (+ (cadr (assoc 10 eHead)) (* trimRadius (cos pAngle))))
          (setq newY (+ (caddr (assoc 10 eHead)) (* trimRadius (sin pAngle))))
          ; modify the line
          (entmod (subst (list 11 newX newY (last (assoc 11 ePipe))) (assoc 11 ePipe) ePipe))))
      (setq iPipe (1+ iPipe)))
    (setq iHead (1+ iHead)))
  (igneus_end)
)
 
;;;
;;;  ExportSHC
;;;
;;;  Description
;;;  -----------
;;;  Exports user selected pipe and flowing heads as a compatible
;;;  file for 'The Simple Hydraulic Calculator' computer program.
;;;
;;;  Limitations
;;;  -----------
;;;  This command does not attempt to place fitting codes in the resulting
;;;  file.  Nor does this command set pipe types or define a water source
;;;  In other words - the file will nead some editing in TSHC before it will
;;;  calc.  Still - it's a good time saver.
;;;

(defun c:exportSHC( / igneus_tolerance head_ss pipe_ss pipe_list node_list label_list command_list used_list head_count head_list fName j k x y newCommand)
  (igneus_init)        ; Call initialization function
  (princ '"\nSelect pipe to export")
  (if (null (setq pipe_ss (ssget))) (progn
                                      (*error* '"No pipe was selected")
                                      (quit)))                                    
  ; get flowing heads (nil set is acceptable)
  (princ '"\nSelect flowing sprinkler heads")
  (setq head_ss (ssget))

  (setq node_list nil)
  (setq head_k -1)
  (setq head_q -1)

  ; cycle through all pipe selected
  ; for each line, add endpoints to node_list unless the endpoint already exists
  (setq j 0)
  (while (< j (sslength pipe_ss))
    (progn
      ; get entity data
      (setq k (entget (ssname pipe_ss j)))
      (setq j (+ 1 j))
      ; if its a line, add point to node_list (closer points first, farther second)
      (if (= '"LINE" (cdr (assoc 0 k)))
        (progn
          (if (> (distance '(0 0 0) (cdr (assoc 10 k))) (distance '(0 0 0) (cdr (assoc 11 k))))
            (setq x (cdr (assoc 11 k)) y (cdr (assoc 10 k)))
            (setq x (cdr (assoc 10 k)) y (cdr (assoc 11 k))))
          (if (null (member x node_list))
            (setq node_list (append node_list (list x))))
          (if (null (member y node_list))
            (setq node_list (append node_list (list y))))
  ))))
  ; search head selection set for sprinkler heads
  (setq head_count 0)
  (if (/= head_ss nil)
    (progn
      ; get minimum discharge and k-factor
      (while (<= head_k 0)
        (if (null (setq head_k (getreal '"Enter k-factor for sprinkler heads <5.6>:")))   ;;; change to 80.6 metric users
          (setq head_k 5.6)))
      (while (<= head_q 0)
        (if (null (setq head_q (getreal '"Enter minimum flow reaquired for a head <14.82>:"))) ;;; change to 57.0 metric users
          (setq head_q 14.82)))
      ;  Now add head points to node list
      (setq j 0)
      (while (< j (sslength head_ss))
        (progn
          ; get the entity data
          (setq k (entget (ssname head_ss j)))
          ; if its a block, add its point to the list
          (if (= '"INSERT" (cdr (assoc 0 k)))
            (progn
              (setq node_list (append node_list (list (cdr (assoc 10 k)))))
              (setq head_count (1+ head_count)) ))
          ; increment j
          (setq j (+ 1 j))
  ))))
  ; Now make a label list for the nodes
  ; Start numbering at 100
  (setq next_label '101)
  (setq label_list (list '100))
  (setq j 1)
  (while (< j (length node_list))
    (progn
      ; compare current point with previous points
      (setq k 0)
      (while (< k j)
        (if (< igneus_tolerance (abs (distance (nth k node_list) (nth j node_list))))
          ;then
          (setq k (1+ k))
          ;else
          (progn
            ; points fall within tolerance so represent same node
            (setq label_list (append label_list (list (nth k label_list))))
            (setq k j)
      )))
      ;; if label list is too short then a duplicate was not found - add next label to list
      (if (= j (length label_list))
        (progn
          (setq label_list (append label_list (list next_label)))
          (setq next_label (1+ next_label))
      ))
      (setq j (1+ j))
  ))

  ; create a head label list so we know when we need a head command instead of node
  (setq head_list nil)
  (setq j (- (length label_list) head_count))
  (while (< j (length label_list))
    (progn
      (setq head_list (append head_list (list (nth j label_list))))
      (setq j (1+ j)) ))

  ; make a TSHC version 1.2 file header
  (setq command_list (list '"<TSHC 1 2>" '"<BODY>" '"// Pipe generated by exportshc command" '""))
  ; Now we can make pipe commands!
  (setq command_list (append command_list (list '"Use s40 120")))
  (setq next_label 100)
  (setq j 0)
  (while (< j (sslength pipe_ss))
    (progn
      ; get entity data
      (setq k (entget (ssname pipe_ss j)))
      ; if its a line, add pipe command to command list
      (if (= '"LINE" (cdr (assoc 0 k)))
        (progn
          ; get pipe size and length from dimension text if it exists
          (setq y (igneus_getPipeSizeLength (ssname pipe_ss j)))
          (setq x (car y))
          (if (= nil x)
            (if (= 1 igneus_LengthDimUnit) (setq x "1.00") (setq x "25")))
          (setq y (cadr y))
          (if (= nil y)
            (progn            
              (setq y (igneus_rtos (distance (cdr (assoc 10 k)) (cdr (assoc 11 k))) '"'"))
              ; convert fraction characters to decimals for TSHC
              (setq y (igneus_subststr ".25" igneus_onequarter y))
              (setq y (igneus_subststr ".5" igneus_onehalf y))
              (setq y (igneus_subststr ".75" igneus_threequarter y))
              ; convert mm length to m for TSHC
              (if (= 2 igneus_lengthDimUnit) (setq y (rtos (/ (atof y) 1000.0) 2 3)))))
          (setq newCommand
            (strcat '"Pipe "
                      (itoa next_label)     ; pipe name
                    '" "                ; start node
                    (itoa (nth (- (length node_list) (length (member (cdr (assoc 10 k)) node_list))) label_list))
                    '" "                ; end node
                    (itoa (nth (- (length node_list) (length (member (cdr (assoc 11 k)) node_list))) label_list))
                    '" " y))            ; length
          ; extra spaces        
          (while (> 26 (strlen newCommand)) (setq newCommand (strcat newCommand " ")))
          ; pipe size
          (setq newCommand (strcat newCommand '" " x '" "))
          ; extra spaces
          (while (> 45 (strlen newCommand)) (setq newCommand (strcat newCommand " ")))
          ; entity name in comment
          (setq newCommand (strcat newCommand "// $" (cdr (assoc 5 k))))
          (setq command_list (append command_list (list newCommand)))
          (setq next_label (1+ next_label))))
      (setq j (+ 1 j))

  ))
  ;  Now for the node commands
  (setq command_list (append command_list (list '"" '"// Nodes generated by exportshc command" '"")))
  (setq j 0)
  (setq used_list nil)
  (while (< j (length node_list))
    (progn
      (if (not (member (nth j label_list) used_list))
        (progn
          ; First label node in drawing
          (entmake (list
                     (cons 0 '"TEXT")
                     (cons 1 (strcat '"<" (itoa (nth j label_list)) '">"))
                     (cons 7 (getvar "TEXTSTYLE"))
                     (cons 8 igneus_nodeDimLayer) ;(getvar "CLAYER"))
                     (list 10 (car (nth j node_list))
                              (cadr (nth j node_list))
                              (caddr (nth j node_list)))
                     (list 11 (car (nth j node_list))
                              (cadr (nth j node_list))
                              (caddr (nth j node_list)))
                     (cons 40 (* (getvar "DIMSCALE") (getvar "DIMTXT")))
                     (cons 41 0.75)
                     (cons 50 0.0)
                     (cons 72 4)))
          ; now the command
          (setq used_list (append used_list (list (nth j label_list))))
          (if (member (nth j label_list) head_list)
              ; make a head command
            (setq command_list (append command_list (list (strcat '"Head "
                                                                  (itoa (nth j label_list)) '" "
                                                                  (igneus_rtos (caddr (nth j node_list)) '"'") '" "
                                                                  (rtos head_q 2 2) '" "
                                                                  (rtos head_k 2 2)))))
            ; make a node command
            (setq command_list (append command_list (list (strcat '"Node "
                                                                  (itoa (nth j label_list)) '" "
                                                                  (igneus_rtos (caddr (nth j node_list)) '"'")))))
      )))
      (setq j (1+ j))
  ))
  ; Get the filename
  (setq fName '"")
  (while (= fName '"") (setq fName (getfiled "Save As ..." "export.shc" "SHC" 1)))
  ; Open the file and write it
  (setq k (open fName "w"))
  (setq j 0)
  (while (< j (length command_list))
    (progn
      (write-line (nth j command_list) k)
      (setq j (1+ j))))
  (setq k (close k))
  (igneus_end)
)

;;;
;;; ImportSHC
;;;
;;; Reads a previously exported .shc file and dims the
;;; pipe in the drawing according to the size values in
;;; the .shc file.
;;;

(defun c:importSHC( / fName s comList )
  (igneus_init)
  ; Get the filename
  (setq fName '"")
  (setq s '"")
  (if (setq fName (getfiled "Import file ..." "" "SHC" 2))
  ; Open the file and read it
    (if (setq k (open fName "r"))
      (progn
        ; get to command section of file : <BODY> tag
        (while (and (/= nil s) (/= s "<BODY>")) (setq s (read-line k)))
        ; read until eof
        (while (/= nil s)
          (progn
            ; check for Pipe command
            (setq comList nil)
            (if (setq s (read-line k))            
              (setq comList (igneus_strToTokens s)))
            (if (/= nil comList)
              (if (= (strcase (car comList)) "PIPE")
                (progn
                      ; found a pipe, get size
                  (setq pSize (atof (nth 5 comList)))
                  ; entity handle should be last token
                  (setq hPipe (car (reverse comList)))
                  ; if first char is not $ then this is not a linked pipe
                  (if (= (substr hPipe 1 1) "$")
                    (progn
                      (setq hPipe (substr hPipe 2 20))
                      ;get pipe entity
                      (if (setq pList (handent hPipe))
                        (progn
                          (setq pList (entget pList '("IGNEUSINCUTILS")))
                           ; retrieve size handle from extended data
                          (setq hSize (cdr (assoc 1005 (cdr (assoc "IGNEUSINCUTILS" (cdr (assoc -3 pList)))))))
                          ; retrieve size text entity list
                          (if (/= hSize nil) (setq sList (entget (handent hSize))) (setq sList nil))
                          (if (and (/= hSize nil) (/= sList nil))
                            ; modify existing text
                            (entmod (subst (cons 1 (igneus_rtos pSize nil)) (assoc 1 sList) sList))
                            ; no existing text, dim this pipe
                            (pipedim_entity (handent hPipe) pSize "-"))))))))))))))
  (igneus_end)
)

;;;
;;; Utility Functions used by commands.
;;; These should not be called directly.
;;;

;;; Error handler
(defun igneus_error (s)
  (princ (strcat "\nError: " s))
  (igneus_end)
)

;;; Initialization function for Igneus Inc. Utilities
(defun igneus_init ()
  ; Set new error handler
  (setq olderr *error*
        *error* igneus_error)
  ; Save system variables
  (setq curLayer (getvar "CLAYER"))
  (setq curBlip (getvar "BLIPMODE"))
  (setq curGrid (getvar "GRIDMODE"))
  (setq curHL (getvar "HIGHLIGHT"))
  (setq curCMD (getvar "CMDECHO"))
  ; Set system variables
  (setvar "CMDECHO" 0)
  (setvar "GRIDMODE" 0)
  (setvar "HIGHLIGHT" 1)
  ; Set beginning of an UNDO group
  (command "._UNDO" "_GROUP")
)

;;; Uninitialization function for Igneus Inc. Utilities
(defun igneus_end()
  ; Restore system variables
  (setvar "CLAYER" curLayer)
  (setvar "BLIPMODE" curBlip)
  (setvar "GRIDMODE" curGrid)
  (setvar "HIGHLIGHT" curHL)
  (command "._UNDO" "_E")
  (setvar "CMDECHO" curCMD)
  ; Restore original error handler
  (setq *error* olderr)
  (princ)
)

;;; This function takes a real number in igneus_baseunit units and converts
;;; it to a string formatted in accordance with igneus_lengthdimunit value.
;;;
;;; formatted as: "<feet>'<inches>"
;;; The real number is treated as inches. And is rounded
;;; to the nearest quarter
(defun igneus_rtos(rlength footchar / rlength feet inches fraction fraction_string)
  (cond
    ;;; metric units always use mm pipe sizes - footchar is the flag
    ( (and (> igneus_lengthDimUnit 1) (= nil footchar)) (rtos rlength 2 0))
    ;;; meter
    ( (= igneus_lengthDimUnit 3)
      (progn
        ; Convert base unit to meters
        (cond ((= igneus_baseunit 1) (setq rlength (* rlength 0.0254)))
              ((= igneus_baseunit 2) (setq rlength (* rlength 0.3048)))
              ((= igneus_baseunit 3) (setq rlength (* rlength 0.001))))
        (rtos rlength 2 3))) ; 3 decimal places for m
    ;;; millimeter
    ( (= igneus_lengthDimUnit 2)
      (progn
        ; Convert base unit to millimeters
        (cond ((= igneus_baseunit 1) (setq rlength (* rlength 25.4)))
              ((= igneus_baseunit 2) (setq rlength (* rlength 304.8)))
              ((= igneus_baseunit 4) (setq rlength (* rlength 1000))))
        (rtos rlength 2 0)))  ; no decimal places for mm
    ;;; Foot-inch format
    ( (= igneus_lengthDimUnit 1)
      (progn
        ; Convert base unit to inches (for lengths)
        (if (/= nil footchar)
          (cond ((= igneus_baseunit 2) (setq rlength (* rlength 12)))
                ((= igneus_baseunit 3) (setq rlength (* rlength 0.039372)))
                ((= igneus_baseunit 4) (setq rlength (* rlength 39.372))))
        )
        (if (null footchar)
          (progn
            (setq feet 0)
            (setq inches (fix rLength))
           )
           (progn
             (setq feet (fix (/ rlength 12.0)))
             (setq inches (fix (- rlength (* feet 12))))
           )
        )
        (setq fraction (- rlength (fix rlength)))
        ; Round inches to nearest quarter (with 3/8 going to 1/2 and 7/8 going to 1)
        (setq fraction_string '"")
        (if (> fraction 0.126) (setq fraction_string igneus_onequarter))
        (if (> fraction 0.374) (setq fraction_string igneus_onehalf))
        (if (> fraction 0.626) (setq fraction_string igneus_threequarter))
        (if (> fraction 0.874) (progn
                                 (setq inches (+ inches 1))
                                 (setq fraction_string '"") ))
        (if (= inches 12)
            (progn
              (setq inches 0)
              (setq feet (+ feet 1)) ))
        ; Put feet & inches together
        (if (and (= feet 0) (null footchar))
          (strcat (itoa inches) fraction_string)
          (strcat (itoa feet) footchar (itoa inches) fraction_string)))))
)

;;;
;;; igneus_GetTextLinkHandle
;;;
;;; given a handle to text, returns handle
;;; from extended data of text intenty to line
;;;
(defun igneus_GetTextLinkHandle (hText) ; / nText
  (if (/= nil hText) (setq nText (handent hText)) (setq nText nil))
  (if (/= nil nText)
    (cdr (cadr (cadr (assoc -3 (entget nText '("IGNEUSINCUTILS"))))))))
 

;;;
;;;  Dimensioning Function ver 0.9
;;;
;;;  History
;;;  -------
;;;
;;;  Use:
;;;  ----
;;;  name: name of line entity to be dimensioned
;;;  pipesize: pipe size label text
;;;  footchar will be inserted between feet and inches on lengths
;;;  Draws text in current style on current layer
;;;

(defun pipedim_entity(eName pipeSize footchar );/
;                              pEnt          pStart     pEnd      hSize    hLength
;                              pAngle        pMid       sEntName  tempList
;                              pipedim_text  sEntList )

  ; Setup a TEXT Record
  (setq pipedim_text
    (list
      (cons  0 '"TEXT")                                     ; entity type
      ;(cons  8 (getvar "CLAYER"))                           ; layer (uses current layer)
      (cons 8 igneus_pipeDimLayer)
      (list 10 0.0 0.0 0.0)                                 ; Midpoint
      (list 11 0.0 0.0 0.0)                                 ; Midpoint
      (cons 40 (* (getvar "DIMSCALE") (getvar "DIMTXT")))   ; Height
      (cons  1 '"")                                         ; text value
      (cons 50 0.0)                                         ; text angle
      (cons 41 0.750)                                       ; Width factor
      (cons  7 (getvar "TEXTSTYLE"))                        ; text style
      (cons 72 4)                                           ; Textmode - midpoint
      (cons -3 0)
    )
  )

  (setq pEnt (entget eName '("IGNEUSINCUTILS")))
  (if (= 'LINE' (cdr (assoc 0 pEnt))) (progn
                                        (*error* '"Pipedim_entity not a line")
                                        (quit)))
  (setq pstart (cdr (assoc 10 pEnt)))
  (setq pend (cdr (assoc 11 pEnt)))
  ; Compute plan view angle of line (x and y coordinates only)
  (setq pangle (angle (reverse (cdr (reverse pstart))) (reverse (cdr (reverse pend)))))
  ; make sure angle isn't upside down
  (if (and (> pangle (/ pi 2)) (<= pangle (* 1.5 pi))) (setq pangle (- pangle pi)))
  ; Find the center point of the pipe
  (setq pmid (mapcar '/ (mapcar '+ pStart pEnd) '(2 2 2)))
  ; Create length string
  (setq pLength (distance pStart pEnd))
  ;(if (and (< pLength 11.875) (= igneus_LengthDimUnit 1) (/= nil footChar))
  ;  (setq pLength (strcat '"0" footchar (igneus_rtos pLength footchar)))
  ;  (setq pLength (igneus_rtos pLength footchar))
  ;)
  (setq pLength (igneus_rtos pLength footchar))
  ; get size and length text handles
  (setq hSize (cdr (assoc 1005 (cdr (assoc "IGNEUSINCUTILS" (cdr (assoc -3 pEnt)))))))
  (setq hLength (cdr (assoc 1005 (reverse (cdr (assoc "IGNEUSINCUTILS" (cdr (assoc -3 pEnt))))))))
  ; check for erased and improperly linked text entities (results from copying)
  (if (/= (cdr (assoc 5 pent)) (igneus_GetTextLinkHandle hSize)) (setq hSize nil))
  (if (/= (cdr (assoc 5 pent)) (igneus_GetTextLinkHandle hLength)) (setq hLength nil))
  ; See if there is an existing length text to modify
  (if (/= nil hLength)
    (progn
      ; There is a handle to a length entity - retrieve entity
      (setq sEntName (handent hLength))
      (setq sEntList (entget sEntName '("IGNEUSINCUTILS")))
      ; If this is not text, then error
      (if (/= '"TEXT" (cdr (assoc 0 sEntList))) (progn
                                                  (*error* '"pipe owns nontext - cad app/util conflict with Igneus")
                                                  (quit)))
      ; modify text to new value
      (setq sEntList (subst (cons 1 pLength) (assoc 1 sEntList) sEntList))
      (entmod sEntList))
    (progn
      ; no existing text, so make new
      ; Compute center point for text
      (setq pTxtCtr (list
                      (+ (car pMid) (* (sin pAngle) (* (getvar "DIMSCALE") (getvar "DIMTXT"))))
                      (- (cadr pMid) (* (cos pAngle) (* (getvar "DIMSCALE") (getvar "DIMTXT"))))
                      (caddr pMid)))
      ; Create the text entity
      (setq pipedim_text (subst (cons 1 pLength) (assoc 1 pipedim_text) pipedim_text))
      (setq pipedim_text
        (subst (append '(10) pTxtCtr) (assoc 10 pipedim_text) pipedim_text))
      (setq pipedim_text
        (subst (append '(11) pTxtCtr) (assoc 11 pipedim_text) pipedim_text))
      (setq pipedim_text (subst (cons 50 pAngle) (assoc 50 pipedim_text) pipedim_text))
      ; link this text back to the pipe line entity
      (setq pipedim_text (subst (cons -3 (list (list "IGNEUSINCUTILS" (cons 1005 (cdr (assoc 5 pent))))))
                                (assoc -3 pipedim_text)
                                pipedim_text))
      ; make the text and retrieve it
      (setq sEntList (entget (entmakex pipedim_text) '("IGNEUSINCUTILS")))
      ; store handle to text for later
      (setq hLength (cdr (assoc 5 sEntList)))
    )
  )

  ; See if there is an existing size entity to modify
  (if (/= nil hSize)
    (progn
      ; There is a handle to a size entity - retrieve entity
      (setq sEntName (handent hSize))
      (setq sEntList (entget sEntName '("IGNEUSINCUTILS")))
      ; If this is not text, then error
      (if (/= '"TEXT" (cdr (assoc 0 sEntList))) (progn
                                                  (*error* '"pipe owns nontext - cad app/util conflict with Igneus Utils")
                                                  (quit)))
      ; modify text to new value
      (setq sEntList (subst (cons 1 (igneus_rtos pipeSize nil)) (assoc 1 sEntList) sEntList))
      ; set pointer to length text entity
      (entmod sEntList))
    (progn
      ; Compute center point for text
      (setq pTxtCtr (list
                      (- (car pMid) (* (sin pAngle) (* (getvar "DIMSCALE") (getvar "DIMTXT"))))
                      (+ (cadr pMid) (* (cos pAngle) (* (getvar "DIMSCALE") (getvar "DIMTXT"))))
                      (caddr pMid)))
      ;;; Create the text entity
      (setq pipedim_text
        (subst (cons 1 (igneus_rtos pipeSize nil)) (assoc 1 pipedim_text) pipedim_text))
      (setq pipedim_text
        (subst (append '(10) pTxtCtr) (assoc 10 pipedim_text) pipedim_text))
      (setq pipedim_text
        (subst (append '(11) pTxtCtr) (assoc 11 pipedim_text) pipedim_text))
      (setq pipedim_text (subst (cons 50 pAngle) (assoc 50 pipedim_text) pipedim_text))
      ; link this text back to the pipe line entity
      (setq pipedim_text (subst (cons -3 (list (list "IGNEUSINCUTILS" (cons 1005 (cdr (assoc 5 pent))))))
                                (assoc -3 pipedim_text)
                                pipedim_text))
      ; make the text and retrieve it
      (setq sEntList (entget (entmakex pipedim_text) '("IGNEUSINCUTILS")))
      ; store handle to text for later
      (setq hSize (cdr (assoc 5 sEntList)))
    )
  )
  ; Now store the handles for size and length text in line's extended data
  (if (setq tempList (cdr (assoc -3 pent)))
    ; line already has extended data
    (progn
      (if (assoc "IGNEUSINCUTILS" tempList)
        (setq tempList (subst (cons "IGNEUSINCUTILS" (list (cons 1005 hSize) (cons 1005 hLength)))
                              (assoc "IGNEUSINCUTILS" tempList)
                              tempList))
        (setq tempList (append tempList (list
                                          (cons "IGNEUSINCUTILS" (list
                                                                   (cons 1005 hSize)
                                                                   (cons 1005 hLength)))))))
      (setq pEnt (subst (cons -3 tempList) (assoc -3 pent) pent)))
    ; Line does not have extended data
    (progn
      (setq tempList (list (cons -3 (list (cons "IGNEUSINCUTILS" (list (cons 1005 hSize) (cons 1005 hLength)))))))
      (setq pEnt (append pEnt tempList))))
  ; modify the line entity
  (entmod pent)
)

;;;
;;; Seperates string into tokens and returns as list
;;;
(defun igneus_strToTokens(s );/ tokens charList i j)
  ; find tokens
  (setq tokens nil)
  (setq i 1)
  (setq j 0)
  (while (<= i (strlen s))
    (progn
      ; find start of token
      (while (and (<= i (strlen s)) (= (substr s i 1) " ")) (setq i (1+ i)))
      ; find end of token
      (setq j (1+ i))
      (while (and (<= j (strlen s)) (/= (substr s j 1) " ")) (setq j (1+ j)))
      (if (<= i (strlen s)) (setq tokens (append tokens (list (substr s i (- j i))))))
      (setq i (1+ j))))
  ; return list
  (setq tokens tokens)
)

(defun igneus_getStringD( p d flag / s)
  (if (= "" (setq s (getString flag p))) (setq s d))
  (setq s s))
 
(defun igneus_getintD( p d / s)
  (if (= nil (setq s (getint p))) (setq s d))
  (setq s s))

(defun igneus_getLayName( p d / s )
  (while (not (tblsearch "layer" (setq s (igneus_getstringD p d T)))))
  (setq s s)
)

;;;
;;; Sorts a list of reals/integers using the quick sort algorithm
;;;
(defun igneus_rqsort ( values / values lower_set upper_set dividor )
  ;;; If there is 1 or fewer elements in the list then just return it.  
  (if (< (length values) 2)
    values
    (progn
      ;;; User the average of the first & last values as the dividor value
      (setq dividor (/ (+ (car values) (last values)) 2.0))
      ;;; Initialize the lower & upper sets to the empty list
      (setq lower_set '())
      (setq upper_set '())
      ;;; Split the values into lower & upper ranges
      (while (> (length values) 0)
        (if (> (car values) dividor)
          (setq upper_set (append upper_set (list (car values))))
          (setq lower_set (append lower_set (list (car values)))))
        (setq values (cdr values)))
      ;;; If no split occured then first & last are equal and maximums
      ;;; Take one & put in upper_set so sorting may continue.
      (if (= 0 (length upper_set))
        (setq upper_set (list (car lower_set)) lower_set (cdr lower_set)))
      (append (igneus_rqsort lower_set) (igneus_rqsort upper_set)) ; tail recursion
    )
  )
)

;;;
;;; Sorts a list of lists of reals/integers by the indexed
;;; element in each sublist using the quick sort algorithm.
;;;
(defun igneus_rqsortn ( values index / values lower_set upper_set dividor )
  ;;; If there is 1 or fewer elements in the list then just return it.  
  (if (< (length values) 2)
    values
    (progn
      ;;; User the average of the first & last values as the dividor value
      (setq dividor (/ (+ (nth index (car values)) (nth index(last values))) 2.0))
      ;;; Initialize the lower & upper sets to the empty list
      (setq lower_set '())
      (setq upper_set '())
      ;;; Split the values into lower & upper ranges
      (while (> (length values) 0)
        (if (> (nth index (car values)) dividor)
          (setq upper_set (append upper_set (list (car values))))
          (setq lower_set (append lower_set (list (car values)))))
        (setq values (cdr values)))
      ;;; If no split occured then first & last are equal and maximums
      ;;; Take one & put in upper_set so sorting may continue.
      (if (= 0 (length upper_set))
        (setq upper_set (list (car lower_set)) lower_set (cdr lower_set)))
      (append (igneus_rqsortn lower_set index) (igneus_rqsortn upper_set index)) ; tail recursion
    )
  )
)

;;;
;;; substitutes new substring for old substring in string
;;;
(defun igneus_subststr(a b s / i j)
  (setq i 1)
  (while (<= i (1+ (- (strlen s) (strlen b))))
    (if (= b (substr s i (strlen b)))
      (setq s (strcat
                (substr s 1 (1- i))
                a
                (substr s (+ i (strlen b))))))
    (setq i (1+ i)))
  (setq s s)
)

;;;
;;; gets size and length text for a pipe if it already exists
;;;
(defun igneus_getPipeSizeLength(nPipe / nPipe lPipe hSize hLength sEntName sEntList)
  ; get pipe entity list
  (setq lPipe (entget nPipe '("IGNEUSINCUTILS")))
  ; get size and length text handles
  (setq hSize (cdr (assoc 1005 (cdr (assoc "IGNEUSINCUTILS" (cdr (assoc -3 lPipe)))))))
  (setq hLength (cdr (assoc 1005 (reverse (cdr (assoc "IGNEUSINCUTILS" (cdr (assoc -3 lPipe))))))))
  ; check for erased and improperly linked text entities (results from copying)
  (if (/= (cdr (assoc 5 lPipe)) (igneus_GetTextLinkHandle hSize)) (setq hSize nil))
  (if (/= (cdr (assoc 5 lPipe)) (igneus_GetTextLinkHandle hLength)) (setq hLength nil))
  ; Get length text if it exists
  (if (/= nil hLength)
    (progn
      ; There is a handle to a length entity - retrieve entity
      (setq sEntName (handent hLength))
      (setq sEntList (entget sEntName '("IGNEUSINCUTILS")))
      ; If this is not text, then error
      (if (/= '"TEXT" (cdr (assoc 0 sEntList))) (progn
                                                  (*error* '"pipe owns nontext - cad app/util conflict with Igneus")
                                                  (quit)))
      ; get text
      (setq hLength (cdr (assoc 1 sEntList)))
      ; substitue TSHC characters for user defined characters
      (setq hLength (igneus_subststr "'" igneus_footchar hLength))
      (setq hLength (igneus_subststr ".25" igneus_onequarter hLength))
      (setq hLength (igneus_subststr ".5" igneus_onehalf hLength))
      (setq hLength (igneus_subststr ".75" igneus_threequarter hLength))
      ; if display units are mm, convert to m for The Simple Hydraulic Calculator
      (if (= 2 igneus_lengthDimUnit) (setq hLength (rtos (/ (atof hLength) 1000.0) 2 3)))))

  ; get size text if it exists
  (if (/= nil hSize)
    (progn
      ; There is a handle to a size entity - retrieve entity
      (setq sEntName (handent hSize))
      (setq sEntList (entget sEntName '("IGNEUSINCUTILS")))
      ; If this is not text, then error
      (if (/= '"TEXT" (cdr (assoc 0 sEntList))) (progn
                                                  (*error* '"pipe owns nontext - cad app/util conflict with Igneus Utils")
                                                  (quit)))
      ; modify text to new value
      (setq hSize (cdr (assoc 1 sEntList)))
      ; substitue TSHC characters for user defined characters
      (setq hSize (igneus_subststr "'" igneus_footchar hSize))
      (setq hSize (igneus_subststr ".25" igneus_onequarter hSize))
      (setq hSize (igneus_subststr ".5" igneus_onehalf hSize))
      (setq hSize (igneus_subststr ".75" igneus_threequarter hSize))))      
  ; return list of size and length
  (list hSize hLength)
)

; default settings
(setq igneus_BranchLayer "0")
(setq igneus_MainLayer "0")
(setq igneus_HeadLayer "0")
(setq igneus_PipeDimLayer "0")
(setq igneus_NodeDimLayer "0")
(setq igneus_onequarter ".25")
(setq igneus_onehalf ".5")
(setq igneus_threequarter ".75")
(setq igneus_footchar "-")
(setq igneus_curPipeSize 1.0)    ; default pipe size of 1"
(setq igneus_tolerance 1.0)      ; default tolerance of 1"
(setq igneus_BaseUnit 1)         ; default to base unit of inch
(setq igneus_LengthDimUnit 1)    ; default to foot-inch length dimensioning

; load user settings if they exist
(load "igneus.cfg" "")

;;;---------------------------------------------------------------------------
(regapp "IGNEUSINCUTILS")
(princ "\nIgneus Inc Cad Utilities v0.7.1 Loaded. (c)2006\n")
(princ)
 

<<

Filename: 321636_fpoptions_pipeline_pipedim_trimheads_exportshc_importshc.lsp
Tác giả: trinhhoanghieu090
Bài viết gốc: 321776
Tên lệnh: vc
lisp xuất tọa độ

Em đang dùng lệnh xuất toạ độ vc của diễn đàn, nhưng em muốn chỉnh lại 1 chút cho phù hợp với công việc ( em muốn thay đổi vị trí 2 cột tọa độ X và Y cho nhau) mong các anh chỉnh giúp em. Em xin cảm ơn trước.

>>

Em đang dùng lệnh xuất toạ độ vc của diễn đàn, nhưng em muốn chỉnh lại 1 chút cho phù hợp với công việc ( em muốn thay đổi vị trí 2 cột tọa độ X và Y cho nhau) mong các anh chỉnh giúp em. Em xin cảm ơn trước.Untitled_zps607b4f8e.png

 

http://www.mediafire.com/download/eg45wylb5osw1tt/vc.lsp

Đã sửa lại cho bạn, của bạn đây:

;; free lisp from cadviet.com

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

;;;Chuong trinh danh so va lap bang toa do ho so thua dat dia chinh
;;;Bang toa do tao thanh block, duoc dat ten theo so thu tu 1, 2, 3...
;;;Chap nhan cac doi tuong la Region, Polyline, Line va Arc khep kin
;;;Written by Ssg - September 2008 - www.cadviet.com
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;PUBLIC FUNCTIONS
;;;-------------------------------------------------------------------------------
(Defun DTR(x) (/ (* x pi) 180) ) ;;;change degree to radian, return REAL
;;;-------------------------------------------------------------------------------
(defun lineP (p0 a r / p1) ;;;Line polar: point, degree angle, radius
    (setq p1 (polar p0 (dtr a) r))
    (command "line" p0 p1 "")
)
;;;-------------------------------------------------------------------------------
(defun linePX (p0 x) (lineP p0 0 x)) ;;;Horizontal line: length x, from p0
;;;-------------------------------------------------------------------------------
(defun linePY (p0 y) (lineP p0 90 y)) ;;;Vertical line: length y, from p0
;;;-------------------------------------------------------------------------------
(defun getVert (e / i L) ;;;Return list of all vertex from pline e
(setq i 0 L nil)
(vl-load-com)
(repeat (fix (+ (vlax-curve-getEndParam e) 1))
    (setq L (append L (list (vlax-curve-getPointAtParam e i))))
    (setq i (1+ i))
)
L
)
;;;-------------------------------------------------------------------------------
(defun wtxtMC (txt p h) ;;;Write text Middle Center, specify text, point, height
(entmake (list (cons 0  "TEXT") (cons 7 (getvar "textstyle"))
    (cons 1 txt) (cons 10 p) (cons 11 p) (cons 40 h) (cons 72 1) (cons 73  2)))
)
;;;-------------------------------------------------------------------------------
(defun Collect(e / e2 SS) ;;;Selection set from e to entlast
(setq SS (ssadd))
(ssadd e SS)
(while (setq e2 (entnext e)) (ssadd e2 SS) (setq e e2))
SS
)
;;;-------------------------------------------------------------------------------
(defun Collect1(e / ss)
;;;Selection set after e to entlast. If e nil, select all from fist entity of drawing.
(if (= e nil) (setq ss (collect (entnext)))
	(progn (setq ss (collect e)) (ssdel e ss))
)
)
;;;-------------------------------------------------------------------------------

;;;PRIVATE FUNCTIONS
;;;-------------------------------------------------------------------------------
(defun txt1(txtL / p1 p2 p3 p4 pL i) ;;;Write texts in 1 row
(setq
    p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
    p2 (polar p1 0 (* 8 h))
    p3 (polar p2 0 (* 12 h))
    p4 (polar p3 0 (* 8 h))
    pL (list p1 p2 p3 p4)
    i 0
)
(repeat 3
    (wtxtMC (nth i txtL) (nth i pL) h)
    (setq i (1+ i))
)
)
;;;-------------------------------------------------------------------------------
(defun mesh1() ;;;Make 1 mesh unit
(linepy p0 (* -3 h))
(command "copy" "L" "" p0 (list (+ (car p0) (* 4 h)) (cadr p0)))
(command "array" "L" "" "r" 1 3 (* 12 h))
(linepx (polar p0 (* 1.5 pi) (* 3 h)) (* 28 h))
)
;;;-------------------------------------------------------------------------------


;;;MAIN PROGRAM
;;;-------------------------------------------------------------------------------
(defun C:VC( / h p et p0 p00 pvL oldos j pv num txtL ss bn)
;;;Vertex Co-ordinate

;;;GET TEXT HEIGHT
(if (not h0) (setq h0 1))
(setq h (getreal (strcat "\nChon chieu cao text <" (rtos h0) ">:")))
(if (not h) (setq h h0) (setq h0 h))

;;;PICK & BASE POINT
(setq p (getpoint "\nPick 1 diem giua mien kin:"))
(command "boundary" p "")
(setq et (entlast))
(redraw et 3)
(setq
    p00 (getpoint "\nDiem chuan bang toa do (phia tren ben trai):")
    p0 p00
    pvL (reverse (getvert et))
    oldos (getvar "osmode")
)
(setvar "osmode" 0)

;;;HEADER
(linepx p0 (* 28 h))
(mesh1)
(txt1 (list "TT" "X" "Y"))
(setq p0 (polar p0 (* 1.5 pi) (* 3 h)))

;;;MAKE RECORDS
(setq j 0)
(repeat (1- (length pvL))
    (mesh1)
    (setq
        pv (nth j pvL)
        num (itoa (1+ j))
        txtL (list num (rtos (cadr pv)) (rtos (car pv)) )
    )
    (txt1 txtL)
    ;(wtxtMC num (polar pv 0 h) h)
    (setq p0 (polar p0 (* 1.5 pi) (* 3 h)))
    (setq j (1+ j))
)

;;;MAKE BLOCK
(setq ss (collect1 et))
(command "erase" et "")
(setq bn "1")
(while (tblsearch "block" bn) (setq bn (itoa (1+ (atoi bn)))))
(command "block" bn p00 ss "")
(command "insert" bn p00 "" "" "")

;;;WRITE POINT NAME
(setq j 0)
(repeat (1- (length pvL))
    (setq
        pv (nth j pvL)
        num (itoa (1+ j))
    )
    (wtxtMC num (polar pv 0 h) h)
    (setq j (1+ j))
)

;;;FINISH
(setvar "osmode" oldos)
(princ)
)
;;;-------------------------------------------------------------------------------


<<

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

Không biết bên express có hàm nào làm cái này không, cho nên phải tự chế thôi.

(defun c:test (/ a lst ss b ss0)
  (setq a (entlast)
      lst (list a)
      ss (vl-remove a (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X"))))) 
  )
  (repeat 4
    (setq b (car (vl-remove-if-not '(lambda (x) (equal a (entnext x))) ss))
lst (cons b lst) 
ss (vl-remove b ss)
a b
    )
  )
  (setq ss0 (ssadd))
  (mapcar...
>>

Không biết bên express có hàm nào làm cái này không, cho nên phải tự chế thôi.

(defun c:test (/ a lst ss b ss0)
  (setq a (entlast)
      lst (list a)
      ss (vl-remove a (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X"))))) 
  )
  (repeat 4
    (setq b (car (vl-remove-if-not '(lambda (x) (equal a (entnext x))) ss))
lst (cons b lst) 
ss (vl-remove b ss)
a b
    )
  )
  (setq ss0 (ssadd))
  (mapcar '(lambda(x) (ssadd x ss0)) lst)
  (sssetfirst nil ss0)
)

<<

Filename: 321814_test.lsp
Tác giả: Tue_NV
Bài viết gốc: 321854
Tên lệnh: dmau
sửa lisp đổi màu đối tượng

Ctrl+1 lâu lắm, không biết do mình yếu hay ko mà Ctrl+1 rất giật, hiện lên cũng chậm nhất là khi chỉnh kích thước leader, ngoài ra tìm được phần hiệu chỉnh mất nhiều thời gian

Bạn Tue_NV thử viết lại không dùng Regen như bạn nói xem có nhanh được hơn nhiều không.

Mình cám ơn

Code như...

>>

Ctrl+1 lâu lắm, không biết do mình yếu hay ko mà Ctrl+1 rất giật, hiện lên cũng chậm nhất là khi chỉnh kích thước leader, ngoài ra tìm được phần hiệu chỉnh mất nhiều thời gian

Bạn Tue_NV thử viết lại không dùng Regen như bạn nói xem có nhanh được hơn nhiều không.

Mình cám ơn

Code như vầy :

(defun c:dmau(/ mau)
  (setq mau (ACAD_COLORDLG 7))
  (command "._DIMOVERRIDE" "dimclrt" mau "" )
 )

<<

Filename: 321854_dmau.lsp
Tác giả: Tue_NV
Bài viết gốc: 321939
Tên lệnh: dmau
sửa lisp đổi màu đối tượng

Viết mới sướng hơn nhiều

Code nhanh cho bạn 

 


(defun c:dmau(/ mau)
  (if (setq ss (ssget '((0 . "*TEXT,DIMENSION")))) (progn
(setq mau (ACAD_COLORDLG 7))     
        (command "._chprop" (ssget "P" '((0 . "*TEXT"))) "" "c" mau "")
  (command "._DIMOVERRIDE" "dimclrt" mau "" (ssget "P" '((0 . "DIMENSION"))) )
 ...
>>

Viết mới sướng hơn nhiều

Code nhanh cho bạn 

 


(defun c:dmau(/ mau)
  (if (setq ss (ssget '((0 . "*TEXT,DIMENSION")))) (progn
(setq mau (ACAD_COLORDLG 7))     
        (command "._chprop" (ssget "P" '((0 . "*TEXT"))) "" "c" mau "")
  (command "._DIMOVERRIDE" "dimclrt" mau "" (ssget "P" '((0 . "DIMENSION"))) )
  ))
 )

<<

Filename: 321939_dmau.lsp
Tác giả: pphung183
Bài viết gốc: 322037
Tên lệnh: cl
sửa lisp đổi màu đối tượng

Sửa chút :

(defun c:cl (/ ss m)
(command "undo" "be")
(if (setq ss (ssget)) 
(progn            (setq m (acad_colordlg 7))                                                     
        (command "change" ss "" "P" "c" m "")
        (command "._DIMOVERRIDE" "dimclrt" m "" (ssget "P" '((0 . "DIMENSION"))) "" )
  ))
(command "undo" "end")
(princ))

Filename: 322037_cl.lsp
Tác giả: pphung183
Bài viết gốc: 322036
Tên lệnh: cl
sửa lisp đổi màu đối tượng

Sửa chút :

(defun c:cl (/ ss m)
(command "undo" "be")
(if (setq ss (ssget)) 
(progn            (setq m (acad_colordlg 7))                                                     
        (command "change" ss "" "P" "c" m "")
        (command "._DIMOVERRIDE" "dimclrt" m "" (ssget "P" '((0 . "DIMENSION"))) "" )
  ))
(command "undo" "end")
(princ))

Filename: 322036_cl.lsp
Tác giả: Tot77
Bài viết gốc: 322108
Tên lệnh: dlb
Nhờ viết lisp thay các đối tượng chọn bằng 1 block khác

Bạn thử cái này xem. Máy phải có cài express.

(defun c:dlb (/ blk d0 d1 ss)
  (setq blk (car (entsel "\nChon Block : "))
d0 (car (acet-ent-geomextents blk)))
  (prompt "\nChon doi tuong de thay bang block : ")
  (while (setq ss (ssget))
    (setq d1 (car (acet-geom-ss-extents ss nil)))    
    (command "copy" blk "" "non" d0 "non" d1 "erase" ss "")
  )
  (princ)
)

Filename: 322108_dlb.lsp
Tác giả: gia_bach
Bài viết gốc: 322114
Tên lệnh: cl
sửa lisp đổi màu đối tượng

Cách khác : 

(defun c:cl (/ m ss)
  (if (and (setq ss (ssget))
	   (setq m (acad_colordlg 7)))
    (foreach obj (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
      (if (wcmatch (vla-get-objectname obj) "*Dimension")
	(progn(vla-put-TextColor obj m)(vla-update obj))
	(vla-put-Color obj m)  )  )    )
  (princ))

Filename: 322114_cl.lsp
Tác giả: gia_bach
Bài viết gốc: 322114
Tên lệnh: cl
sửa lisp đổi màu đối tượng

Cách khác : 

(defun c:cl (/ m ss)
  (if (and (setq ss (ssget))
	   (setq m (acad_colordlg 7)))
    (foreach obj (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
      (if (wcmatch (vla-get-objectname obj) "*Dimension")
	(progn(vla-put-TextColor obj m)(vla-update obj))
	(vla-put-Color obj m)  )  )    )
  (princ))

Filename: 322114_cl.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 322404
Tên lệnh: ha
Đố vui

@Haanh + @Hoằn:

Mặc dầu không xem file của Haanh post lên, nhưng cả cách Haanh và Hoằn đều dẫn đến kết quả con số 10 chỉ là gần đúng. Có làm 100 lần thì nó vẫn cứ gần đúng mà thôi. Đây là bản chất của Cad. May mắn lắm thì trong vài trường hợp đặc biệt mới có thể cho ra con số 10 tuyệt đối đúng.

Để minh chứng, 2 em thử lisp sau đây để biết chiều dài thực của đoạn...

>>

@Haanh + @Hoằn:

Mặc dầu không xem file của Haanh post lên, nhưng cả cách Haanh và Hoằn đều dẫn đến kết quả con số 10 chỉ là gần đúng. Có làm 100 lần thì nó vẫn cứ gần đúng mà thôi. Đây là bản chất của Cad. May mắn lắm thì trong vài trường hợp đặc biệt mới có thể cho ra con số 10 tuyệt đối đúng.

Để minh chứng, 2 em thử lisp sau đây để biết chiều dài thực của đoạn đường cong.

 

(defun C:HA(/ ent len)
 (setq ent (car (entsel "\nChon doan duong cong can kiem tra chieu dai: ")))
 (setq len (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)))
  (alert (strcat "Chieu dai thuc la: " (rtos len 2 100))))

<<

Filename: 322404_ha.lsp
Tác giả: ketxu
Bài viết gốc: 322458
Tên lệnh: ha
Sửa lisp ghi cao độ và xin lisp tính khoảng cách trên mặt cắt ngang

Sau này bạn vui lòng :

1- Post đúng vị trí bạn đã thấy lisp nếu yêu cầu không khác quá xa yêu cầu gốc

2- Nếu post code ra ngoài vui lòng cho code vào thẻ code (hình <>)

 

(defun C:HA( / y0 y1 ent s)
(command "ucs" "w")
(setq y0 (cadr (cdr (assoc 10 (entget (car (entsel "\nChon Line de lam duong chuan: ")))))))
(or *tl* (setq *tl* 1))
(setq *tl* (cond ((getreal (strcat "\nTi le < " (rtos...
>>

Sau này bạn vui lòng :

1- Post đúng vị trí bạn đã thấy lisp nếu yêu cầu không khác quá xa yêu cầu gốc

2- Nếu post code ra ngoài vui lòng cho code vào thẻ code (hình <>)

 

(defun C:HA( / y0 y1 ent s)
(command "ucs" "w")
(setq y0 (cadr (cdr (assoc 10 (entget (car (entsel "\nChon Line de lam duong chuan: ")))))))
(or *tl* (setq *tl* 1))
(setq *tl* (cond ((getreal (strcat "\nTi le < " (rtos *tl*) "> :")))(*tl*)))
(while
  (and
   (setq y1 (cadr (getpoint "\nPick diem de lay cao do: ")) s (* *tl* (- y1 y0)))
   (while (not (setq ent (car (entsel "\nChon Text de sua cao do: ")))))
   (entmod (subst (cons 1 (strcat (if (> s 0.0) "+" "") (rtos s 2 2))) (assoc 1 (entget ent)) (entget ent)))))
(princ))

<<

Filename: 322458_ha.lsp

Trang 182/330

182