Jump to content
InfoFile
Tác giả: ketxu
Bài viết gốc: 227341
Tên lệnh: tor
lisp xoay text theo pline

Quick code cho bạn :

(defun c:tor(/ ob)(vl-load-com)
    ;Xoay text theo 1 duong dan
    ;Ketxu quick code 25/2
    (cond 
        ((and
            (setq ob (entsel "\n\U+0110\U+1ED1i t\U+01B0\U+1EE3ng d\U+1EABn : "))
            (ssget (list (cons 0 "TEXT,MTEXT")))
        )
        (setq ob (car ob))
        (vlax-for obT (vla-get-ActiveSelectionSet...
>>

Quick code cho bạn :

(defun c:tor(/ ob)(vl-load-com)
    ;Xoay text theo 1 duong dan
    ;Ketxu quick code 25/2
    (cond 
        ((and
            (setq ob (entsel "\n\U+0110\U+1ED1i t\U+01B0\U+1EE3ng d\U+1EABn : "))
            (ssget (list (cons 0 "TEXT,MTEXT")))
        )
        (setq ob (car ob))
        (vlax-for obT (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object)))
            (vla-put-Rotation 
                obT
                ((lambda(a)(if (and (> a (/ pi 2.)) (<= a (* pi 1.5)))(+ a pi) a))
                (+ (* 0.5 pi)
                (angle     (setq a (vlax-get obT 'InsertionPoint))
                        (vlax-curve-getclosestpointto ob a T)
                )))
            )
        ))
        (T (alert "L\U+1ED7i thao t\U+00E1c!"))
    )
    (princ)
)

<<

Filename: 227341_tor.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 381709
Tên lệnh: ghct
Lisp Ghép Text Cần Giúp Đỡ

Mục đích của em là xin lisp để nối text trong 2 cột thành 1 cột và ở giữa có dấu – như trong bản vẽ dưới đây ạhttp://www.cadviet.com/upfiles/5/146910_mau_1.dwg

Hề hề hề,

Vậy là bạn muốn cho các cập đôi...

>>

Mục đích của em là xin lisp để nối text trong 2 cột thành 1 cột và ở giữa có dấu – như trong bản vẽ dưới đây ạhttp://www.cadviet.com/upfiles/5/146910_mau_1.dwg

Hề hề hề,

Vậy là bạn muốn cho các cập đôi này sống chung trong một chuồng . Vậy thì thử cái này coi sao.

 

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

 

(defun c:ghct (/ p p1 p2 h ht r1 r2 ls1 ls2 ls3 ss txt)
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq p1 (getpoint "\n Chon diem goc tren ben trai cot 1")
          p2 (getpoint "\n Chon diem goc trên ben trai cot 2")
          h (getdist p2 "\n Chon diem xac dinh chieu cao hang cua bang")
          r1 (getdist p1 "\n Chon diem xac dinh chieu rong cot 1")
          r2 (getdist p2 "\n Chon diem xac dinh chieu rong cot 2")
          ls1 (list)
          ls2 (list)
          ls3 (list)  )
(while (setq ss (ssget "f" (list p1 (list (+ (car p1) r1) (- (cadr p1) h))) (list (cons 0 "*text")) ))
         (setq txt (cdr (assoc 1 (entget (ssname ss 0))))
                   ls1 (append ls1 (list txt))
                   p1 (list (car p1) (- (cadr p1) h)) 
                   ht (cdr (assoc 40 (entget (ssname ss 0)))) )
)
(while (setq ss (ssget "f" (list p2 (list (+ (car p2) r2) (- (cadr p2) h))) (list (cons 0 "*text")) ))
         (setq txt (cdr (assoc 1 (entget (ssname ss 0))))
                   ls2 (append ls2 (list txt))
                   p2 (list (car p2) (- (cadr p2) h))  )
)   
(if (= (length ls1) (length ls2))
    (setq ls3 (mapcar '(lambda (x y) (strcat  x "-" y)) ls1 ls2))
)
(if ls3
    (command "rectangle" (setq p1 (getpoint "\n Chon diem dat bang moi")) (list (+ (car p1) r1 r2) (- (cadr p1) (* h (length ls3))))  )
)
(foreach txt ls3
    (setq p (list (+ (car p1) (/ (+ r1 r2) 2)) (- (cadr p1) (/ h 2))))
    (command "text" "j" "mc" p ht 0 txt)
    (setq p1 (list (car p1) (- (cadr p1) h)))
)
(setvar "osmode" oldos)
(princ)
)    

<<

Filename: 381709_ghct.lsp
Tác giả: thanhduan2407
Bài viết gốc: 381687
Tên lệnh: exl2p
[Yêu Cầu] Cắm Cọc Gpmb Trên 2 Mép Ngoài Taluy Trên Bình Đồ

Em có viết chương trình Extend Line về 2 phía. Không biết ai cần ko? ^^

(vl-load-com)
(defun c:EXL2P (/ OBJPL1 OBJPL2 SSOBJLINE VLAOBJPL1 VLAOBJPL2)
;;;;EXTEND LINE 2 PHIA
  (setq ObjPL1 (car (entsel "\nChon duong chan thu nhat: ")))
  (setq ObjPL2 (car (entsel "\nChon duong chan thu hai ")))
  (setq VlaObjPL1 (vlax-ename->vla-object ObjPL1))
  (setq VlaObjPL2 (vlax-ename->vla-object ObjPL2))
  (setq ssObjLine (LM:ss->ent (ssget...
>>

Em có viết chương trình Extend Line về 2 phía. Không biết ai cần ko? ^^

(vl-load-com)
(defun c:EXL2P (/ OBJPL1 OBJPL2 SSOBJLINE VLAOBJPL1 VLAOBJPL2)
;;;;EXTEND LINE 2 PHIA
  (setq ObjPL1 (car (entsel "\nChon duong chan thu nhat: ")))
  (setq ObjPL2 (car (entsel "\nChon duong chan thu hai ")))
  (setq VlaObjPL1 (vlax-ename->vla-object ObjPL1))
  (setq VlaObjPL2 (vlax-ename->vla-object ObjPL2))
  (setq ssObjLine (LM:ss->ent (ssget (list (cons 0 "LINE")))))
  (foreach eL ssObjLine
    (EntmodLine eL ObjPL1)
    (EntmodLine eL ObjPL2)
  )
  (princ)
)

(defun EntmodLine (ObjLine  ObjPLine /	      VlaLine  VlaPline
		   Lts1	    P1	     P2	      Ds_KC1   Ds_KC2
		   di1	    di2
		  )
  (setq VlaLine (vlax-ename->vla-object ObjLine))
  (setq VlaPline (vlax-ename->vla-object ObjPLine))
  (setq Lts1 (LM:Intersections VlaLine VlaPline acextendboth))
  (setq P1 (acet-dxf 10 (entget ObjLine)))
  (setq P2 (acet-dxf 11 (entget ObjLine)))
  (setq Ds_KC1 (mapcar '(lambda (x) (list (distance P1 x) x)) Lts1))
  (setq Ds_KC2 (mapcar '(lambda (x) (list (distance P2 x) x)) Lts1))
  (setq di1 (car (vl-sort Ds_KC1 '(lambda (x y) (< (car x) (car y))))))
  (setq di2 (car (vl-sort Ds_KC2 '(lambda (x y) (< (car x) (car y))))))
  (if (< (car di1) (car di2))
    (entmod (subst (cons 10 (last di1))
		   (assoc 10 (entget ObjLine))
		   (entget ObjLine)
	    )
    )
    (entmod (subst (cons 11 (last di2))
		   (assoc 11 (entget ObjLine))
		   (entget ObjLine)
	    )
    )
  )
)





;;;; acextendnone
(defun LM:Intersections	(obj1 obj2 mode / l r)
  (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
  (repeat (/ (length l) 3)
    (setq r (cons (list (car l) (cadr l) (caddr l)) r)
	  l (cdddr l)
    )
  )
  (reverse r)
)
(defun LM:ss->ent (ss / i l)
  (if ss
    (repeat (setq i (sslength ss))
      (setq l (cons (ssname ss (setq i (1- i))) l))
    )
  )
)

<<

Filename: 381687_exl2p.lsp
Tác giả: tien2005
Bài viết gốc: 381717
Tên lệnh: gct
Lisp Ghép Text Cần Giúp Đỡ

ý em là để cho đơn giản vấn đề thì em có 2 cột dtext(mtext ) như sau:

1a   b3

2n...

>>

ý em là để cho đơn giản vấn đề thì em có 2 cột dtext(mtext ) như sau:

1a   b3

2n   1-r

sd    3

lsd   1-r

...     ....

bác có thể giúp em sao cho khi đánh lệnh rồi chọn quét tất cả sẽ tạo ra :

1a-b3

2n-1-r

sd-3

lsd-1r

....

 

Bạn thử lisp này

(defun c:gct (/ ss1 ss2 _NHT:sssortXY)
  ;;sap xep cac toi tuong theo X hoac Y
;;ss - selection by ssget
;;dir: T - sap xep theo X tang dan
;;     nil - sap xep theo Y giam dan
;;vla: T/nil
;;return OBJECT/ENAME

(defun _NHT:sssortXY (ss dir vla / lstent)
  ;(setq ss(ssget))
  (if ss
    (progn
    (setq lstent
	   (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
		    (if	dir
		      
		      '(lambda (x y)
			 
			 (< (car (cdr (assoc 10 (entget x))))
			    (car (cdr (assoc 10 (entget y))))
			 )
		       )
		      
		      '(lambda (x y)
			 (> (cadr (cdr (assoc 10 (entget x))))
			    (cadr (cdr (assoc 10 (entget y))))
			 )
		       )
		    )
	   )
    )
    (if vla (setq lstent(mapcar 'vlax-ename->vla-object lstent)) lstent)
    )
    lstent
  )
)
  (command "_.undo" "be")
  (if (and
	(princ "\nChon cac text o cot 1")
	(setq ss1 (ssget '((0 . "text, mtext"))))
	(princ "\nChon cac text o cot 2")
	(setq ss2 (ssget '((0 . "text, mtext"))))
      )
    (mapcar
      '(lambda (x y)
	 (vla-put-textstring
	   x
	   (strcat (vla-get-textstring x) "-" (vla-get-textstring y))
	 )
       )
      (_NHT:sssortXY ss1 nil t)
      (_NHT:sssortXY ss2 nil t)
    )
  )
  (command "_.undo" "e")
  (princ)
  )

<<

Filename: 381717_gct.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 381718
Tên lệnh: test
Lisp Ghép Text Cần Giúp Đỡ

Một cách viết khác, quét 1 phát ( với điều kiện các text trong mỗi cột tương đối ngăn nắp 1 tý ):

(defun c:test (/ ss ent hei lst ls1 ls2 i lse)
(vl-load-com)
(if (setq ss (ssget '((0 . "*TEXT"))))
(progn (repeat (setq i (sslength ss))
(setq ent (ssname ss (setq i (1- i)))
hei (cdr (assoc 40 (entget ent)))
lst (cons (cons (cdr (assoc 10 (entget ent))) (cdr (assoc 1 (entget ent)))) lst)
lst (vl-sort lst...
>>

Một cách viết khác, quét 1 phát ( với điều kiện các text trong mỗi cột tương đối ngăn nắp 1 tý ):

(defun c:test (/ ss ent hei lst ls1 ls2 i lse)
(vl-load-com)
(if (setq ss (ssget '((0 . "*TEXT"))))
(progn (repeat (setq i (sslength ss))
(setq ent (ssname ss (setq i (1- i)))
hei (cdr (assoc 40 (entget ent)))
lst (cons (cons (cdr (assoc 10 (entget ent))) (cdr (assoc 1 (entget ent)))) lst)
lst (vl-sort lst '(lambda (x y) (< (car (car x)) (car (car y)))))))
(foreach x lst
(if (equal (caar x) (caaar lst) (* 0.1 hei))
(setq ls1 (cons (cdr x) ls1))
(setq ls2 (cons (cdr x) ls2))))
(setq lst (mapcar '(lambda (x y) (strcat x "-" y)) ls1 ls2))
(setq i -1)
(while (setq ent (ssname ss (setq i (1+ i))))
(if (member (cdr (assoc 1 (entget ent))) ls2)
(entdel ent)
(setq lse (cons ent lse))))
(mapcar '(lambda (x y) (vla-put-textstring (vlax-ename->vla-object x) y)) lse lst)))
(princ))

<<

Filename: 381718_test.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 381800
Tên lệnh: rtl%C2%A0
[Yêu Cầu]Nhờ Mọi Người Giúp Đỡ Về Lisp Xoay Góc Đoạn Thẳng Và Text

Tại sao phải Vla-Put, Vlax-Put nhiều thế nhỉ ?

Dùng (Vla-Rotate obj center angle) sẽ gọn hơn. (không thay đổi text align)

 


Sửa lại theo chỉ dẫn của bác

Tại sao phải Vla-Put, Vlax-Put nhiều thế nhỉ ?

Dùng (Vla-Rotate obj center angle) sẽ gọn hơn. (không thay đổi text align)

 


Sửa lại theo chỉ dẫn của bác gia_bach:

​(defun c:rtl  (/ mid-point adoc lst lst-line lst-text ss ang dis hei mpt mid stp minp maxp)
 (defun mid-point (p1 p2) (mapcar '(lambda (x1 x2) (/ (+ x1 x2) 2.0)) p1 p2))
 (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object)))
 (prompt "\nSelect LINE, TEXT, MTEXT!")
 (if (setq ss (ssget '((0 . "*TEXT,LINE"))))
  (progn (setq lst (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))))
         (foreach obj  lst
          (if (eq (vla-get-objectname obj) "AcDbLine")
           (setq lst-line (cons obj lst-line))
           (setq lst-text (cons obj lst-text))))
         (vla-endundomark adoc)
         (vla-startundomark adoc)
         ;; Text
         (foreach obj  lst-text
          (vla-getboundingbox obj 'minp 'maxp)
          (setq ang (vlax-get obj 'rotation)
                mpt (vlax-3d-point (mid-point (vlax-safearray->list maxp) (vlax-safearray->list minp))))
          (cond ((or (equal ang (* 0.25 pi) 10e-8)) (vla-Rotate obj mpt (* -0.125 pi)))
                ((or (equal ang (* 1.5 pi)) (equal ang (* 0.5 pi))) (vla-Rotate obj mpt (* -0.25 pi)))
                (t)))
         ;; Line
         (foreach obj  lst-line
          (setq stp (vlax-get obj 'startpoint)
                ang (vla-get-angle obj)
                dis (vla-get-Length obj)
                mid (vlax-3d-point (polar stp ang (* 0.5 dis))))
          (cond ((or (equal ang (* 0.25 pi) 10e-8)
                     (equal ang (* 0.75 pi) 10e-8)
                     (equal ang (* 1.25 pi) 10e-8)
                     (equal ang (* 1.75 pi) 10e-8))
                 (vla-Rotate obj mid (* -0.125 pi)))
                ((or (equal ang (* 0.5 pi)) (equal ang (* 1.5 pi))) (vla-Rotate obj mid (* -0.25 pi)))
                (t)))
         (vla-endundomark adoc)))
 (princ))

P/S: + Cái đầu không được với MText -> Sai.


<<

Filename: 381800_rtl%C2%A0.lsp
Tác giả: nataca
Bài viết gốc: 14894
Tên lệnh: rtl%C2%A0
Ai yêu guitar thì nhào zô
Thêm một bài nữa. Bài này đánh theo ngẫu hứng, chẳng có tên là j và cũng chẳng biết gọi là j. Để xem dân tình phản đối đến đâu <_<
http://www.cadviet.com/upfiles/ok1.mp3

Filename: 14894_rtl%C2%A0.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 381794
Tên lệnh: rtl%C2%A0
[Yêu Cầu]Nhờ Mọi Người Giúp Đỡ Về Lisp Xoay Góc Đoạn Thẳng Và Text

Bạn thử cái này xem (Tuy nhiên Alignment của text chưa trả về ban đầu được nó chuyển sang MiddleCenter ):

(defun c:rtl  (/ adoc lst lst-line lst-text ss ang dis hei mpt mid stp ins bou len minp maxp)
 (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object)))
 (prompt "\nSelect LINE, TEXT, MTEXT!")
 (if (setq ss (ssget '((0 . "*TEXT,LINE"))))
  (progn (setq lst (mapcar...
>>

Bạn thử cái này xem (Tuy nhiên Alignment của text chưa trả về ban đầu được nó chuyển sang MiddleCenter ):

(defun c:rtl  (/ adoc lst lst-line lst-text ss ang dis hei mpt mid stp ins bou len minp maxp)
 (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object)))
 (prompt "\nSelect LINE, TEXT, MTEXT!")
 (if (setq ss (ssget '((0 . "*TEXT,LINE"))))
  (progn (setq lst (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))))
         (foreach obj  lst
          (if (eq (vla-get-objectname obj) "AcDbText")
           (setq lst-text (cons obj lst-text))
           (setq lst-line (cons obj lst-line))))
         (vla-endundomark adoc)
         (vla-startundomark adoc)
         (foreach obj  lst-text
          (setq bou (vla-getboundingbox obj 'minp 'maxp)
                len (- (car (vlax-safearray->list maxp)) (car (vlax-safearray->list minp)))
                ang (vlax-get obj 'rotation)
                hei (vlax-get obj 'height)
                ins (vlax-get obj 'insertionpoint)
                mpt (polar ins ang (* 0.5 len)))
          (vla-put-Alignment Obj acAlignmentMiddleCenter)
          (vla-put-TextAlignmentPoint Obj (vlax-3d-point (polar mpt (+ ang (* 0.5 pi)) (* 0.5 hei))))
          (cond ((or (equal ang (* 0.25 pi) 10e-8)) (vla-put-rotation obj (* 0.125 pi)))
                ((or (equal ang (* 1.5 pi)) (equal ang (* 0.5 pi))) (vla-put-rotation obj (* 0.25 pi)))
                (t)))
         (foreach obj  lst-line
          (setq stp (vlax-get obj 'startpoint)
                ang (vla-get-angle obj)
                dis (vla-get-Length obj)
                mid (polar stp ang (* 0.5 dis)))
          (cond ((or (equal ang (* 0.25 pi) 10e-8)
                     (equal ang (* 0.75 pi) 10e-8)
                     (equal ang (* 1.25 pi) 10e-8)
                     (equal ang (* 1.75 pi) 10e-8))
                 (vlax-put obj 'startpoint (polar mid (* 0.125 pi) (* 0.5 dis)))
                 (vlax-put obj 'endpoint (polar mid (* 1.125 pi) (* 0.5 dis))))
                ((or (equal ang (* 0.5 pi)) (equal ang (* 1.5 pi)))
                 (vlax-put obj 'startpoint (polar mid (* 1.25 pi) (* 0.5 dis)))
                 (vlax-put obj 'endpoint (polar mid (* 0.25 pi) (* 0.5 dis))))
                (t)))
         (vla-endundomark adoc)))
 (princ))

P/S: đường thẳng của bạn phải là LINE.​


<<

Filename: 381794_rtl%C2%A0.lsp
Tác giả: hiepttr
Bài viết gốc: 381923
Tên lệnh: timy
Nội Suy Cao Độ Y Từ Cao Độ X Và Đồ Thị Bằng Pline, Arc

Lâu không được code nên ngứa ngáy viết đại :D

Bạn nên sửa TUT lại cho đúng quy định kẻo bị xóa :D :D :D

(defun c:TIMY ( / lst_va old pl x xl int_pt)
(vl-load-com)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nChon PL! ")
(while (null pl) (prompt "\nChon PL! ") (setq pl (ssget "_+.:E:S" '((0 . "LWPOLYLINE")))))
(setq pl (vlax-ename->vla-object (ssname...
>>

Lâu không được code nên ngứa ngáy viết đại :D

Bạn nên sửa TUT lại cho đúng quy định kẻo bị xóa :D :D :D

(defun c:TIMY ( / lst_va old pl x xl int_pt)
(vl-load-com)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nChon PL! ")
(while (null pl) (prompt "\nChon PL! ") (setq pl (ssget "_+.:E:S" '((0 . "LWPOLYLINE")))))
(setq pl (vlax-ename->vla-object (ssname pl 0)))
(while (setq x (getreal "\nNhap X: "))
		(progn
			(command ".xline" "v" (list x 0) "")
			(setq xl (vlax-ename->vla-object (entlast)))
			(if (setq int_pt (vlax-invoke pl 'intersectwith xl acExtendNone)) (princ (strcat "\ Y = " (rtos (cadr int_pt) 2 3)))
				(princ (strcat "*** \Khong co diem nao co gia tri X= " (rtos x 2 3) " thuoc PL da chon ! ***"))
				)	;if
			(vla-erase xl)
		)
)
(mapcar 'setvar lst_va old)
(princ)
)

<<

Filename: 381923_timy.lsp
Tác giả: hiepttr
Bài viết gốc: 382145
Tên lệnh: timy
Nội Suy Cao Độ Y Từ Cao Độ X Và Đồ Thị Bằng Pline, Arc

Fix trường hợp có nhiều điểm thỏa mãn:

(defun c:TIMY ( / lst_va old pl x xl int_pt len)
(vl-load-com)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nChon PL! ")
(while (null pl) (prompt "\nChon PL! ") (setq pl (ssget "_+.:E:S" '((0 . "LWPOLYLINE")))))
(setq pl (vlax-ename->vla-object (ssname pl 0)))
(while (setq x (getreal "\nNhap X: "))
		(progn
			(command ".xline" "v" (list...
>>

Fix trường hợp có nhiều điểm thỏa mãn:

(defun c:TIMY ( / lst_va old pl x xl int_pt len)
(vl-load-com)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nChon PL! ")
(while (null pl) (prompt "\nChon PL! ") (setq pl (ssget "_+.:E:S" '((0 . "LWPOLYLINE")))))
(setq pl (vlax-ename->vla-object (ssname pl 0)))
(while (setq x (getreal "\nNhap X: "))
		(progn
			(command ".xline" "v" (list x 0) "")
			(setq xl (vlax-ename->vla-object (entlast)))
			(if (setq int_pt (vlax-invoke pl 'intersectwith xl acExtendNone)) 
				(if
					(> (setq len (length int_pt)) 3)
						(repeat (/ len 3)
							(princ (strcat "\     Y = " (rtos (cadr int_pt) 2 3)))
							(setq int_pt (cdddr int_pt))
						)	  ;repeat
					(princ (strcat "\ Y = " (rtos (cadr int_pt) 2 3)))
				)	  ;if trong
				(princ (strcat "*** \Khong co diem nao co gia tri X= " (rtos x 2 3) " thuoc PL da chon ! ***"))
				)	;if ngoai
			(vla-erase xl)
		)
)
(mapcar 'setvar lst_va old)
(princ)
)

Và tám :D :D :D

Lisp trên làm việc theo phương thức:

1, Chọn LWpolyline cho đến lúc được thì

2, Vẽ Xline theo phương đứng (Ver...)

3, Xác định giao giữa PL và XL vừa vẽ ra,

   Nếu có, nếu list điểm giao do hàm vlax-invoke ...trả về  có length >3 thì >>> vòng lặp: in phần tử thứ 2, cắt 3 phần tử đầu list...

                nếu không (tức length = 3) thì in phần tử thứ 2;

  Nếu không giao, in dòng thông báo ...

 

Các hàm vl đều là kết quả mà mình mót được của các bác trên diễn đàn nên mình không dám lải nhải nhiều thêm :D :D :D

Hoặc là:

(defun c:TIMY ( / lst_va old pl x xl int_pt len)
(vl-load-com)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nChon PL! ")
(while (null pl) (prompt "\nChon PL! ") (setq pl (ssget "_+.:E:S" '((0 . "LWPOLYLINE")))))
(setq pl (vlax-ename->vla-object (ssname pl 0)))
(while (setq x (getreal "\nNhap X: "))
		(progn
			(command ".xline" "v" (list x 0) "")
			(setq xl (vlax-ename->vla-object (entlast)))
			(if (not (setq int_pt (vlax-invoke pl 'intersectwith xl acExtendNone))) 
				(princ (strcat "*** \Khong co diem nao co gia tri X= " (rtos x 2 3) " thuoc PL da chon ! ***"))
				(while int_pt
					(princ (strcat "\     Y = " (rtos (cadr int_pt) 2 3)))
					(setq int_pt (cdddr int_pt))
				)	  ;while
			)	  
			(vla-erase xl)
		)
)
(mapcar 'setvar lst_va old)
(princ)
)


<<

Filename: 382145_timy.lsp
Tác giả: quansla
Bài viết gốc: 382564
Tên lệnh: test
@@@dim Nhanh!
?ây b?n
;;

(defun c:test (/ ollay doc lst mspace obj p10 p11 ss)
(vl-load-com)
(setvar "cmdecho" 0)
(setq ollay (getvar "clayer"))
(if (tblsearch "layer" "DIM")
(setvar "clayer" "DIM"))
(if (setq ss (ssget '(( 0 . "LINE"))))
(progn
(command "undo" "begin")
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq doc (vla-get-activedocument(vlax-get-acad-object))
mspace (vla-get-modelspace doc))
(foreach dt lst
(setq obj...
>>
?ây b?n
;;

(defun c:test (/ ollay doc lst mspace obj p10 p11 ss)
(vl-load-com)
(setvar "cmdecho" 0)
(setq ollay (getvar "clayer"))
(if (tblsearch "layer" "DIM")
(setvar "clayer" "DIM"))
(if (setq ss (ssget '(( 0 . "LINE"))))
(progn
(command "undo" "begin")
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq doc (vla-get-activedocument(vlax-get-acad-object))
mspace (vla-get-modelspace doc))
(foreach dt lst
(setq obj (vlax-ename->vla-object dt)
p10 (vla-get-startpoint obj)
p11 (vla-get-endpoint obj))
(setq obj (vla-adddimaligned mspace p10 p11 p10)))
(command "undo" "end")
)
(princ "\nNothing do")
)
(setvar "clayer" ollay)
(setvar "cmdecho" 1)
(princ)
)

<<

Filename: 382564_test.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 382534
Tên lệnh: muco
Nhờ Giúp Đỡ Viết Lisp

 Vâng! Em xin up lên mediafire, nhờ bác giúp e: http://www.mediafire.com/download/osa71d81pllykk9/Sketch.dwg

Hề hề hề,

Dùng thử cái này coi sao nhé,

 

Hề hề hề,

Dùng thử cái này coi sao nhé,

 

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

 

Lưu ý chống chỉ định:

1/- Pline kín là đa giác lõm.

 

3/- Khoảng cách array nhỏ hơn kích thước  ô chọn của con trỏ màn hình Cad.

(defun c:muco (/ a b c p h pls pls1 p1 p2 ss e ssl e1 k1 k2 pc pd pc1 pd1)
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq a (car (entsel "\n Chon pline gioi han"))
          b (car (entsel "\n Chon pline nguon"))
          p (getpoint "\n Chon diem goc")
          h (getdist "\n Chon khoang cach array: ") )
(command "undo" "be")
(command "xline" "v" p "")
(setq c (entlast))
(setq pls (acet-geom-intersectwith c a 0)
         pls (vl-sort pls '(lambda (x y) (< (cadr x) (cadr y))))  
         p1 (car pls)
         p2 (last pls) )
(while (< (cadr p1) (- (cadr p2) h))
     (setq p1 (polar p1 (/ pi 2) h))
     (command "copy" b "" p p1)
    
)
(setq ss (ssadd)
          e (entnext c) )
(while e
       (ssadd e ss)
       (setq e (entnext e))
)
(setq ssl (acet-ss-to-list ss))
(foreach e ssl
      (setq e1 (vlax-ename->vla-object e))
      (if (setq pls1 (acet-geom-intersectwith e a 0))
          (progn
                    (setq k1 (vlax-curve-getparamatpoint e1 (car pls1))
                               pd (vlax-curve-getstartpoint e1)
                               pc (vlax-curve-getendpoint e1)  )
                   (if (cadr pls1)
                       (progn
                             (command "trim" a "" pd "")
                             (command "trim" a "" pc "")
                       )
                       (if (cpip pc a)
                            (command "trim" a "" pd "")
                            (command "trim" a "" pc "")
                       )
                  )
                  (setq pd1 (vlax-curve-getstartpoint e1)
                            pc1 (vlax-curve-getendpoint e1)  )
                  (if (equal pc1 pc 0.001)
                       (command "extend" a "" pc "")
                  )
                  (if (equal pd1 pd 0.001)
                       (command "extend" a "" pd "")
                  )
         )
         (progn
                 (setq pd (vlax-curve-getstartpoint e1)
                           pc (vlax-curve-getendpoint e1)   )
                 (command "extend" a "" pd pc "")
         )
     )
)
(command "erase" b c "")
(command "undo" "e")
(setvar "osmode" oldos)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;
(defun cpip (p  e /  c pls p1 p2 )
(vl-load-com)
(command "xline" "v" p "")
(setq c (entlast))
(setq pls (acet-geom-intersectwith c e 0)
         pls (vl-sort pls '(lambda (x y) (< (cadr x) (cadr y))))  
         p1 (car pls)
         p2 (last pls) )
(command "erase" c "")
(if (and (< (cadr p1) (cadr p)) (< (cadr p) (cadr p2))) t nil)
 
)

<<

Filename: 382534_muco.lsp
Tác giả: pphung183
Bài viết gốc: 382585
Tên lệnh: muc
Nh? Giúp ?? Vi?t Lisp

Rút g?n chút :)  :

(defun c:muc (/ lwpline a b p h c pls p1 p2 ss e ssl lst)
(defun lwpline (lst)
(if (> (length lst) 1) (entmakex (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity")
'(100 . "AcDbPolyline") (cons 90 (length lst)) '(70 . 0) )
(mapcar '(lambda (p) (list 10 (car p) (cadr p))) lst) )))) ;;;;;
(setq a (car (entsel "\n Chon pline gioi han")) b (car (entsel "\n Chon pline nguon")))
(setq p (cadr (acet-geom-vertex-list b)) h (getdist...
>>

Rút g?n chút :)  :

(defun c:muc (/ lwpline a b p h c pls p1 p2 ss e ssl lst)
(defun lwpline (lst)
(if (> (length lst) 1) (entmakex (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity")
'(100 . "AcDbPolyline") (cons 90 (length lst)) '(70 . 0) )
(mapcar '(lambda (p) (list 10 (car p) (cadr p))) lst) )))) ;;;;;
(setq a (car (entsel "\n Chon pline gioi han")) b (car (entsel "\n Chon pline nguon")))
(setq p (cadr (acet-geom-vertex-list b)) h (getdist "\n Chon khoang cach array: "))
(command "undo" "be") (command "xline" "v" "non" p "") (setq c (entlast))
(setq pls (acet-geom-intersectwith c a 2) p1 (cadr pls) p2 (car pls))
(while (< (cadr p1) (- (cadr p2) h)) (setq p1 (polar p1 (/ pi 2) h))
(command "copy" b "" "non" p "non" p1) ) (setq ss (ssadd) e (entnext c))
(while e (ssadd e ss) (setq e (entnext e)) ) (setq ssl (acet-ss-to-list ss))
(foreach e ssl 
(setq pls (acet-geom-intersectwith a e 2) lst (acet-geom-vertex-list e))
(setq lst (append (list (car pls)) (reverse (cdr (reverse (cdr lst)))) (list (cadr pls)))) 
(lwpline lst) (command "erase" e "") )
(command "erase" b c "") (command "undo" "e") (princ))


<<

Filename: 382585_muc.lsp
Tác giả: duongthanh85
Bài viết gốc: 14912
Tên lệnh: mtll%C2%A0
Dùng fím tắt để gọi 1 layer
Bạn có thể dùng các lệnh:
-LT: gọi layer
Sau đó make( chọn tạo layer mới), Set( đưa 1 layer đã có ra làm layer hiện hành),...

Change: để chuyển một đối tượng đã vẽ sang 1 layer khác.

Machprop: để copy định dạng của một đối tượng sang đối tượng khác.

Filename: 14912_mtll%C2%A0.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 381915
Tên lệnh: tdtdat
Nhờ Viết Lisp Chuyển Tọa Độ Góc Ranh Từ File Excel Sang Autocad

Nhờ các Anh, Em viết dùm lisp chuyển tọa độ góc ranh từ file excel sang autocad.

 

Mình thường tìm thửa đất trong bản đồ bằng thủ công rất vất vã, mắt lại kém (viễn thị rồi) mà cái bản tọa độ số nhỏ quá.

 Mình dùng lệnh LINE để tìm thửa đất bằng thủ công như...

>>

Nhờ các Anh, Em viết dùm lisp chuyển tọa độ góc ranh từ file excel sang autocad.

 

Mình thường tìm thửa đất trong bản đồ bằng thủ công rất vất vã, mắt lại kém (viễn thị rồi) mà cái bản tọa độ số nhỏ quá.

 Mình dùng lệnh LINE để tìm thửa đất bằng thủ công như sau:

ví dụ : 

L 

click chọn đại 1 điểm rồi gõ 1, ↵ nhập tọa độ y trước, x sau ( 598838.222,1200196.772) 

                                               2, ↵ 598837.316,1200196.424 

                                              3, ↵  598831.114,2300295.042 

                                               4, ↵ ........

                                             ...................................................

 

Mình nhờ các bác viết dùm mình lisp tên : TDTD.lsp (lệnh gọi : tdtdat) làm công việc bằng tay trên thành lisp khi chay lisp xong nó sẽ xác định được khu đất mình cần tìm bằng đường polyline màu gì cũng được (khác màu trắng để biết được khu đất mình đang tìm).

 

Mình có scan tò chủ quyền phần tọa độ góc ranh(file hình), file excel, và bản đồ số đính kèm (trên bản đồ mình đã lấy tọa độ bằng pp thủ công rồi). Link:

http://www.cadviet.com/upfiles/5/18430_toadogocranh.rar

 

Thanks you các bác nhiều. Kiến thức hạn hẹp xin anh em giúp đỡ. Chân thành cám ơn

Hề hề hề,

Cái này trên diễn đàn có khá nhiều lisp tương tự rồi. Bạn có thể tìm kiếm và chọn cho mình cái ưng ý.

Đây chỉ là một ví dụ để bạn tham khảo.

 

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

 

Lưu ý bạn rằng lisp này chỉ phù hợp với bản vẽ và file excel bạn gửi. các trường hợp khác mình không bảo đảm bới không hiểu về các cách chuyển đổi hệ tọa độ trong trắc địa của bạn.

Trước khi chạy lisp bạn cần lưu file excel thành dạng file csv và xóa bỏ dòng title đầu tiên của bảng. Nếu không lisp sẽ bị lỗi

(defun c:tdtdat (/ oldos fn f str txl p)
(setq oldos (getvar  "osmode" ))
(setvar "osmode" 0)
(command "undo" "be")
(setq  fn (getfiled "Select Data File" "" "csv" 0)
            f (open fn "r")  )
(command "pline" )
(while  (/= (setq str (read-line f)) nil) 
   (setq txl (separate str ",")
            p (list (atof (caddr txl)) (atof (cadr txl))) )
   (command p)
)
(command "")
(close f)
(command "undo" "e")
(setvar "osmode" oldos)
(princ)
)
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun Separate (S sym / i L ch)
(setq i 0 L nil)
(while (< i (strlen S))
      (setq i (1+ i) ch (substr S i 1))
      (if (= ch sym) (progn
(setq
     L (append L (list (substr S 1 (- i 1))))
     S (substr S (1+ i) (- (strlen S) i))
     i 0
)
      )) 
)
(append L (list S))
)
 

<<

Filename: 381915_tdtdat.lsp
Tác giả: Thaistreetz
Bài viết gốc: 199681
Tên lệnh: var1+nil+%3B+lenh+nay+chay+o+ban+ve+thu+nhat var2
- Lisp so sánh sự khác nhau giữa các biến hệ thống của 2 bản vẽ
Đôi khi chúng ta có nhu cầu cần so sánh các thiết lập biến hệ thống giữa 2 bản vẽ xem chúng khác nhau những gì. Đây là lisp mình fát triển từ lisp của bác Doan Van Ha trong bài viết số 2 topic Lisp theo dõi sự thay đổi biến hệ thống trong quá trình vẽ (Topic này cũng do mình lập - em kể công tí :D)
>>
Đôi khi chúng ta có nhu cầu cần so sánh các thiết lập biến hệ thống giữa 2 bản vẽ xem chúng khác nhau những gì. Đây là lisp mình fát triển từ lisp của bác Doan Van Ha trong bài viết số 2 topic Lisp theo dõi sự thay đổi biến hệ thống trong quá trình vẽ (Topic này cũng do mình lập - em kể công tí :D)
Hướng dẫn sử dụng:
- Bạn cần tải lisp này vào cả 2 bản vẽ cần thực hiện so sánh
- Bản vẽ thứ nhất bạn gọi lệnh Var1. kết quả: nó báo cho bạn "Đã lấy được toàn bộ danh sách và giá trị biến hệ thống của bản vẽ thứ nhất"
- Chuyển sang bản vẽ thứ 2 bạn gõ lệnh Var2. lệnh này làm công việc tương tự như của lệnh var1 là lấy toàn bộ giá trị biến hệ thống của bản vẽ thứ 2. Đồng thời nó thực hiện công việc so sánh với giá trị của các biến hệ thống bản vẽ thứ nhất. Nếu biến nào có giá trị khác nó sẽ thống kê ra màn hình cho bạn.

;Chu y: mot so System Variables khong can quan tam, nhu: "CDATE" "DATE" "LASTPROMPT" "TDINDWG" "TDUSRTIMER" "UNDOCTL"...
;;; Edit by Thaistreetz - Cadviet.com
(defun C:var1 nil ; Lenh nay chay o ban ve thu nhat
(setq lstvar1 nil)
(foreach var lstvar
(if (getvar var) (setq lstvar1 (cons (cons var (getvar var)) lstvar1))))
(setq lstvar1 (reverse lstvar1))
(vl-propagate 'lstvar1)
(prompt "\nDa lay duoc toan bo thong tin bien he thong ban ve thu nhat")
(princ))
(defun C:var2 (/ lstvar2 lv1 lv2 x) ; Lenh nay chay o ban ve thu 2
(if lstvar1
(progn
(princ "\n")
(foreach var lstvar (if (getvar var) (setq lstvar2 (cons (cons var (getvar var)) lstvar2))))
(setq lv1 (list-exclusive lstvar1 lstvar2) lv2 (list-exclusive lstvar2 lstvar1))
(foreach var lv1
(if (setq x (assoc (car var) lv2))
(progn (princ (car var)) (princ "\t") (princ (cdr var)) (princ "\t") (princ (cdr x)) (princ "\n") (setq lv2 (vl-remove x lv2)))
(progn (princ (car var)) (princ "\t") (princ (cdr var)) (princ "\t") (princ "nil") (princ "\n"))))
(foreach var lv2 (princ (car var)) (princ "\t") (princ (cdr var)) (princ "\t") (princ "nil") (princ "\n")))
(prompt "khong co danh sach bien he thong cua ban ve thu nhat de so sanh"))
(princ))
; lay cac phan tu khong thuoc giao cua 2 danh sach
(defun list-exclusive (lst1 lst2) (if lst1 (if (member (car lst1) lst2) (list-exclusive (cdr lst1) lst2) (cons (car lst1) (list-exclusive (cdr lst1) lst2)))))
;----- System Variables of Cad2007.
(setq lstvar (list
"3DDWFPREC"
"ACADLSPASDOC"
"ACADPREFIX"
"ACADVER"
"ACISOUTVER"
"ADCSTATE"
"AFLAGS"
"ANGBASE"
"ANGDIR"
"APBOX"
"APERTURE"
"APSTATE"
"AREA"
"ASSISTSTATE"
"ATTDIA"
"ATTMODE"
"ATTREQ"
"AUDITCTL"
"AUNITS"
"AUPREC"
"AUTOSNAP"
"BACKGROUNDPLOT"
"BACKZ"
"BACTIONCOLOR"
"BDEPENDENCYHIGHLIGHT"
"BGRIPOBJCOLOR"
"BGRIPOBJSIZE"
"BINDTYPE"
"BLIPMODE"
"BLOCKEDITLOCK"
"BLOCKEDITOR"
"BPARAMETERCOLOR"
"BPARAMETERFONT"
"BPARAMETERSIZE"
"BTMARKDISPLAY"
"BVMODE"
"CALCINPUT"
"CAMERADISPLAY"
"CAMERAHEIGHT"
"CDATE"
"CECOLOR"
"CELTSCALE"
"CELTYPE"
"CELWEIGHT"
"CENTERMT"
"CHAMFERA"
"CHAMFERB"
"CHAMFERC"
"CHAMFERD"
"CHAMMODE"
"CIRCLERAD"
"CLAYER"
"CLEANSCREENSTATE"
"CLISTATE"
"CMATERIAL"
"CMDACTIVE"
"CMDDIA"
"CMDECHO"
"CMDINPUTHISTORYMAX"
"CMDNAMES"
"CMLJUST"
"CMLSCALE"
"CMLSTYLE"
"COMPASS"
"COORDS"
"CPLOTSTYLE"
"CPROFILE"
"CROSSINGAREACOLOR"
"CSHADOW"
"CTAB"
"CTABLESTYLE"
"CURSORSIZE"
"CVPORT"
"DASHBOARDSTATE"
"DATE"
"DBCSTATE"
"DBLCLKEDIT"
"DBMOD"
"DCTCUST"
"DCTMAIN"
"DEFAULTLIGHTING"
"DEFAULTLIGHTINGTYPE"
"DEFLPLSTYLE"
"DEFPLSTYLE"
"DELOBJ"
"DEMANDLOAD"
"DIASTAT"
"DIMADEC"
"DIMALT"
"DIMALTD"
"DIMALTF"
"DIMALTRND"
"DIMALTTD"
"DIMALTTZ"
"DIMALTU"
"DIMALTZ"
"DIMAPOST"
"DIMARCSYM"
"DIMASO"
"DIMASSOC"
"DIMASZ"
"DIMATFIT"
"DIMAUNIT"
"DIMAZIN"
"DIMBLK"
"DIMBLK1"
"DIMBLK2"
"DIMCEN"
"DIMCLRD"
"DIMCLRE"
"DIMCLRT"
"DIMDEC"
"DIMDLE"
"DIMDLI"
"DIMDSEP"
"DIMEXE"
"DIMEXO"
"DIMFIT"
"DIMFRAC"
"DIMFXL"
"DIMFXLON"
"DIMGAP"
"DIMJOGANG"
"DIMJUST"
"DIMLDRBLK"
"DIMLFAC"
"DIMLIM"
"DIMLTYPE"
"DIMLTEX1"
"DIMLTEX2"
"DIMLUNIT"
"DIMLWD"
"DIMLWE"
"DIMPOST"
"DIMRND"
"DIMSAH"
"DIMSCALE"
"DIMSD1"
"DIMSD2"
"DIMSE1"
"DIMSE2"
"DIMSHO"
"DIMSOXD"
"DIMSTYLE"
"DIMTAD"
"DIMTDEC"
"DIMTFAC"
"DIMTFILL"
"DIMTFILLCLR"
"DIMTIH"
"DIMTIX"
"DIMTM"
"DIMTMOVE"
"DIMTOFL"
"DIMTOH"
"DIMTOL"
"DIMTOLJ"
"DIMTP"
"DIMTSZ"
"DIMTVP"
"DIMTXSTY"
"DIMTXT"
"DIMTZIN"
"DIMUNIT"
"DIMUPT"
"DIMZIN"
"DISPSILH"
"DISTANCE"
"DONUTID"
"DONUTOD"
"DRAGMODE"
"DRAGP1"
"DRAGP2"
"DRAGVS"
"DRAWORDERCTL"
"DRSTATE"
"DTEXTED"
"DWFFRAME"
"DWFOSNAP"
"DWGCHECK"
"DWGCODEPAGE"
"DWGNAME"
"DWGPREFIX"
"DWGTITLED"
"DYNDIGRIP"
"DYNDIVIS"
"DYNMODE"
"DYNPICOORDS"
"DYNPIFORMAT"
"DYNPIVIS"
"DYNPROMPT"
"DYNTOOLTIPS"
"EDGEMODE"
"ELEVATION"
"ENTERPRISEMENU"
"ERRNO"
"ERSTATE"
"EXPERT"
"EXPLMODE"
"EXTMAX"
"EXTMIN"
"EXTNAMES"
"FACETRATIO"
"FACETRES"
"FIELDDISPLAY"
"FIELDEVAL"
"FILEDIA"
"FILLETRAD"
"FILLMODE"
"FONTALT"
"FONTMAP"
"FRONTZ"
"FULLOPEN"
"FULLPLOTPATH"
"GRIDDISPLAY"
"GRIDMAJOR"
"GRIDMODE"
"GRIDUNIT"
"GRIPBLOCK"
"GRIPCOLOR"
"GRIPDYNCOLOR"
"GRIPHOT"
"GRIPHOVER"
"GRIPOBJLIMIT"
"GRIPS"
"GRIPSIZE"
"GRIPTIPS"
"GTAUTO"
"GTDEFAULT"
"GTLOCATION"
"HALOGAP"
"HANDLES"
"HIDEPRECISION"
"HIDETEXT"
"HIGHLIGHT"
"HPANG"
"HPASSOC"
"HPBOUND"
"HPDOUBLE"
"HPDRAWORDER"
"HPGAPTOL"
"HPINHERIT"
"HPNAME"
"HPOBJWARNING"
"HPORIGIN"
"HPORIGINMODE"
"HPSCALE"
"HPSEPARATE"
"HPSPACE"
"HYPERLINKBASE"
"IMAGEHLT"
"IMPLIEDFACE"
"INDEXCTL"
"INETLOCATION"
"INPUTHISTORYMODE"
"INSBASE"
"INSNAME"
"INSUNITS"
"INSUNITSDEFSOURCE"
"INSUNITSDEFTARGET"
"INTELLIGENTUPDATE"
"INTERFERECOLOR"
"INTERFEREOBJVS"
"INTERFEREVPVS"
"INTERSECTIONCOLOR"
"INTERSECTIONDISPLAY"
"ISAVEBAK"
"ISAVEPERCENT"
"LASTANGLE"
"LASTPOINT"
"LASTPROMPT"
"LATITUDE"
"LAYERFILTERALERT"
"LAYOUTREGENCTL"
"LEGACYCTRLPICK"
"LENSLENGTH"
"LIGHTGLYPHDISPLAY"
"LIGHTLISTSTATE"
"LIMCHECK"
"LIMMAX"
"LIMMIN"
"LISPINIT"
"LOCALE"
"LOCALROOTPREFIX"
"LOCKUI"
"LOFTANG1"
"LOFTANG2"
"LOFTMAG1"
"LOFTMAG2"
"LOFTNORMALS"
"LOFTPARAM"
"LOGFILEMODE"
"LOGFILENAME"
"LOGFILEPATH"
"LOGINNAME"
"LONGITUDE"
"LTSCALE"
"LUNITS"
"LUPREC"
"LWDEFAULT"
"LWDISPLAY"
"LWUNITS"
"ISOLINES"
"MATSTATE"
"MAXACTVP"
"MAXSORT"
"MBUTTONPAN"
"MEASUREINIT"
"MEASUREMENT"
"MENUCTL"
"MENUECHO"
"MENUNAME"
"MIRRTEXT"
"MODEMACRO"
"MSMSTATE"
"MSOLESCALE"
"MTEXTED"
"MTEXTFIXED"
"MTJIGSTRING"
"MYDOCUMENTSPREFIX"
"NOMUTT"
"NORTHDIRECTION"
"OBSCUREDCOLOR"
"OBSCUREDLTYPE"
"OFFSETDIST"
"OFFSETGAPTYPE"
"OLEFRAME"
"OLEHIDE"
"OLEQUALITY"
"OLESTARTUP"
"OPMSTATE"
"ORTHOMODE"
"OSMODE"
"OSNAPCOORD"
"OSNAPHATCH"
"OSNAPZ"
"OSOPTIONS"
"PALETTEOPAQUE"
"PAPERUPDATE"
"PDMODE"
"PDSIZE"
"PEDITACCEPT"
"PELLIPSE"
"PERIMETER"
"PERSPECTIVE"
"PFACEVMAX"
"PICKADD"
"PICKAUTO"
"PICKBOX"
"PICKDRAG"
"PICKFIRST"
"PICKSTYLE"
"PLATFORM"
"PLINEGEN"
"PLINETYPE"
"PLINEWID"
"PLOTOFFSET"
"PLOTROTMODE"
"PLQUIET"
"POLARADDANG"
"POLARANG"
"POLARDIST"
"POLARMODE"
"POLYSIDES"
"POPUPS"
"PREVIEWEFFECT"
"PREVIEWFILTER"
"PRODUCT"
"PROGRAM"
"PROJECTNAME"
"PROJMODE"
"PROXYGRAPHICS"
"PROXYNOTICE"
"PROXYSHOW"
"PROXYWEBSEARCH"
"PSLTSCALE"
"PSOLHEIGHT"
"PSOLWIDTH"
"PSTYLEMODE"
"PSTYLEPOLICY"
"PSVPSCALE"
"PUBLISHALLSHEETS"
"PUCSBASE"
"QCSTATE"
"QTEXTMODE"
"RASTERDPI"
"RASTERPREVIEW"
"RECOVERYMODE"
"REFEDITNAME"
"REGENMODE"
"RE-INIT"
"REMEMBERFOLDERS"
"RENDERPREFSSTATE"
"REPORTERROR"
"ROAMABLEROOTPREFIX"
"RTDISPLAY"
"SAVEFILE"
"SAVEFILEPATH"
"SAVENAME"
"SAVETIME"
"SCREENBOXES"
"SCREENMODE"
"SCREENSIZE"
"SDI"
"SELECTIONAREA"
"SELECTIONAREAOPACITY"
"SELECTIONPREVIEW"
"SHADEDGE"
"SHADEDIF"
"SHADOWPLANELOCATION"
"SHORTCUTMENU"
"SHOWHIST"
"SHOWLAYERUSAGE"
"SHPNAME"
"SIGWARN"
"SKETCHINC"
"SKPOLY"
"SNAPANG"
"SNAPBASE"
"SNAPISOPAIR"
"SNAPMODE"
"SNAPSTYL"
"SNAPTYPE"
"SNAPUNIT"
"SOLIDCHECK"
"SOLIDHIST"
"SPLFRAME"
"SPLINESEGS"
"SPLINETYPE"
"SSFOUND"
"SSLOCATE"
"SSMAUTOOPEN"
"SSMPOLLTIME"
"SSMSHEETSTATUS"
"SSMSTATE"
"STANDARDSVIOLATION"
"STARTUP"
"STEPSIZE"
"STEPSPERSEC"
"SUNPROPERTIESSTATE"
"SUNSTATUS"
"SURFTAB1"
"SURFTAB2"
"SURFU"
"SURFTYPE"
"SURFV"
"SYSCODEPAGE"
"TABLEINDICATOR"
"TABMODE"
"TARGET"
"TBCUSTOMIZE"
"TDCREATE"
"TDINDWG"
"TDUCREATE"
"TDUPDATE"
"TDUSRTIMER"
"TDUUPDATE"
"TEMPOVERRIDES"
"TEMPPREFIX"
"TEXTEVAL"
"TEXTFILL"
"TEXTQLTY"
"TEXTSIZE"
"TEXTSTYLE"
"THICKNESS"
"TILEMODE"
"TIMEZONE"
"TOOLTIPMERGE"
"TOOLTIPS"
"TPSTATE"
"TRACEWID"
"TRACKPATH"
"TRAYICONS"
"TRAYNOTIFY"
"TRAYTIMEOUT"
"TREEDEPTH"
"TREEMAX"
"TRIMMODE"
"TSPACEFAC"
"TSPACETYPE"
"TSTACKALIGN"
"TSTACKSIZE"
"UCSAXISANG"
"UCSBASE"
"UCSDETECT"
"UCSFOLLOW"
"UCSICON"
"UCSNAME"
"UCSORG"
"UCSORTHO"
"UCSVIEW"
"UCSVP"
"UCSXDIR"
"UCSYDIR"
"UNDOCTL"
"UNDOMARKS"
"UNITMODE"
"UPDATETHUMBNAIL"
"USERI1-5"
"USERR1-5"
"USERS1-5"
"VIEWCTR"
"VIEWDIR"
"VIEWMODE"
"VIEWSIZE"
"VIEWTWIST"
"VISRETAIN"
"VPMAXIMIZEDSTATE"
"VSBACKGROUNDS"
"VSEDGECOLOR"
"VSEDGEJITTER"
"VSEDGEOVERHANG"
"VSEDGES"
"VSEDGESMOOTH"
"VSFACECOLORMODE"
"VSFACEHIGHLIGHT"
"VSFACEOPACITY"
"VSFACESTYLE"
"VSHALOGAP"
"VSHIDEPRECISION"
"VSINTERSECTIONCOLOR"
"VSINTERSECTIONEDGES"
"VSINTERSECTIONLTYPE"
"VSISOONTOP"
"VSLIGHTINGQUALITY"
"VSMATERIALMODE"
"VSMAX"
"VSMIN"
"VSMONOCOLOR"
"VSOBSCUREDCOLOR"
"VSOBSCUREDEDGES"
"VSOBSCUREDLTYPE"
"VSSHADOWS"
"VSSILHEDGES"
"VSSILHWIDTH"
"VSSTATE"
"VTDURATION"
"VTENABLE"
"VTFPS"
"WHIPARC"
"WHIPTHREAD"
"WINDOWAREACOLOR"
"WMFBKGND"
"WMFFOREGND"
"WORLDUCS"
"WORLDVIEW"
"WRITESTAT"
"WSCURRENT"
"XCLIPFRAME"
"XEDIT"
"XFADECTL"
"XLOADCTL"
"XLOADPATH"
"XREFCTL"
"XREFNOTIFY"
"XREFTYPE"
"ZOOMFACTOR"
"ZOOMWHEEL"))

Mình lưu ý luôn 1 vài nhược điểm của lisp này:
- Do danh sách biến hệ thống được thống kê thủ công, nên có thể sót 1 vài biến không được kiểm tra. Đồng thời 1 vài biến chúng ta không quan tâm vì nó luôn thay đổi tại mỗi thời điểm cũng không được đưa vào so sánh.
- Danh sách này bác DVH lấy dựa vào danh sách các biến hệ thống của cad 2007, nó chạy tốt với các bản cad 2007-2010. từ bản 2011 trở lên autodesk đã có 1 số thay đổi lớn về giao diện và cách thức autocad tương tác với người dùng nên một số biến hệ thống liên quan có thể không còn tồn tại ở các bản cad này. bạn cần remove nó khỏi danh sách trong lisp để tránh lỗi có thể sảy ra. tương tự với các bản cad đời thấp. sẽ không có 1 số biến của cad 2007 cũng cần fải remove đi mới chạy được.
- code mình viết sơ bộ, chủ yếu để triển khai ý tưởng nên chỉ thông báo kết quả ra cửa sổ command của cad. tốt nhất các bạn nên sửa lại để thống kê ra file text giúp kiểm tra sự khác nhau được dễ dàng hơn.
<<

Filename: 199681_var1+nil+%3B+lenh+nay+chay+o+ban+ve+thu+nhat_var2.lsp
Tác giả: Tue_NV
Bài viết gốc: 72239
Tên lệnh: imppnt
Lisp thay đổi độ cao node của PL-DONE

Chào Tuynh
Mạn phép bác Hoành cho phép Tue_NV chỉnh lại Code của bác để giúp cho bạn Tuynh
@Tuynh : Chạy Lisp sau -> Chọn File txt của bạn -> sẽ được kết quả

Có gì chưa được hãy post lên đây. Tue_NV sẽ chỉnh lại giúp bạn

Filename: 72239_imppnt.lsp
Tác giả: pbellh
Bài viết gốc: 382249
Tên lệnh: test
Nhờ Chỉnh Sửa Lisp Nối Text Cao Độ

Mình có down lisp này từ diễn đàn, nội dung của nó là nối các cặp chữ số lại với nhau ngăn cách bởi dấu “.” tạo thành các text cao độ, với điều kiện xét  khoảng cách giữa 2 text ( insertion ) với tham số d do mình nhập vào, nhưng khi mình chọn = d thì thấy nó chạy không đúng, < d cũng đôi lúc chạy không đúng luôn. Mong các cao thủ sửa giúp ạ. Mình xin cảm ơn

>>

Mình có down lisp này từ diễn đàn, nội dung của nó là nối các cặp chữ số lại với nhau ngăn cách bởi dấu “.” tạo thành các text cao độ, với điều kiện xét  khoảng cách giữa 2 text ( insertion ) với tham số d do mình nhập vào, nhưng khi mình chọn = d thì thấy nó chạy không đúng, < d cũng đôi lúc chạy không đúng luôn. Mong các cao thủ sửa giúp ạ. Mình xin cảm ơn

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/65194-yeu-cau-lisp-noi-text-tu-dong/
(defun c:test(/ lstObj d ans ins! tObj tam isFound lstObj lstRs)
(setq lstObj (mapcar 'vlax-ename->vla-object (acet-ss-to-list (ssget (list (cons 0 "*TEXT")))))
  d (getdist "\nKhoang cach :")
  ans (getstring "\n<=d hay =d ? [<] :")
)
(defun ins!(e)(vlax-get e 'Insertionpoint))
(while (setq tObj (car lstObj))
(setq tam (ins! tObj))
(cond 
   ((setq isFound (vl-member-if '(lambda(x)(and (setq kc (- (distance (ins! x) tam) d))
                                                (if (wcmatch ans ",<")(not (minusp kc))(zerop kc)) )
                                 ) (setq lstObj (cdr lstObj))) )
   (setq isFound (vl-sort isFound '(lambda(x y)(< (distance (ins! x) tam)(distance (ins! y) tam))))
	lstObj (vl-remove (car isFound) lstObj)
	lstRs (vl-sort (list tobj (car isFound)) '(lambda(x y)(< (car (ins! x))(car (ins! y))))))
   (vla-put-textstring (car lstRs)
	(strcat
	(vla-get-textstring (car lstRs)) "."
	(vla-get-textstring (last lstRs))
	)
   )
   (vla-delete (last lstRs))
  )
)
)
)

<<

Filename: 382249_test.lsp
Tác giả: hiepttr
Bài viết gốc: 383829
Tên lệnh: dong2
C?m C?c Gpmb Trên 2 Mép Ngoài Taluy Trên Bình ??

Pro thì không dám nh?ng c?ng s?a cho b?n ?ây: :D :D :D 

(defun c:DONG2 ( / lst_va old ss lst_name coc tlt tlp ob trai phai mid mid_pt)
(vl-load-com)
(defun mid(p1 p2)(mapcar '* (mapcar '+ p1 p2) '(0.5 0.5 0.5)))
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nChon BD muon dong coc GPMB !")
(setq ss (ssget '((8 . "MEPTLT,MEPTLP,ENTCOC"))))
(setq lst_name (vl-remove-if...
>>

Pro thì không dám nh?ng c?ng s?a cho b?n ?ây: :D :D :D 

(defun c:DONG2 ( / lst_va old ss lst_name coc tlt tlp ob trai phai mid mid_pt)
(vl-load-com)
(defun mid(p1 p2)(mapcar '* (mapcar '+ p1 p2) '(0.5 0.5 0.5)))
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nChon BD muon dong coc GPMB !")
(setq ss (ssget '((8 . "MEPTLT,MEPTLP,ENTCOC"))))
(setq lst_name (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq coc (vl-remove-if-not '(lambda(x) (= "ENTCOC" (cdr (assoc 8 (entget x))))) lst_name)
	  tlt (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLT" (cdr (assoc 8 (entget x))))) lst_name)))
	  tlp (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLP" (cdr (assoc 8 (entget x))))) lst_name))))
(foreach c coc
	(setq trai (vlax-invoke (setq ob (vlax-ename->vla-object c)) 'intersectwith tlt acExtendThisEntity)
		  phai (vlax-invoke ob 'intersectwith tlp acExtendThisEntity)
		  mid_pt (mid (vlax-curve-getStartpoint c) (vlax-curve-getEndpoint c)))
	(command "_.insert" "cocmoc" trai 1 "" "")
	(command "_.insert" "cocmoc" phai 1 "" "")
	(command ".DIMALIGNED" mid_pt trai mid_pt)
	(command ".DIMALIGNED" mid_pt phai mid_pt)
)
(mapcar 'setvar lst_va old)
(princ)
)

<<

Filename: 383829_dong2.lsp
Tác giả: hsoso
Bài viết gốc: 245
Tên lệnh: cd
Lisp Cut dim, cut hatch, align it
Sau khi tìm hiểu, mình đã tìm được cái này trên diễn đàn.
 
Lisp cắt Dim.
 
Cách dùng:
- Sau khi upload, dùng lệnh CD.
- click điểm 1 để chọn vị trí cắt chân Dim,
- click điểm 2 để chọn vị trí cắt đường Dim.
 
Nếu không muốn cắt chân Dim hoặc đường Dim thì nhấn phím dấu cách.
 

(defun c:cd (/ entdt dcat1 dcat2 sodimsua index sodt ssdt tt)
  (defun cdim...
>>
Sau khi tìm hiểu, mình đã tìm được cái này trên diễn đàn.
 
Lisp cắt Dim.
 
Cách dùng:
- Sau khi upload, dùng lệnh CD.
- click điểm 1 để chọn vị trí cắt chân Dim,
- click điểm 2 để chọn vị trí cắt đường Dim.
 
Nếu không muốn cắt chân Dim hoặc đường Dim thì nhấn phím dấu cách.
 

(defun c:cd (/ entdt dcat1 dcat2 sodimsua index sodt ssdt tt)
  (defun cdim (entdt    pchan     pduong      /       tt        old10
           old13    old14     new10      new13       new14    p10n
           p13n    p14n     p10o      p13o       p14o        gocduong
           gocchan    pchanb     pduongb loaidim
          )
    (defun chanvuonggoc    (ph p1 p2 / ptemp pkq goc)
      (setq
    goc   (+ (angle p1 p2) (/ pi 2.0))
    ptemp (polar ph goc 1000.0)
    pkq   (inters ph ptemp p1 p2 nil)
      )
      pkq
    )
    (setq
      tt       (entget entdt)
      old10    (assoc '10 tt)
      old13    (assoc '13 tt)
      old14    (assoc '14 tt)
      p10o     (cdr old10)
      p13o     (cdr old13)
      p14o     (cdr old14)
      loaidim  (logand (cdr (assoc '70 tt)) 7)
      gocduong (cond
         ((= loaidim 1) (angle p13o p14o))
         ((= loaidim 0) (cdr (assoc '50 tt)))
         (t nil)
           )
      pchan (cond
          (pchan (list (car pchan) (cadr pchan) 0.0))
          (t pchan)
        )
      pduong (cond
          (pduong (list (car pduong) (cadr pduong) 0.0))
          (t pduong)
        )
      
    )
    (if    gocduong
      (progn
    (if pchan
      (setq
        pchanb (polar pchan gocduong 1000.0)
        p13n   (chanvuonggoc (list (car p13o) (cadr p13o) 0.0) pchan pchanb)
        p14n   (chanvuonggoc (list (car p14o) (cadr p14o) 0.0) pchan pchanb)
        new13  (cons 13 p13n)
        new14  (cons 14 p14n)
        tt       (subst new13 old13 tt)
        tt       (subst new14 old14 tt)
      )
    )
    (if pduong
      (setq
        pduongb (polar pduong gocduong 1000.0)
        p10n    (chanvuonggoc (list (car p10o) (cadr p10o) 0.0) pduong pduongb)
        new10   (cons 10 p10n)
        tt        (subst new10 old10 tt)
      )
    )
    (entmod tt)
      )
    )
    gocduong
  )

 
  (setq    ssdt     (ssget '((0 . "DIMENSION")))
    dcat1     (getpoint "\nDiem cat chan DIM: ")
    dcat2     (getpoint "\nDiem cat duong DIM: ")
        
    dcat1    (cond
           (dcat1 (trans dcat1 1 0))
           (t nil)
         )
    dcat2    (cond
           (dcat2 (trans dcat2 1 0))
           (t nil)
         )    
    sodt     (sslength ssdt)
    index     0
    sodimsua 0
  )
  (repeat sodt
    (setq entdt    (ssname ssdt index)
      index    (1+ index)
      tt    (entget entdt)

    )
    (if    (cdim entdt dcat1 dcat2)
      (setq sodimsua (1+ sodimsua))
    )
  )
  (princ (strcat "\nSo duong dim da sua: " (itoa sodimsua)))
 
)

<<

Filename: 245_cd.lsp

Trang 197/306

197