Jump to content
InfoFile
Tác giả: Tot77
Bài viết gốc: 318185
Tên lệnh: tta
Nhờ sửa Lisp Copy Text Cad sang Excel

@huunhan : bạn thử cái này http://www.cadviet.com/forum/topic/99171-xuat-cad-sang-excel/

@tien:  cứ để file excel mở song song với file cad, chừng nào không nhập nữa thì hãy save và tắt excel.

(defun c:tta (/ ss sst ssc ssd pl oo txt i lst area *error*)
  (vl-load-com)
  (defun inside(pt l)
    (defun...
>>

@huunhan : bạn thử cái này http://www.cadviet.com/forum/topic/99171-xuat-cad-sang-excel/

@tien:  cứ để file excel mở song song với file cad, chừng nào không nhập nữa thì hãy save và tắt excel.

(defun c:tta (/ ss sst ssc ssd pl oo txt i lst area *error*)
  (vl-load-com)
  (defun inside(pt l)
    (defun tgoc(a b c) (abs (- pi (abs (- (angle b c) (angle a b))))))
    (equal 6.28319 (apply '+ (mapcar '(lambda(x y) (tgoc x pt y)) l (append (cdr l) (list (car l))))) 0.001)
  )
 
  (if (not xlApp)    
    (setq xlApp   (vlax-get-or-create-object "Excel.Application")
          xlCells (vlax-get-property
                      (vlax-get-property
                        (vlax-get-property
                          (vlax-invoke-method
                            (vlax-get-property xlApp "Workbooks")
                            "Add") "Sheets") "Item" 1) "Cells")
row 0 col 1
         xtmp (vla-put-visible xlApp :vlax-true)
    )
  )
 
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X" '((0 . "TEXT"))))))
sst (vl-remove-if-not '(lambda (x) (distof (vla-get-TextString (vlax-ename->vla-object x)))) ss)
ssc (vl-remove-if '(lambda (x) (member x sst)) ss)
sst (mapcar '(lambda (x) (list (vlax-get (vlax-ename->vla-object x) 'TextAlignmentPoint)
 (vla-get-TextString (vlax-ename->vla-object x)))) sst) 
  )
  (prompt "\nChon khung pline:")
  (while (setq pl (ssget ":E:S" '((0 . "LWPOLYLINE"))))
    (setq pl (ssname pl 0)) (redraw pl 3)    
    (setq ssd (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= 10 (car x))) (entget pl)))
 oo (vl-remove-if-not '(lambda (x) (inside (vlax-get (vlax-ename->vla-object x) 'TextAlignmentPoint) ssd)) ssc))
    (if oo
      (progn 
(setq oo (car oo)
     ssc (vl-remove oo ssc)
     lst (list (vla-get-TextString (vlax-ename->vla-object oo))))
        (foreach pt ssd
          (setq txt (car (vl-sort sst '(lambda (x y) (< (distance (car x) pt) (distance (car y) pt)))))
       lst (append lst (list (last txt))) 
          )
        )
        (setq area (rtos (* 0.000001 (vla-get-Area (vlax-ename->vla-object pl))) 2 2)
     i -1 row (1+ row))
        (mapcar '(lambda (x) (vlax-put-property xlCells "Item" row  (+ col (setq i (1+ i))) x)) lst)
        (vlax-put-property xlCells "Item" row 9 area)
       )
    )
    (prompt "\nChon khung pline:")
  )  
  (mapcar '(lambda (x) (redraw x 4)) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X")))))
  (redraw)
  (princ)
)

@huaductiep: để lúc nào rảnh tôi sửa theo yêu cầu cuả bạn, lúc này hơi bị "ngán" cái đề tài này.


<<

Filename: 318185_tta.lsp
Tác giả: hiepttr
Bài viết gốc: 318163
Tên lệnh: ktcv
Tổng hợp các lisp thường dùng cho dân CƠ KHÍ & CẤP TỐC THOÁT NƯỚC

Còn chần chờ gì nữa mà ko tiếp bước 2, bước 3 ..... bước n đi haanh ?!

 

>>> Phần 1:

(defun c:KTCV( / Rnho Rlon P S Dng Dtr x y Dtb)
(defun ch(a b) (sqrt (+ (* a a) (* b b))))
;====
(setq Rnho (getdist "\nNhap ban kinh nho (r): ")
	  Rlon (getdist "\nNhap ban kinh lon (R): ")
	  P (getdist "\nNhap buoc vit (P): ")
	  S (getdist "\nNhap chieu day tam thep (S): "))
(cond ((and Rnho Rlon P S)
	(setq Dng (/ (ch (* 2...
>>

Còn chần chờ gì nữa mà ko tiếp bước 2, bước 3 ..... bước n đi haanh ?!

 

>>> Phần 1:

(defun c:KTCV( / Rnho Rlon P S Dng Dtr x y Dtb)
(defun ch(a b) (sqrt (+ (* a a) (* b b))))
;====
(setq Rnho (getdist "\nNhap ban kinh nho (r): ")
	  Rlon (getdist "\nNhap ban kinh lon (R): ")
	  P (getdist "\nNhap buoc vit (P): ")
	  S (getdist "\nNhap chieu day tam thep (S): "))
(cond ((and Rnho Rlon P S)
	(setq Dng (/ (ch (* 2 pi Rlon) P) pi)
		  Dtr (/ (ch (* 2 pi Rnho) P) pi)
		  x (sqrt (- (* (- Rlon Rnho) (- Rlon Rnho)) (/ (* (- Dng Dtr) (- Dng Dtr)) 4.)))
		  y (/ (* x 0.5 S) (- Rlon Rnho))
		  Dtb (- Dng (* 2 y))))
)
)

P/s:

haanh cần đưa nguyên cục vậy để mình lựa chọn giải pháp để khỏi tốn công vô ích

chứ viết lisp mà cứ rặn .... từng tí vậy là ức chế lắm đó ^ ^

 

:D :D :D


<<

Filename: 318163_ktcv.lsp
Tác giả: ketxu
Bài viết gốc: 318221
Tên lệnh: abcxyz
Nhờ giúp đỡ

Quick code :

(defun c:abcxyz()
(setvar 'angdir 1)
(setq 	gh (getreal "\ngh :") f (if (<= gh 180) + -))
(mapcar 'set '(gt gs) 
	(read (strcat "(" (getstring t "\ngt gs (cach nhau boi space) :") ")"))
)
(setq 	ga (+ (f gh 180) (* gs 0.5))
		gc (- (f gh 180) (* gs 0.5))
		gb (- gh (* gt 0.5))
		gd (+ gh (* gt 0.5))
)
(setvar 'angdir 0)
)

Filename: 318221_abcxyz.lsp
Tác giả: nhoclangbat
Bài viết gốc: 311132
Tên lệnh: vll kkj kkt kkm
Chương 5.5 : Bài tập

- sau 1 hồi ngâm nga nhoc xin đc nộp lại bài tập ^^

;ve line
(defun c:vll (/ pa pb old)
(setq old (mapcar 'getvar '("cmdecho" "osmode")))
(mapcar 'setvar '("osmode" "cmdecho") '(33 0))
(initget 1)
(setq pa (getpoint "\nchon diem A:"))
(initget 1)
(setq pb (getpoint pa "\nchon diem B:"))
(command ".line" pa pb "")
(mapcar 'setvar '("cmdecho" "osmode") old)
(princ )
)
;;;;ham ipos
(defun ipos (n lst / len)
(setq len (length lst))
(if (< n...
>>

- sau 1 hồi ngâm nga nhoc xin đc nộp lại bài tập ^^

;ve line
(defun c:vll (/ pa pb old)
(setq old (mapcar 'getvar '("cmdecho" "osmode")))
(mapcar 'setvar '("osmode" "cmdecho") '(33 0))
(initget 1)
(setq pa (getpoint "\nchon diem A:"))
(initget 1)
(setq pb (getpoint pa "\nchon diem B:"))
(command ".line" pa pb "")
(mapcar 'setvar '("cmdecho" "osmode") old)
(princ )
)
;;;;ham ipos
(defun ipos (n lst / len)
(setq len (length lst))
(if (< n len)
(nth (1- n) lst)))
;;;;;kiem tra so nguyen hay thuc
(defun c:kkj (/ d1 hh)
(setq d1 (getdist "\nnhap khoang cach:"))
(princ "\n")
(setq hh (getvar "lastprompt"))
(setq kk (strlen "nhap khoang cach: "))
(setq tt (read (substr hh kk)))
(princ "\n")
(setq xx (type tt))
(cond 
	((= xx (type 5)) (alert " kc nhap la so nguyen"))
	((= xx (type 5.0)) (alert " kc nhap la so thuc")))
)
;cau 5.4 cai nay nghe quen quen ^^ lam dai ko pit dung ko
(defun c:kkt (/ oldd pp)
(setq oldd (mapcar 'getvar '("cmdecho" "osmode")))
(mapcar 'setvar '("osmode" "cmdecho") '(33 0))
(if (not bankinh) (setq bankinh 10))
(setq bankinh1 (getreal (strcat "\nnhap ban kinh (" (rtos bankinh 2 0) "): ")))
(if bankinh1 (setq bankinh bankinh1))
(setq pp (getpoint "\nchon vi tri tam:"))
(command ".circle" pp bankinh)
(mapcar 'setvar '("cmdecho" "osmode") oldd)
(princ "\n"))
;;;;;



(defun c:kkm (/ hanggia xx hangl giatuongung tongtien baocao thongbao dd)
(setq hanggia '(("PEPSI"  9000) ("COCA"  7000) ("7UP"  8000)))
(setq hangl '(("PEPSI" . 15) ("COCA" . 2) ("7UP" . 45)))
(setq xx '("COCA" "7UP" "7UP" "PEPSI" "COCA" "7UP"))
(princ "\n")
(defun doi (a)
(last (assoc a hanggia)))
(princ "\n")
(princ (setq giatuongung (mapcar 'doi xx)))
;gia tuong ung (7000 8000 8000 9000 7000 8000)
(princ "\n")
(princ (setq tongtien (apply '+ giatuongung)))
(princ)
(defun lay (b) 
(setq hangl (subst (cons b (1- (cdr (assoc b hangl)))) (assoc b hangl) hangl)))
(setq dd (last (mapcar 'lay xx)))
(princ "\n")
(defun hangcon (cc)
(princ (strcat "\nSo luong "(car cc) " con : " (itoa (cdr cc)) " chai")))
(setq thongbao (mapcar 'hangcon dd))
(princ "\n")
(defun dohang (yy)
(cond 
      ((= (cdr yy) 0) (princ (strcat "\nda het " (car yy))))
	  ((> (cdr yy) 0) (princ (strcat "\nvan con " (car yy)))))) 
(princ "\n")
(setq baocao (mapcar 'dohang dd))
(princ)
)

	
	




- câu 6 nhoc vẫn chưa tìm ra  đc ví dụ nào có thể sử dụng hàm and và pr thay if và cond, vậy chương trình với yêu cầu nào thì chỉ cần sử dụng hàm and , or, link anh Ket đưa mất rùi ^^, nhoc chỉ hiểu là and và or là các hàm logic như lý thuyết nêu có tác dụng tạo ra điều kiện để làm 1 việc gì đó.

-vd: mày và tao ????? mày và tao sẽ làm gì; mày hoặc tao tương tự ??? cũng có trường hợp khác thì hiểu ( tiền hoặc chết) ^^ => tóm lại chưa thông

-ah nhoc cảm thấy hơi khó khi lồng hàm logic vào hàm if với cond, và cảm giác của nhoc, hàm cond nhìn có vẽ rõ ràng tường minh hơn hàm if ^^, nên bài của nhoc dùng hàm cond không ah, if chỉ đc rẽ 2 nhánh, cond đc nhiều nhánh, vậy sao đa số lsp nhoc thấy dùng if nhiều hơn cond nhỉ, nếu dùng cond mún chỉnh sữa thêm điều kiện cũng dễ hơn mà ^^

- như vd của anh

(if  (= a 1) (progn (setq b 4) (set c 5) (set d 6))) => 6

- khi sử dụng hàm cond nó cũng cho ra đc ket qu tương tự 

(cond 

           ( (= a 1) (set b 4) (set c 5) (set d 6))) => 6

_ Mong đc a Ket thông dùm nhoc :)


<<

Filename: 311132_vll_kkj_kkt_kkm.lsp
Tác giả: nhoclangbat
Bài viết gốc: 318304
Tên lệnh: kkl kxoa
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

- mấy anh ơi trợ giúp nhoc bài toán này với ^^, nhoc đang tính nâng cấp cái lsp nhoc lên mà chưa nghĩ ra giải thuật ngắn gọn ^^, nó có nhiều trường hợp lắc léo, nhoc test chắc hơn chục trường hợp , gặp cái nào nhoc thêm đk cái đó riết cái lsp dài lê thê mà vẫn chưa thỏa đc.

-  nhoc có 1 danh sách các khoảng cách mắt lưới như sau 10-25-50-100-200-250-500, hàm làm tròn của nhoc có 1 tham số...

>>

- mấy anh ơi trợ giúp nhoc bài toán này với ^^, nhoc đang tính nâng cấp cái lsp nhoc lên mà chưa nghĩ ra giải thuật ngắn gọn ^^, nó có nhiều trường hợp lắc léo, nhoc test chắc hơn chục trường hợp , gặp cái nào nhoc thêm đk cái đó riết cái lsp dài lê thê mà vẫn chưa thỏa đc.

-  nhoc có 1 danh sách các khoảng cách mắt lưới như sau 10-25-50-100-200-250-500, hàm làm tròn của nhoc có 1 tham số tương đương với khoảng cách mắt lưới.

- sơ khai lsp dựa vào kich thước khung, rùi nhoc đặt đk từ lớn đến nhỏ khoảng cách lưới, thằng nào thỏa trước sẽ làm thằng đó, nhưng cái dở ở đây, với khung to, mắt lưới tạo ra quá dày nhìn bị rối.

- nhoc dựa vào biến tỉ lệ để quyết định hệ số làm tròn là bao nhiêu, tuy nhiên với tỉ lệ nhỏ, mà khung quá to khoảng cách mắt lưới nhỏ, nhìn dày quá ^^

- ý định của nhoc là ko cần dựa vào tỉ lệ nhập nữa mà dựa vào kích thước khung để quyết định khoảng cách mắt lưới, tỉ lệ chỉ quyết định chiều cao tẽt và kick thước mắt lưới

- VD: tỉ lệ 500, mà khung tới 700 chẳng hạn, nhoc muốn nó duyệt từ từ lấy 700 chia cho từng đơn vị mắt lưới ở trên từ lớn đến nhỏ, để ra số lần lặp, tối thiểu phải có 2 mắt trục x và 2 mắt trục y, lớn nhất chỉ 3 mắt, còn ra ngoài 2 đk đó thì nó duyệt thằng khác,chừng nào thỏa thì sẽ trả về đơn vị mắt lưới cần tạo và hệ số làm tròn tương ứng, như Vd nhoc ở đây thì 700/200 là đẹp ^^ số làn lặp sẽ là 3.

;hàm tao textstyle
(defun emk_style (MyStyle MyFont)
(entmake (list    (cons 0 "STYLE")    
(cons 100 "AcDbSymbolTableRecord")    
(cons 100 "AcDbTextStyleTableRecord")    
(cons 2 MyStyle)    (cons 3  MyFont)    
(cons 70 0))))
;;;;
(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))))) 
;;;;;;--------------------------------------------------------------------------------------------
;================================================================================================
(defun dtr (a)
(* (/ a 180.0) pi)
)
(prompt "LISP TAO LUOI TOA DO BAN DO VI TRI, LENH : KKL")
;;;
(defun c:kkl (/ donvi nx ny pt1 pt2 kcx kcy goc1 goc2 x1 x y  heso old ptext1 ptext2 ptext3 ptext4 str str2 goc3 htext num lstp obj ss ss1 ten pt3 pt4 tronx trony kk)
(vl-load-com)
(setq old (getvar "osmode"))
(if (null (tblsearch "STYLE" "vusaln"))
    (emk_style "vusaln" "Vaptimn.TTF"))
(if (null (tblsearch "LAYER" "A1-luoik"))
    (_layer2 "A1-luoik" 7))
  (setq tyleVT (getvalue tyleVT 1000.0 "Nhap ty le ban do VT: "))
  (princ "\n")
  (setq heso (/ 1000 tyleVT))
  (setq htext (/ 2.0 heso))
  (setq kk (/ tyleVT 20))
(prompt "Chon Khung chay luoi, luu y khung chon phai la polyline:")
;==================================================================
(while (/= (setq ss (ssget "+.:E:S" '((0 . "LWPOLYLINE")))) nil)
;===================================*******************++++++++++++++++++++********************===================================  
(progn
(setvar "osmode" 0)
;======================================================================
(setq obj (vlax-ename->vla-object (ssname ss 0)))
(setq lstp (vla-getBoundingBox obj 'minp 'maxp))
(setq pt1 (vlax-safearray->list minp))
(setq pt2 (vlax-safearray->list maxp))
(setq pt3 (inters pt1 (polar pt1 (/ pi 2) 90000) pt2 (polar pt2 pi 90000) nil))
(setq pt4 (inters pt1 (polar pt1 0 90000) pt2 (polar pt2 (dtr 270) 90000) nil))
;=======================================================================
(setq kcx (- (car pt2) (car pt1)) kcy (- (cadr pt2) (cadr pt1)))
;===============================================================================================
(cond        ((and (= tyleVT 500.0) (> kcx 150) (>= (/ kcy 50) 1.8))
			 (setq donvi 50) (setq kk 50))
			 ((and (= tyleVT 4000.0) (> kcx 1270) (>= (/ kcy 400) 1.8))
			 (setq donvi 400) (setq kk 400))
			 ((and (= tyleVT 5000.0) (> kcx 1590) (>= (/ kcy 500) 1.8))
			 (setq donvi 500) (setq kk 500))
             ((and (>= (/ kcx 250) 1.8) (>= (/ kcy 250) 1.8) (> kcx 650))
             (setq donvi 250))
             ((and (>= (/ kcx 200) 2) (>= (/ kcy 200) 1.8) (> kcx 410))
             (setq donvi 200))
            ((and (>= (/ kcx 100) 1.8) (>= (/ kcy 100) 1.8) (> kcx 250))
             (setq donvi 100))
		    ((and (>= (/ kcx 50) 1.8) (>= (/ kcy 50) 1.8) (> kcx 125))
             (setq donvi 50))
            ((and (>= (/ kcx 25) 1.8) (>= (/ kcy 25) 1.8) (> kcx 62.5))
             (setq donvi 25))
			 ((and (>= (/ kcx 10) 1.8) (>= (/ kcy 10) 1.8) (> kcx 25.5))
             (setq donvi 10))
            )
(if donvi
     (progn
    (cond
        ((> donvi 250) (setq tronx (lamtron (fix (+ (car pt1) 100)) kk)) (setq trony (lamtron (fix (+ (cadr pt1) 100)) kk)))
	    ((> donvi 10) (setq tronx (lamtron (fix (+ (car pt1) 10)) kk)) (setq trony (lamtron (fix (+ (cadr pt1) 10)) kk)))
	    ((<= donvi 10) (setq tronx (lamtron (fix (car pt1)) kk)) (setq trony (lamtron (fix (cadr pt1)) kk)))
    )	   
;==============================================================================================
(cond  
        ((> (- (+ tronx (* donvi (- (fix (/ kcx donvi)) 1))) (car pt1)) kcx) (setq nx (- (fix (/ kcx donvi)) 1)))
		((and (< (- (+ tronx (* donvi (- (fix (/ kcx donvi)) 1))) (car pt1)) kcx) (> (- (- (car pt4) (/ 10 heso)) (+ tronx (* donvi (- (fix (/ kcx donvi)) 1)))) donvi)) (setq nx (1+ (fix (/ kcx donvi)))))
		((< (- (+ tronx (* donvi (- (fix (/ kcx donvi)) 1))) (car pt1)) kcx) (setq nx (fix (/ kcx donvi))))
)
(cond  
         ((> (- (+ trony (* donvi (- (fix (/ kcy donvi)) 1))) (cadr pt1)) kcy) (setq ny (- (fix (/ kcy donvi)) 1)))
		 ((and (< (- (+ trony (* donvi (- (fix (/ kcy donvi)) 1))) (cadr pt1)) kcy) (> (- (- (cadr pt3) (/ 5 heso)) (+ trony (* donvi (- (fix (/ kcy donvi)) 1)))) donvi)) (setq ny (1+ (fix (/ kcy donvi)))))
		 ((< (- (+ trony (* donvi (- (fix (/ kcy donvi)) 1))) (cadr pt1)) kcy) (setq ny (fix (/ kcy donvi))))
)
;==============================================================================================
 (setq goc2 (list tronx (cadr pt1) 0.0))
(setq goc3 (list (car pt1) trony 0.0))
;===============================================================
(repeat nx

(makeline goc2 (polar goc2 (/ pi 2) (/ 8.0 heso)) "A1-luoik" nil nil nil)
;=======================================================================
(setq ptext1 (polar goc2 (dtr 23) (/ 3.5 heso)))
(setq ptext2 (polar goc2 (dtr 158) (/ 3.5 heso)))
(setq num (fix (car goc2)))
(setq str (them0 (itoa (rem num 1000))))
(setq str2 (itoa (/ num 1000)))
(mktext ptext1 htext str "M" "A1-luoik" "vusaln" nil)
(mktext ptext2 htext str2 "M" "A1-luoik" "vusaln" nil)
;=======================================================================
(setq goc2 (mapcar '+ goc2 (list donvi 0.0 0.0)))
) ;end repeat nx
;============================================================
(repeat ny
(makeline goc3 (polar goc3 0 (/ 8.0 heso)) "A1-luoik" nil nil nil)
;=====================================================================
(setq ptext3 (polar goc3 (dtr 23) (/ 4.0 heso)))
(setq ptext4 (polar goc3 (dtr 338) (/ 4.0 heso)))
(setq num (fix (cadr goc3)))
(setq str (them0 (itoa (rem num 1000))))
(setq str2 (itoa (/ num 1000)))
(mktext ptext3 htext str2 "M" "A1-luoik" "vusaln" nil)
(mktext ptext4 htext str "M" "A1-luoik" "vusaln" nil)
;============================================================= 
(setq goc3 (mapcar '+ goc3 (list 0.0 donvi 0.0)))
); end repeat ny
;============================================================
(setq goc1 (list tronx trony 0.0))
;============================================================================================ 
 (setq x (car goc1))
  (repeat nx
    (setq y (cadr goc1))
    (repeat ny
      
	  (vediem x y (/ 2.5 heso))
      (setq y (+ y donvi))
    )
;===============================================================================================
    (setq x (+ x donvi))
  )
 ;==============================================================================================
 ) ;end progn donvi
   (alert "Ban chon Khung KiBo qua\nChon Khung Lai Hen!!!^^") ; end nho hon 25
) ; end if don vi
;==============================================================================
) ; end progn while

) ; end while
(prompt "Ban co mun xoa luoi vua tao, co thi quet chon enter, khong thi enter bo qua")
(setq ss1 (ssget '((0 . "LINE,TEXT") (8 . "A1-luoik"))))
(if ss1
 (progn
   (repeat (sslength ss1)
	 (setq ten (ssname ss1 0))
	 (entdel ten)
	 (ssdel ten ss1)
	 )
  )
 )
(setvar "osmode" old)
(princ)
)
;============================================================================================
(defun c:kxoa()
(prompt "Chon luoi vua tao mun xoa")
(ssget '((0 . "LINE,TEXT") (8 . "A1-luoik")))
(vl-cmdf ".erase" "P" "")
(princ)
)
;==============================================================================================
;;;;;;;;;;;;;;;;;;;
(defun lamtron (n k / sodu)
  (setq sodu (rem n k))
  (if (/= sodu 0)
    (setq n (+ (- n sodu) k))
  )
  n
)
;=================================
(defun vediem (xx yy r / left right top bot)
  (setq top (+ yy r))
  (setq bot (- yy r))
  (setq right (+ xx r))
  (setq left (- xx r))
  (makeline (list left yy) (list right yy) "A1-luoik" nil nil nil)
  (makeline (list xx top) (list xx bot) "A1-luoik" nil nil nil)
)
;============================
;=================================================================================
(defun _layer2 ( name colour )
    (if (null (tblsearch "LAYER" name))
        (entmake
            (list
               '(0 . "LAYER")
               '(100 . "AcDbSymbolTableRecord")
               '(100 . "AcDbLayerTableRecord")
               '(70 . 0)
                (cons 2 name)
                (cons 62 colour)
            )
        )
    )
)
;=====================================================================================
; ham luu gia tri
(defun getvalue ( a giatri dongnhac / astr) 
(or a (setq a giatri))
(cond
	((= (type a) 'INT) (setq a (cond ((getint (strcat "\n" dongnhac "(" (itoa a) ") :")))(a))))
	((= (type a) 'REAL) (setq a (cond ((getreal (strcat "\n" dongnhac "(" (rtos a 2 0) ") :")))(a))))
	((= (type a) 'STR) (setq a (cond ((= "" (setq astr (getstring T (strcat "\n" dongnhac " (" a "): ")))) a) (astr))))
))
;;;;
;ham tao text 2
(defun mktext (point height string justify layer textstyle mau / lst)
(setq lst (list '(0 . "TEXT")
                              (cons 10 point)
							  (cons 40 height)
							  (cons 1 string)
							  (cons 8 layer)
							  (cons 7 (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
;--------------------------------------
(defun them0(chuoi)
  (setq len (strlen chuoi))
  (if (= len 1)
    (strcat "00" chuoi)
    (if (= len 2)
      (strcat "0" chuoi)
      chuoi
    )  
  )
 )

- Mong đc các anh giúp đở ^^

- P/s: nhoc ko giỏi trình bày có gì các anh bỏ quá cho ^^


<<

Filename: 318304_kkl_kxoa.lsp
Tác giả: ksgia
Bài viết gốc: 13722
Tên lệnh: ttx tty
KHI TA GỬI ĐI 2 NỤ CƯỜI
Tôi vẫn nhớ như in từng chữ tư tưởng chủ đề của bộ phim Độ dốc (không nhớ rõ tác giả của bộ phim này), qua bài viết của một tác giả đăng trên báo Phụ nữ Việt nam:
"Trong mỗi con người chúng ta, dù ở bất kỳ cương vị công tác nào trong cuộc sống, đều có một độ dốc giới hạn. Hoàn thành tốt mọi nhiệm vụ trong cái giới hạn sẵn có của bản thân là điều không ai có...
>>
Tôi vẫn nhớ như in từng chữ tư tưởng chủ đề của bộ phim Độ dốc (không nhớ rõ tác giả của bộ phim này), qua bài viết của một tác giả đăng trên báo Phụ nữ Việt nam:
"Trong mỗi con người chúng ta, dù ở bất kỳ cương vị công tác nào trong cuộc sống, đều có một độ dốc giới hạn. Hoàn thành tốt mọi nhiệm vụ trong cái giới hạn sẵn có của bản thân là điều không ai có thể chê trách. Nhưng niềm vinh quang chân chính chỉ đến với những ai dám vượt qua cái giới hạn sẵn có của bản thân để có thể đi xa hơn nữa..."
Trong văn học, đã có một dạo rộ lên cái gọi là văn học bước qua lời nguyền , sau khi xuất hiện tác phẩm Bước qua lời nguyền của Nhà văn trẻ Tạ Duy Anh...
<<

Filename: 13722_ttx_tty.lsp
Tác giả: Tot77
Bài viết gốc: 318391
Tên lệnh: ofs
offset cùng 1 lúc nhiều đối tượng "về 1 phía"

Sửa chút xíu lsp của Ket, có 2 điều :

1. Pline không cần phải closed mới dùng được, nhưng dĩ nhiên pline phải có nhiều đoạn nó mới biết cái nào vào trong cái nào ra ngoài.

2. Gộp 2 lệnh o+o- vào chung 1 lệnh, bạn nhập số >0 thì offset ra ngoài, <0 thì offset vào trong.

Còn các lệnh chamfer và fillet vẫn như cũ.

 Bạn đặt sẵn layer hiện hành trước khi chạy lsp, màu theo...

>>

Sửa chút xíu lsp của Ket, có 2 điều :

1. Pline không cần phải closed mới dùng được, nhưng dĩ nhiên pline phải có nhiều đoạn nó mới biết cái nào vào trong cái nào ra ngoài.

2. Gộp 2 lệnh o+o- vào chung 1 lệnh, bạn nhập số >0 thì offset ra ngoài, <0 thì offset vào trong.

Còn các lệnh chamfer và fillet vẫn như cũ.

 Bạn đặt sẵn layer hiện hành trước khi chạy lsp, màu theo bylayer.

 

(vl-load-com) 
(defun c:ofs( / ss lay lst)
  (setq lay (getvar 'clayer))
  (cond ((ssget '((0 . "CIRCLE,ELLIPSE,POLYLINE,LWPOLYLINE,SPLINE")))
(or #d (setq #d 5))
(setq #d (cond ((getdist (strcat "\nDistance <" (rtos #d 2 2) ">"))) (#d)))
(vlax-for obj (setq ss (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object))))
 (setq lst (mapcar 'car (list (vlax-invoke obj 'Offset #d)  (vlax-invoke obj 'Offset (- #d)))))
 (mapcar '(lambda (x) (vla-put-Layer x lay) (vla-put-Color x 256)) lst)
 (vla-delete (car (vl-sort lst
'(lambda(x y) ((if (< #d 0) > <) (vlax-get x 'Area) (vlax-get y 'Area))) ))
 )
)
(vla-delete ss)
)
(T (princ "\nNo thing to do"))
  )
)

<<

Filename: 318391_ofs.lsp
Tác giả: Tue_NV
Bài viết gốc: 318412
Tên lệnh: m-%3Eh
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Cám ơn Tue_NV

Vì mình tinh chuyển qua Microstation nhưng phần mềm này không hiểu Mpolygon bằng Hatch nên mình dự định chuyển Mpolygon thành Hatch.

Bản thân các Mpolygon trong file của mình do cadmap Improt từ Mic.

Nếu trên Mic save as qua cad thì nó lại là Hatch.

 

Không biết bác muốn chuyển...

>>

Cám ơn Tue_NV

Vì mình tinh chuyển qua Microstation nhưng phần mềm này không hiểu Mpolygon bằng Hatch nên mình dự định chuyển Mpolygon thành Hatch.

Bản thân các Mpolygon trong file của mình do cadmap Improt từ Mic.

Nếu trên Mic save as qua cad thì nó lại là Hatch.

 

Không biết bác muốn chuyển Hatch có Partern nào?

Tue_NV chuyển giúp bác sang dạng SOLID

Code đây bác :

(defun c:M->H (/ count ss ename Tue-ss-new Tue-explode)
(defun Tue-ss-new(lst / Reslst e include)
  (mapcar 'set '(e include) lst)
  (if include (setq Reslst (list e)) (setq Reslst '()))
  (while (setq e (entnext e))
    (if (null (wcmatch (strcase (cdr(assoc 0 (entget e)))) "MPOLYGON,POLYLINE,ATTRIB,SEQEND"))
          (setq Reslst (append Reslst (list e)))
    )
  )
Reslst
)
(defun Tue-explode (ename / ss-explode elast);;Tue-dxf Tue-ss-new Tue-ss-list
      (setq elast (entlast))
      (Command "Explode" ename)
      (setq ss-explode (Tue-ss-new (list elast) ) )
)
;;;main
(setq count -1)
(if (setq ss (ssget '((0 . "MPOLYGON"))))
     (while (setq ename (ssname ss (setq count (1+ count))))
       (setq ename (Tue-explode ename))
       (command "._hatch" "S")
          (Foreach x ename (command x))
       (command "")
     )
)
)

<<

Filename: 318412_m-%3Eh.lsp
Tác giả: hiepttr
Bài viết gốc: 318417
Tên lệnh: ktcv
Tổng hợp các lisp thường dùng cho dân CƠ KHÍ & CẤP TỐC THOÁT NƯỚC

Thì đây haanh:

;Lisp khai trien canh vit
(defun c:KTCV( / Rnho Rlon P S Dng Dtr x y Dtb)
(defun ch(a b) (sqrt (+ (* a a) (* b b))))
;====
(setq Rnho (getdist "\nNhap ban kinh nho (r): ")
	  Rlon (getdist "\nNhap ban kinh lon (R): ")
	  P (getdist "\nNhap buoc vit (P): ")
	  S (getdist "\nNhap chieu day tam thep (S): "))
(cond ((and Rnho Rlon P S)
	(setq Dng (/ (ch (* 2 pi Rlon) P) pi)
		  Dtr (/ (ch (* 2 pi Rnho) P) pi)
		  x (sqrt (- (* (- Rlon Rnho) (-...
>>

Thì đây haanh:

;Lisp khai trien canh vit
(defun c:KTCV( / Rnho Rlon P S Dng Dtr x y Dtb)
(defun ch(a b) (sqrt (+ (* a a) (* b b))))
;====
(setq Rnho (getdist "\nNhap ban kinh nho (r): ")
	  Rlon (getdist "\nNhap ban kinh lon (R): ")
	  P (getdist "\nNhap buoc vit (P): ")
	  S (getdist "\nNhap chieu day tam thep (S): "))
(cond ((and Rnho Rlon P S)
	(setq Dng (/ (ch (* 2 pi Rlon) P) pi)
		  Dtr (/ (ch (* 2 pi Rnho) P) pi)
		  x (sqrt (- (* (- Rlon Rnho) (- Rlon Rnho)) (/ (* (- Dng Dtr) (- Dng Dtr)) 4.)))
		  y (/ (* x 0.5 S) (- Rlon Rnho))
		  Dtb (- Dng (* 2 y))
		  Dtr_tb (- Dtr (* 2 y))
		  )
		  )
)
(princ (strcat "\nDtb: " (rtos Dtb 2 4) "\tdtb: " (rtos Dtr_tb 2 4)))
(princ)
)
;========================================

p/s: Có muốn vui cũng chẳng vui nỗi ^^ Vì haanh "rặn" ... làm mình ngóng dài hết cả cổ :D :D :D


<<

Filename: 318417_ktcv.lsp
Tác giả: trinhhoanghieu090
Bài viết gốc: 318401
Tên lệnh: ps2
Nhờ giúp đỡ

Sau một hồi mày mò và được sự giúp đỡ của các bác @phamthanhbinh, @ketxu, @tot77 đây là tác phẩm đầu tay của em :

 

(defun c:PS2()

(setvar 'angdir 1)

;;;==============================================
;;; ve tau
;;;==============================================

(setq gh (getreal "\n Please Enter Vessel Heading <0d>:") )
(if (= gh nil) (setq gh 0 ))

(setq dtau (getpoint "\n Pick Vessel...
>>

Sau một hồi mày mò và được sự giúp đỡ của các bác @phamthanhbinh, @ketxu, @tot77 đây là tác phẩm đầu tay của em :

 

(defun c:PS2()

(setvar 'angdir 1)

;;;==============================================
;;; ve tau
;;;==============================================

(setq gh (getreal "\n Please Enter Vessel Heading <0d>:") )
(if (= gh nil) (setq gh 0 ))

(setq dtau (getpoint "\n Pick Vessel Position:"))
(command "insert" (strcat"*""PS") dtau 1 gh)


;;; ve day neo
;;;==============================================
;;; nhap so lieu neo truoc lai, sau lai
;;;===============================================
(mapcar 'set '(gt lt)
    (read (strcat "(" (getstring t "\n Nhap Goc Mo & Chieu Dai Day Neo Truoc Lai(cach nhau boi space) :") ")"))
)
(mapcar 'set '(gs ls)
    (read (strcat "(" (getstring t "\n Nhap Goc Mo & Chieu Dai Day Neo Sau Lai(cach nhau boi space) :") ")"))
)
(setq     ga (+ (+ gh 180) (* gs 0.5))
    gc (- (+ gh 180) (* gs 0.5))
    gb (- gh (* gt 0.5))
    gd (+ gh (* gt 0.5))
)
(setq   ga (- ga 90) ga(- ga)
        gb (- gb 90) gb(- gb)
        gc (- gc 90) gc(- gc)
        gd (- gd 90) gd(- gd)
)
(if (< ga 0) (setq ga (+ ga 360)))
(if (< gb 0) (setq gb (+ gb 360)))
(if (< gc 0) (setq gc (+ gc 360)))
(if (< gd 0) (setq gd (+ gd 360)))

(if (>= ga 360) (setq ga (- ga 360)))
(if (>= gb 360) (setq gb (- gb 360)))
(if (>= gc 360) (setq gc (- gc 360)))
(if (>= gd 360) (setq gd (- gd 360)))

;;; Ve day neo bang toa do cuc
;;;===============================================

(command "line" "non" (setq pb (getpoint "\nChon diem Neo AP2: ")) "non" (polar pb (/ (* pi gb) 180) lt) "")
(command "line" "non" (setq pd (getpoint "\nChon diem Neo AS4: ")) "non" (polar pd (/ (* pi gd) 180) lt) "")
(command "line" "non" (setq pa (getpoint "\nChon diem Neo AP1: ")) "non" (polar pa (/ (* pi ga) 180) ls) "")
(command "line" "non" (setq pc (getpoint "\nChon diem Neo AS3: ")) "non" (polar pc (/ (* pi gc) 180) ls) "")

)

http://www.cadviet.com/upfiles/3/133631_ps.dwg

 

Các bác xem, sửa lại cho gọn và thêm cho em một số chức năng sau đây vào lisp với:

 

-  Đoạn code này :

(mapcar 'set '(gt lt)
(read (strcat "(" (getstring t "\n Nhap Goc Mo & Chieu Dai Day Neo Truoc Lai(cach nhau boi space) :") ")"))

Các bác sửa lại cho các giá trị nhập vào cách nhau vào dấu phẩy và bấm dấu cách (space bar) là thực hiện tiếp

- Tất cả các đối tượng này được vẽ từ lệnh lisp vào layer "Anchor_Pattern" . Nếu chưa có thì tạo mới, có rồi thì add luôn vào.

- Viết các giá trị góc và cạnh trên đường thẳng vừa vẽ bằng tọa độc cực, ví dụ:

(command "line" "non" (setq pb (getpoint "\nChon diem Neo AP2: ")) "non" (polar pb (/ (* pi gb) 180) lt) "")

 

thì viết giá trị gb, lt lên cạnh đó với chiều cao text high mặc định. file kết quả như ví dụ:

http://www.cadviet.com/upfiles/3/133631_mau_3.dwg

 

 

 

 


<<

Filename: 318401_ps2.lsp
Tác giả: trinhhoanghieu090
Bài viết gốc: 318511
Tên lệnh: cxy
Lisp ghi toạ độ điểm ra màn hình !!!
(defun C:cxy ()
(setvar "cmdecho" 0)
(setq h (getreal "\n Nhap chieu cao Text< 5 >: "))
(if (= h nil)  (Setq h 5 ))
(setq pt1 (getpoint "\n Pick diem can lay toa do: "))
(if pt1
(progn
(setq pt2 (getpoint pt1 "\n Pick diem ghi toa do: "))
(if pt2
(progn
(setq txtx (strcat "X = " (rtos (car pt1) 2 2) " m"))
(setq txty (strcat "Y= " (rtos (cadr pt1) 2 2)" m"))
(command "Mtext" pt2 "h" h pt2 txtx txty "")
)
)
)
)
(setvar "cmdecho"...
>>
(defun C:cxy ()
(setvar "cmdecho" 0)
(setq h (getreal "\n Nhap chieu cao Text< 5 >: "))
(if (= h nil)  (Setq h 5 ))
(setq pt1 (getpoint "\n Pick diem can lay toa do: "))
(if pt1
(progn
(setq pt2 (getpoint pt1 "\n Pick diem ghi toa do: "))
(if pt2
(progn
(setq txtx (strcat "X = " (rtos (car pt1) 2 2) " m"))
(setq txty (strcat "Y= " (rtos (cadr pt1) 2 2)" m"))
(command "Mtext" pt2 "h" h pt2 txtx txty "")
)
)
)
)
(setvar "cmdecho" 1)
(princ)
)

Chào các cao thủ Lisper, sau một hồi mày mò và tìm hiểu trên diễn đàn em cũng cho ra lò được cái lisp ghi tọa độ như trên. Có thể nói là dùng cũng tạm được, nhưng em muốn các bác chỉ giáo cho em để hoàn thiện hơn. Trong đoạn code:

 

(setq h (getreal "\n Nhap chieu cao Text< 5 >: "))
(if (= h nil) (Setq h 5 )

 

thay vì nếu khi nhập chiều cao text để mặc định là 5 thì em muốn nó lấy giá trị mình vừa nhập vào lúc trước khi sử dụng lisp này. ví dụ như trong trường hợp mình dùng lệnh liên tục, gọi lisp lần đầu mình nhập vào là 100 hay bất kỳ giá trị nào khác lặp lại các lần sau nó gán cho bằng giá trị đó luôn chỉ phải bấm enter không phải gõ lại nữa. thanks


<<

Filename: 318511_cxy.lsp
Tác giả: thanhduan2407
Bài viết gốc: 318559
Tên lệnh: cxy
Lisp ghi toạ độ điểm ra màn hình !!!
(defun C:cxy ( / pt1 pt2 txtx txty)
(setvar "cmdecho" 0)
(or *chieucao* (setq *chieucao* 1))
(setq chieucao (getreal (strcat "\n Chieu cao text <"
			  (rtos *chieucao* 2 2)
			 "> :"
		  )
	 )
)
(if (not chieucao) (setq chieucao *chieucao*) (setq *chieucao* chieucao))
(setq pt1 (getpoint "\n Pick diem can lay toa do: "))
(if pt1
	(progn
		(setq pt2 (getpoint pt1 "\n Pick diem ghi toa do: "))
		(if pt2
			(progn
				(setq txtx (strcat "X = " (rtos (car...
>>
(defun C:cxy ( / pt1 pt2 txtx txty)
(setvar "cmdecho" 0)
(or *chieucao* (setq *chieucao* 1))
(setq chieucao (getreal (strcat "\n Chieu cao text <"
			  (rtos *chieucao* 2 2)
			 "> :"
		  )
	 )
)
(if (not chieucao) (setq chieucao *chieucao*) (setq *chieucao* chieucao))
(setq pt1 (getpoint "\n Pick diem can lay toa do: "))
(if pt1
	(progn
		(setq pt2 (getpoint pt1 "\n Pick diem ghi toa do: "))
		(if pt2
			(progn
				(setq txtx (strcat "X = " (rtos (car pt1) 2 2) " m"))
				(setq txty (strcat "Y= " (rtos (cadr pt1) 2 2)" m"))
				(command "Mtext" pt2 "h" chieucao pt2 txtx txty "")
			)
		)
	)
)
(setvar "cmdecho" 1)
(princ)
)


<<

Filename: 318559_cxy.lsp
Tác giả: quansla
Bài viết gốc: 318647
Tên lệnh: thunghiem
Bẫy lỗi khi sử dụng lệnh (grread ...)

http://www.cadviet.com/forum/topic/14210-hoi-ve-lisp-thuat-toan-y-tuong-coding/page-100
Bẫy lỗi bằng hàm *error

Không rõ bác đã thử chưa với Cad 2012 ở máy em code như thế này không có khả năng bắt lỗi

(defun...
>>

http://www.cadviet.com/forum/topic/14210-hoi-ve-lisp-thuat-toan-y-tuong-coding/page-100
Bẫy lỗi bằng hàm *error

Không rõ bác đã thử chưa với Cad 2012 ở máy em code như thế này không có khả năng bắt lỗi

(defun c:thunghiem( / myerr old_err gr ga gb roop)
(defun myerr (msg)
(if msg (princ (strcat "\nBay loi thu nghiem: " msg)))
(if old_err (setq *error* old_err))
(princ))
(setq old_err *error* *error* myerr)
(setq roop T)
(while roop
(princ "\n Bat ky de kiem tra= .....\tSpace/Enter=Quit:")
(setq gr (grread nil (+ 2 4 8) 2)
ga (car gr)
gb (cadr gr))
(cond
((member gr '((2 13)(2 32))) ;; "" Space or Enter
(princ"\nBan da chon quit")
(setq roop nil))
(T
(princ "\nGia tri gr la:")
(princ gr)
(princ "\tGia tri ga la:")
(princ ga)
(princ "\tGia tri gb la:")
(princ gb))
)
)
(if old_err (setq *error* old_err))
(princ)
)




Trong suốt quá trình thực hiện lệnh, việc nhấn phím bất kỳ chuột trái/ phải code vẫn thực hiện, nhưng nếu ấn ESC là cần tắt hoàn toàn Cad mới thoát khỏi lỗi
<<

Filename: 318647_thunghiem.lsp
Tác giả: luhaivinh
Bài viết gốc: 318721
Tên lệnh: bbhang
Chương 5.5 : Bài tập

hahaha.Cuối cùng cũng hoàn thành câu 5. Thật là hai não quá  đi... :lol:

Mọi người quánh giá giùm mình với.

Thế này đã qua ải chưa vậy a Ket... :P

 

(defun c:bbhang(/ lst1 lst2 lst3 lst4 spham ttien slban slcon tbao) ;cau 5 
  (setq lst1 '(("A" . 3000)("B" . 4000)("C" . 5000)))
  (setq lst2 '(("A" . 15)("B" . 8)("C" . 2)))
  (setq lst3 (list "A" "C" "B" "B" "C" "A" "A"))
  (setq spham (mapcar...
>>

hahaha.Cuối cùng cũng hoàn thành câu 5. Thật là hai não quá  đi... :lol:

Mọi người quánh giá giùm mình với.

Thế này đã qua ải chưa vậy a Ket... :P

 

(defun c:bbhang(/ lst1 lst2 lst3 lst4 spham ttien slban slcon tbao) ;cau 5 
  (setq lst1 '(("A" . 3000)("B" . 4000)("C" . 5000)))
  (setq lst2 '(("A" . 15)("B" . 8)("C" . 2)))
  (setq lst3 (list "A" "C" "B" "B" "C" "A" "A"))
  (setq spham (mapcar '(lambda (x) (car x)) lst2))
  (setq lst4 (mapcar '(lambda (y) (cdr (assoc y lst1))) lst3))
  (setq ttien (princ (strcat "\nTong tien ban duoc trong ngay la: " (itoa (apply '+ lst4)))))
  (setq slban (mapcar '(lambda (z) (cons z (apply '+ (mapcar '(lambda (j) (if (= j z) 1 0)) lst3)))) spham))
  (setq slcon (mapcar '(lambda (m) (cons m (- (cdr (assoc m lst2)) (cdr (assoc m slban))))) spham))
  (setq tbao (mapcar '(lambda (n) (if (= (cdr n) 0)(princ (strcat "\nSan pham " (car n) ": Da het hang!"))(princ (strcat "\nSo luong san pham " (car n) " con trong kho: " (itoa (cdr n)))))) slcon))
  (princ))


<<

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

Bạn thử với LISP này xem. ^^

(defun c:tdt( / ss lst fn fid lstEn)
(vl-load-com)
(setvar "hpgaptol" 0.5)
(setq Olmode (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setq Elast (entlast))
(setq Clor (getvar "CECOLOR"))
(setvar "CECOLOR" "2")
(while
	(setq pt (getpoint "\n Pick diem trong vung kin :"))
	(vl-cmdf  "-boundary" pt "")
)
(while
          (setq Elast  (entnext Elast ))
	  (setq lstEn (reverse (cons Elast lstEn)))
)
(setq h (LM:GetXWithDefault...
>>

Bạn thử với LISP này xem. ^^

(defun c:tdt( / ss lst fn fid lstEn)
(vl-load-com)
(setvar "hpgaptol" 0.5)
(setq Olmode (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setq Elast (entlast))
(setq Clor (getvar "CECOLOR"))
(setvar "CECOLOR" "2")
(while
	(setq pt (getpoint "\n Pick diem trong vung kin :"))
	(vl-cmdf  "-boundary" pt "")
)
(while
          (setq Elast  (entnext Elast ))
	  (setq lstEn (reverse (cons Elast lstEn)))
)
(setq h (LM:GetXWithDefault getreal "\nNhap chieu cao chu: " '*h* (atof "1")))
(foreach e lstEn
  (entmake (list (cons 0 "TEXT") (cons 10 (mid e)) (cons 40  h) (cons 1  (rtos (Area e) 2 2))))
  (entdel e)
)
(setvar "CECOLOR" Clor)
(setvar "OSMODE" 193)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:dtd( / ss lst fn fid lstEn);Do dien tich
(vl-load-com)
(setvar "hpgaptol" 0.5)
(setq Olmode (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setq Elast (entlast))
(setq Clor (getvar "CECOLOR"))
(setvar "CECOLOR" "2")
(setq ss (ssget (list (cons 0  "TEXT"))))
  (progn
      (setq ss (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex ss))))
      (foreach item ss
	   (setq temp  (entget item))
	   (setq   Tdo (TD:Text-Base item ))
	   (setq     h (cdr (assoc 40 temp)))
	   (setq   Pnt   (list (car Tdo) (cadr Tdo)))
	   (vl-cmdf  "-boundary" Pnt "")
	   (setq Elast (entlast))
	   (setq Dtich (rtos (Area Elast) 2 2))
           (setq Poin (polar Pnt  (/ (* 3 pi) 2) (* 2 h)))
;;;	   (entmake (list (cons 0 "TEXT") (cons 10 (mid Elast)) (cons 40  h) (cons 1  Dtich)))
	   (entmake (list (cons 0 "TEXT") (cons 10 Poin) (cons 40  h) (cons 1  Dtich)))
      )
     )
(setvar "CECOLOR" Clor)
(setvar "OSMODE" 193)
(princ)
)




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun Area (ent)
(setvar "hpgaptol" 0.1)
(vla-get-area (vlax-ename->vla-object ent))
)
(defun mid (ent / p1 p2)
	(vla-getboundingbox (vlax-ename->vla-object ent) 'p1 'p2)
	(setq p1 (vlax-safearray->list p1)
				p2 (vlax-safearray->list p2)
				pt (mapcar '+ p1 p2)
				pt (mapcar '* pt '(0.5 0.5 0.5))
	)
	pt
)
(defun wtxt_l(txt p / sty d h1 h2 wf h) ;;;Write txt on graphic screen at p
(setq    sty (getvar "textstyle")    
d (tblsearch "style" sty)    
h1 (cdr (assoc 40 d))    
h2 (cdr (assoc 42 d))    
wf (cdr (assoc 41 d)))
(if (> h1 0) (setq h h1) (setq h h2))
(entmake (list (cons 0 "TEXT") (cons 7 sty) (cons 40 h) (cons 41 wf)(cons 72 4)(cons 11 p)(cons 62 4) (cons 1 txt) (cons 10 p)))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun TD:Text-Base (ent)
  (setq Ma10  (cdr (assoc 10 (entget ent))))
  (setq Ma11  (cdr (assoc 11 (entget ent))))
  (setq X11 (car Ma11))
  (setq Ma71  (cdr (assoc 71 (entget ent))))
  (setq Ma72  (cdr (assoc 72 (entget ent))))
  (if (or (and (= Ma71 0) (= Ma72 0) (= X11 0))
	  (and (= Ma71 0) (= Ma72 3) )
	  (and (= Ma71 0) (= Ma72 5) )
      )
    Ma10
    Ma11
   )
)


(defun LM:GetXWithDefault ( _function _prompt _symbol _default / _toString )
	(setq _toString
		(lambda ( x )
			(cond
				( (eq getangle _function) (angtos x) )
				( (eq 'REAL (type x)) (rtos x) )
				( (eq 'INT (type x)) (itoa x) )
				( x )
			)
		)
	)

	(set _symbol
	(
	(lambda ( input ) (if (or (not input) (eq "" input)) (eval _symbol) input))
	(_function (strcat _prompt "<" (_toString (set _symbol (cond ( (eval _symbol) ) ( _default )))) "> : "))
	)
	)
)

<<

Filename: 318759_tdt_dtd.lsp
Tác giả: nhoclangbat
Bài viết gốc: 318859
Tên lệnh: mtll
Lisp tạo viewport từ khung chọn bên model.

- Chào bạn Conghoa ^^, nhoc đã chỉnh đc phần thô, chọn khung bên model rùi tạo viewport bên layout tương ứng với khu đã chọn và tỉ lệ do mình nhập như hình nhoc đăng, nhoc chỉnh theo ý tưởng lúc đầu của nhoc giống hình đó là mình có sẵn các khung bên model , gọi lệnh sẽ hỏi chọn khung sau đó nhập tỉ lệ cho khung đó, nhập xong sẽ tự chuyển qua layout cho mình chọn điểm đặt khung chọn xong...

>>

- Chào bạn Conghoa ^^, nhoc đã chỉnh đc phần thô, chọn khung bên model rùi tạo viewport bên layout tương ứng với khu đã chọn và tỉ lệ do mình nhập như hình nhoc đăng, nhoc chỉnh theo ý tưởng lúc đầu của nhoc giống hình đó là mình có sẵn các khung bên model , gọi lệnh sẽ hỏi chọn khung sau đó nhập tỉ lệ cho khung đó, nhập xong sẽ tự chuyển qua layout cho mình chọn điểm đặt khung chọn xong quay trở về lại model cho mình chọn khung tiếp theo, cứ tiếp tục vậy khi nào xong thì phải chuột kết thúc lệnh, bạn test trước xem nhé ^^

(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 _layer2 ( name colour )
    (if (null (tblsearch "LAYER" name))
        (entmake
            (list
               '(0 . "LAYER")
               '(100 . "AcDbSymbolTableRecord")
               '(100 . "AcDbLayerTableRecord")
               '(70 . 0)
                (cons 2 name)
                (cons 62 colour)
            )
        )
    )
)
; ham luu gia tri
(defun getvalue ( a giatri dongnhac / astr) 
(or a (setq a giatri))
(cond
	((= (type a) 'INT) (setq a (cond ((getint (strcat "\n" dongnhac "(" (itoa a) ") :")))(a))))
	((= (type a) 'REAL) (setq a (cond ((getreal (strcat "\n" dongnhac "(" (rtos a 2 0) ") :")))(a))))
	((= (type a) 'STR) (setq a (cond ((= "" (setq astr (getstring 1 (strcat "\n" dongnhac " (" a "): ")))) a) (astr))))
))
;;;;
;============================================================
;========LISP TAO VIEWPORT TREN LAYOUT BANG CACH CHON O MODEL========
;=========================REV4ii=====================================
(defun C:mtll( / os lst khung X_min Y_min X_max Y_max X index taphop pt1)
(vl-load-com)
(if (null (tblsearch "LAYER" "khung")) (_layer2 "Khung" 3))
  (command "UNDO" "BE")
  (setq os(getvar "OSMODE"))
  (setvar "OSMODE" 0)
  (while (/= (setq taphop (ssget "+.:E:S" '((0 . "LWPOLYLINE")))) nil)
  (progn
   (setq tyleVT (getvalue tyleVT 1000.0 "Nhap ty le ban do: "))
  (command "LAYOUT" "S" "Layout1")
  (setq pt1 (getpoint "\nchon diem dat khung"))
  (command "ZOOM" "E")
    (setq khung (ssname taphop 0))
    (setq lst (cdr (acet-geom-vertex-list khung)))
    (setq X_min 1000000000
      Y_min 1000000000
      X_max -1000000000
      Y_max -1000000000)
    (foreach a lst
      (if (< (car a) X_min) (setq X_min (car a)))
      (if (< (cadr a) Y_min) (setq Y_min (cadr a)))
      (if (> (car a) X_max) (setq X_max (car a)))
      (if (> (cadr a) Y_max) (setq Y_max (cadr a)))
      )
    (command "LAYOUT" "S" "Layout1")
    (command "ZOOM" "W" (list X_min Y_min) (list X_max Y_max))
    (makepline lst 1 "Khung" nil nil nil)
    (command "MOVE" (entlast) "" (list X_min Y_min) (list (car pt1) 0))
    (command "ZOOM" "W" (list 0 0) (list (+ (car pt1) 100) 0))
    (command "SCALE" (entlast) "" (list (car pt1) 0) (/ 1000 tyleVT))
    (command "MVIEW" "O" (entlast))
    (command "MSPACE")
    (command "ZOOM" (list X_min Y_min) (list X_max Y_max))
    (command "PSPACE")
	(command "MVIEW" "L" "on" (entlast) "")
    (command "ZOOM" "W" (list 0 0) (list (+ (car pt1) 100) 0))
    (command "MODEL")
    ) ;ene progn while
	) ; end while
  (command "MODEL")
  (command "UNDO" "END")
  (setvar "OSMODE" os)
  (princ)
  )
;=======================================================


<<

Filename: 318859_mtll.lsp
Tác giả: hiepttr
Bài viết gốc: 318273
Tên lệnh: mt
vẽ đường chú thích thanh thép (đường mũi tên chỉ)

Sorry cdhn !

 

Mấy hôm nay do mình phải nhảy như sóc trong công việc & việc học lisp nên không chú tâm lắm trong code

 

Nên mình bỏ sót mất trường hợp khi bản vẽ đã bị thay đổi UCS (không còn là World), hoặc khi đường dóng không cắt thanh thép

 

Dẫn đến các sai sót về tọa đọ điểm ... >>> kết quả là các lỗi mà bạn đã nêu...

>>

Sorry cdhn !

 

Mấy hôm nay do mình phải nhảy như sóc trong công việc & việc học lisp nên không chú tâm lắm trong code

 

Nên mình bỏ sót mất trường hợp khi bản vẽ đã bị thay đổi UCS (không còn là World), hoặc khi đường dóng không cắt thanh thép

 

Dẫn đến các sai sót về tọa đọ điểm ... >>> kết quả là các lỗi mà bạn đã nêu trên.

 

Nay mình test lại, đã phát hiện lỗi & fix dưới đây:

 

p/s: Nếu bạn chạy lisp trên bản vẽ bạn đã từng chạy nó mà vẫn xảy ra lỗi (ko thấy có mũi tên - chính xác là mũi tên insert ko đúng vị trí) thì tìm và xóa hết block có tên "mui_ten_hiep" >>> dùng lệnh PU để xóa block này rồi chạy lại lisp nhé !

;lisp ve mui ten ghi chu thep
(defun c:MT( / temperr errorTrap lst_va old lay lay_thep ss pt1 pt2 tl ent1 pt lst_pt)
;ham bay loi
(setq temperr *error*)
(defun errorTrap (msg)
    (if old (mapcar 'setvar lst_va old))
	(if lay (setvar 'clayer lay))
	(cond
		((tblsearch "ucs" "save_ucs") 
			(command "ucs" "na" "r" "save_ucs")
			(command "ucs" "na" "d" "save_ucs")
			)
	)
    (setq *error* temperr)
	(princ "\n*** Da set lai bien, OK ! ***")
    (princ)
)
(setq *error* errorTrap)
;======het ham bay loi = P1 ============================
(setq lst_va '("osmode" "cmdecho" "AUNITS")
	  old (mapcar 'getvar lst_va))
;=================
(if (not(tblsearch "layer" "DONG_MAU_DO")) (MakeLayer "DONG_MAU_DO" 1 nil nil T))
(setq lay (getvar 'clayer))
(setvar 'clayer "DONG_MAU_DO")
;=================
(command "ucs" "na" "s" "save_ucs")
(command "ucs" "w")
(cond ((not(tblsearch "block" "mui_ten_hiep"))
			(entmake (list
							'(0 . "TRACE")
							'(100 . "AcDbEntity") 
							;(cons 8 "0")
							'(100 . "AcDbTrace") 
							'(10 0 0 0) 
							'(11 0 0 0) 
							'(12 -2.5 -0.5 0) 
							'(13 -2.5 0.5 0)
							)
			)
			(command "-block" "mui_ten_hiep" '(0 0 0) (entlast) "")
			))
;=================
(setq lay_thep (assoc 8 (entget (car (entsel "\nChon thanh thep mau: ")))))
(prompt "\nChon cac thanh thep can ghi chu thich !")
(setq ss (ssget (append '((0 . "LINE,LWPOLYLINE")) (list lay_thep)))
	  pt1 (getpoint "\nXac dinh 2 diem tren duong dong ghi chu !\nChon diem goc: ")
	  pt2 (getpoint pt1 "\nChon diem phia ngon mui ten: ")
	  )
(mapcar 'setvar lst_va '(0 0 3))
(setq #tl# (NGT #tl# 1.0 getreal "Nhap ti le "))
(if (and ss pt1 pt2 #tl#)
	(progn
		(MAKELINE pt1 pt2 nil nil nil nil nil)	  
		(setq ent1 (entlast))
		(foreach elem (ss2lst ss)
			(setq lst1 (acet-geom-intersectwith ent1 elem 3)
				  pt (car (vl-sort lst1 '(lambda (x y) (< (distance pt1 x) (distance pt1 y)))))
				  lst_pt (cons pt lst_pt))
			(command "-insert" "mui_ten_hiep" "S" (* 1.5 #tl#) "R" (angle pt1 pt2) pt)
			)	;for
		(setq lst_pt (vl-sort lst_pt '(lambda (x y) (> (distance pt1 x) (distance pt1 y)))))
		(entmod (subst (cons 11 (car lst_pt)) (assoc 11 (setq info (entget ent1))) info))
		)
	(princ "\n*** Dau vao chu hop ly ***")
)	;if
(command "ucs" "na" "r" "save_ucs")
(command "ucs" "na" "d" "save_ucs")
(setq *error* temperr)
(setvar 'clayer lay)
(mapcar 'setvar lst_va old)
(princ)
)
;=================================
(defun MakeLine (PT1 PT2 Linetype LTScale Layer Color 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 62 (if Color Color 256))									
				(cons 10 PT1)	(cons 11 PT2)))
)
;===================================
(defun ss2lst (ss / ename i lst)
;chuyen ss thanh list
(setq i 0)
(repeat (sslength ss)
	(setq ename (ssname ss i)
		  i (1+ i)
		  lst (cons ename lst))
)
(reverse lst)
)
;================================
(defun MakeLayer (name color linetype lineWeight plot)	
(entmakex (list '(0 . "LAYER")								 
				(cons 100 "AcDbSymbolTableRecord")								 
				(cons 100 "AcDbLayerTableRecord")								 
				(cons 2 name)								 
				(cons 70 0)								 
				(cons 62 (if color color 7))								 
				(cons 6 (if linetype linetype "Continuous"))								 
				(cons 290 (if plot 1 0))								 
				(cons 370 (if lineWeight (fix (* 100 lineWeight)) -3))))
)
;=================================
(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)
	)
	)
)

<<

Filename: 318273_mt.lsp
Tác giả: gia_bach
Bài viết gốc: 318895
Tên lệnh: mc
Nhờ các anh sửa giúp lisp chuyển vị trí text sang trái (Justifi : Left)

e muốn chuyển text về "Middle center" thì làm như thế nào ah? a có thể sửa lisp giúp e dk k ah?

Về Middle-Center : 

(defun c:mc (/ obj pt)
  ;; By : Gia_Bach 2014 ;;
  (vl-load-com)
  (if (ssget (list(cons 0 "TEXT")) )
    (vlax-for obj (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-Acad-Object)))
...
>>

e muốn chuyển text về "Middle center" thì làm như thế nào ah? a có thể sửa lisp giúp e dk k ah?

Về Middle-Center : 

(defun c:mc (/ obj pt)
  ;; By : Gia_Bach 2014 ;;
  (vl-load-com)
  (if (ssget (list(cons 0 "TEXT")) )
    (vlax-for obj (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-Acad-Object)))
      (if (/= (vla-get-Alignment obj) 10)
	(progn
	  (setq pt (vla-get-textalignmentpoint obj))
	  (vla-put-alignment obj 10)
	  (vla-put-insertionpoint obj pt) ))))
  (princ))

<<

Filename: 318895_mc.lsp
Tác giả: Tot77
Bài viết gốc: 318937
Tên lệnh: mc
Nhờ các anh sửa giúp lisp chuyển vị trí text sang trái (Justifi : Left)

Trong bộ Express có 1 hàm rất hay, đó là hàm acet-tjust để chuyển justify của text mà không thay đổi vị trí của text. Lệnh trên có thể viết gọn lại như sau.

(defun c:mc ()
  (acet-tjust (ssget (list (cons 0 "TEXT"))) "MC")
  (princ)
)

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

 Cái này không đơn giản đâu nhoc, nó cũng giống bài toán dãn chữ không trùng, dời block không trùng vậy. Thuật toàn là lấy bounding box của text rồi ssget cái window đó xem có bắt cái line nào k, rồi move text cho xa dấn cái line đó cho tới khi không trùng nữa. NÓi thì dễ chứ làm mới khó.

Test thử:

(defun c:gian (/ ss sst ssl ss1 li d1 d2 tm ang eg)
  (defun dxf...
>>

 Cái này không đơn giản đâu nhoc, nó cũng giống bài toán dãn chữ không trùng, dời block không trùng vậy. Thuật toàn là lấy bounding box của text rồi ssget cái window đó xem có bắt cái line nào k, rồi move text cho xa dấn cái line đó cho tới khi không trùng nữa. NÓi thì dễ chứ làm mới khó.

Test thử:

(defun c:gian (/ ss sst ssl ss1 li d1 d2 tm ang eg)
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "*TEXT,*LINE"))))))
sst (vl-remove-if '(lambda (x) (vl-string-search "LINE" (dxf 0 x))) ss)
ssl (vl-remove-if-not '(lambda (x) (vl-string-search "LINE" (dxf 0 x))) ss)
  )
  (foreach v sst   
    (while (and  (not (vla-getBoundingBox (vlax-ename->vla-object v) 'minp 'maxp))
                 (setq li (mapcar 'vlax-safearray->list (list minp maxp))
      ss1 (ssget "C" (car li) (last li) '((0 . "*LINE")))))
      (setq ss1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss1)))
   d1 (dxf 10 v)
   tm (car (vl-sort (mapcar '(lambda (x) (list (distance d1 (setq d2 (vlax-curve-getclosestpointto x d1))) d2)) ss1)
'(lambda (x y) (> (car x) (car y)))))     
   ang (angle (last tm) d1)
   eg (entget v))
      (entmod (subst (cons 10 (polar d1 ang (car tm))) (assoc 10 eg) eg))
    )
  )
  (princ)
)

<<

Filename: 319308_gian.lsp

Trang 179/330

179