Jump to content
InfoFile
Tác giả: khaosat2009
Bài viết gốc: 109537
Tên lệnh: xscale xsc
Scale đối tượng một chiều
Đây là đọan code scale đối tượng một chiều

Lệnh là XSC hoặc XSCALE

 

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

Lệnh là XSC hoặc XSCALE

 

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

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

Anh Hoành ơi, làm ơn giúp mình một Lisp dùng trong công tác nắn bản vẽ Ảnh.

Ví dụ như mình có một tờ bản đồ ảnh trên đó thể hiện các hình thể địa hình tự nhiên, sau khi đo đạc vào các điểm chuẩn trên ảnh tương ứng ngoài thực tế có tọa độ có tọa độ các điểm, chuyển điểm lên Cad.

Mình muốn nhờ anh giúp lisp : yêu cầu load ảnh vào, chọn điểm trên ành chỉ vảo điểm cần nắn đến, ... chọn nhiều điểm càng tốt.

Khi thực hiện thì lisp kéo ra hoặc thu lại các điểm của ảnh vào đúng vị trí các điểm trên cad.

Mong được anh giúp


<<

Filename: 109537_xscale_xsc.lsp
Tác giả: tientracdia
Bài viết gốc: 222971
Tên lệnh: xt2ex
chuyển số liệu text từ cad sang excell

Chú ý là các đa giác phải cùng màu và cùng lớp với circle nhé.


(defun c:xt2ex (/ oldos sslst tlst filename f...
>>

Chú ý là các đa giác phải cùng màu và cùng lớp với circle nhé.


(defun c:xt2ex (/ oldos sslst tlst filename f sslst1 C1 C2 C3 C4 C5 C6 C7 C8 )
(vl-load-com)
(command "undo" "be")
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq sslst (acet-ss-to-list (ssget (list (cons 0 "LWPOLYLINE") (cons 62 63) (cons 8 "Main_tach_o"))))
         tlst ""   )
(setq filename (getfiled "Select a File" "" "csv" 1))
(setq f (open filename "w"))
(write-line "Main_STT,Main_H_Dap,Main_S_Dap,Main_V_Dap,Main_H_Dao,Main_S_Dao,Main_V_Dao,Main_S_O," f)
(foreach e sslst
	(setq sslst1 (acet-ss-to-list (ssget "wp" (acet-geom-vertex-list e)
                                                                         (list (cons 0 "text")) 	))  )
	(setq C1 nil C2 nil C3 nil C4 nil C5 nil C6 nil C7 nil C8 nil)
	(foreach en sslst1
                 (if (= (cdr (assoc 8 (entget en))) "Main_STT")
                     (setq C1 (cdr (assoc 1 (entget en))) )
                 )
	)
	(foreach en sslst1
                 (if (= (cdr (assoc 8 (entget en))) "Main_H_Dap")
                     (setq C2 (cdr (assoc 1 (entget en))) )
                 )
	)
	(foreach en sslst1
                 (if (= (cdr (assoc 8 (entget en))) "Main_S_Dap")
    				(setq C3 (cdr (assoc 1 (entget en))) )
                 )
	)
	(foreach en sslst1
                 (if (= (cdr (assoc 8 (entget en))) "Main_V_Dap")
                     (setq C4 (cdr (assoc 1 (entget en))) )
                 )
	)
	(foreach en sslst1
                 (if (= (cdr (assoc 8 (entget en))) "Main_H_Dao")
                     (setq C5 (cdr (assoc 1 (entget en))) )
                 )
	)
	(foreach en sslst1
                 (if (= (cdr (assoc 8 (entget en))) "Main_S_Dao")
    				(setq C6 (cdr (assoc 1 (entget en))) )
                 )
	)
	(foreach en sslst1
                 (if (= (cdr (assoc 8 (entget en))) "Main_V_Dao")
                     (setq C7 (cdr (assoc 1 (entget en))) )
                 )
	)

	(foreach en sslst1
                 (if (= (cdr (assoc 8 (entget en)))  "Main_S_O")
    				(setq C8 (cdr (assoc 1 (entget en))) )
                 )
	)
	(setq tlst (strcat (if C1 C1 " ") (chr 44) (if C2 C2 " ") (chr 44) (if C3 C3 " ") (chr 44) (if C4 C4 " ") (chr 44)
                                   (if C5 C5 " ") (chr 44) (if C6 C6 " ") (chr 44) (if C7 C7 " ") (chr 44) (if C8 C8 " ") (chr 44) ))
	(write-line tlst f)
	(setq tlst "")
)
(close f)
(setvar "osmode" oldos)
(command "undo" "e")
(princ)
)

Vẩn không xuất ra cvs được bạn ơi

Nhưng tại sao mình lại chuyển cùng màu và cùng lớp vậy bạn ?

khi đã thay đổi

(setq sslst (acet-ss-to-list (ssget (list (cons 0 "LWPOLYLINE") (cons 62 63) (cons 8 "Main_tach_o"))))

tlst "" )

http://www.cadviet.com/upfiles/3/114381_ycau4.dwg


<<

Filename: 222971_xt2ex.lsp
Tác giả: akita13
Bài viết gốc: 133979
Tên lệnh: itest
kiểm tra một điểm có nằm trong đa giác hay không?

Bác cứ nghiên cứu đoạn Autolisp này thử nhé

 

>>

Bác cứ nghiên cứu đoạn Autolisp này thử nhé

 

;;======================================================================;;
;;	DETERMINING IF A POINT LIES ON THE INTERIOR OF A POLYGON	;;
;;======================================================================;;

(defun insidep (pt ent / big flag obj1 obj2 obj3 p1 p2 small)
 (vl-load-com)
 (if (and pt ent)
   (progn
     (setq obj1 (vlax-ename->vla-object (car ent)))
     (setq obj2 (car (vlax-invoke obj1 'Offset 0.001))
    obj3 (car (vlax-invoke obj1 'Offset -0.001)))
     (if (> (vla-get-area obj2)(vla-get-area obj3))
(progn
  (set 'big obj2)
  (set 'small obj3))
(progn
  (set 'big obj3)
  (set 'small obj2)))
     (setq p1 (vlax-curve-getClosestPointTo big pt)
    p2 (vlax-curve-getClosestPointTo small pt))
     (if (> (distance pt p1)(distance pt p2))
(setq flag T)
(setq flag nil))
     (mapcar (function (lambda (x)
		  (progn
		    (vla-delete x)
		    (vlax-release-object x))))
      (list big small))
     )
   )
 flag
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun @Inside (PIQ	 Object	  /	   ClosestPoint
	ClosestParam	  Sample   Start    End	     P1
	P2	 P	  a1	   a2	    Defl
       )

 (setq Sample 0.2)

 (vl-load-com)
 (or (= (type @delta) 'SUBR)
     (defun @delta (a1 a2)
(cond
  ((> a1 (+ a2 pi))
   (+ a2 pi pi (- a1))
  )
  ((> a2 (+ a1 pi))
   (- a2 a1 pi pi)
  )
  (1 (- a2 a1))
)
     )
 )
 (and
   (cond
     ((not Object)
      (prompt "  No object provided.")
     )
     ((= (type Object) 'VLA-Object))
     ((= (type Object) 'Ename)
      (setq Object (vlax-ename->vla-object Object))
     )
     (1 (prompt "  Improper object type."))
   )
   (or
     (and
(< 1 (vl-list-length PIQ) 4)
(vl-every 'numberp PIQ)
     )
     (prompt " Improper point value.")
   )
   (or
     (not
(vl-catch-all-error-p
  (setq	Start
	 (vl-catch-all-apply
	   'vlax-curve-getStartPoint
	   (list Object)
	 )
  )
)
     )
     (prompt "  Object is not a curve.")
   )
   (or
     (equal Start (vlax-curve-getendpoint Object) 1e-10)
     (prompt "  Curve is not closed.")
   )
   (setq P (trans PIQ 1 0))		; PIQ in WCS
   (setq ClosestPoint
   (vlax-curve-getclosestpointto Object P) ; In WCS
   )
   (not (equal P ClosestPoint 1e-10))	; in WCS
   (setq ClosestParam (vlax-curve-getparamatpoint Object ClosestPoint))
   (setq ClosestPoint (trans ClosestPoint 0 1)) ; convert to UCS
   (setq End (vlax-curve-getEndparam Object))
   (setq P1   0.0
  P2   Sample
  Defl 0.0
   )
   (setq a1 (angle PIQ (trans Start 0 1))) ; in UCS
   (while (<= P2 End)
     (setq P2 (min P2 End))
       (if (< P1 ClosestParam P2)
(setq a2   (angle PIQ ClosestPoint)
      Defl (+ Defl (@delta a1 a2))
      a1   a2
)
     )

     (while (not (setq P (vlax-curve-getPointAtParam Object P2)))
(setq P2 (+ P2 Sample))
     )
     (setq a2	 (angle PIQ (trans P 0 1)) ; in UCS
    Defl (+ Defl (@delta a1 a2))
    a1	 a2
    P1	 P2
    P2	 (+ P2 Sample)
     )
   )

   (> (abs Defl) 4)
 )
)
;;;;;;*************
(defun C:ITest (/ Object P)
 (if (setq Object (car (entsel "\nSelect curve: ")))
   (while (setq P (getpoint "\nPoint: "))
     (prin1 (@Inside P Object))
   )
 )
 (princ)
)

Có bác nào onl không cho em hỏi chút.Cái hàm insidep ở đầu chương trình em thấy trong chương trình chính không thấy lệnh gọi.nó chạy trong chương trình này như thế nào ah.


<<

Filename: 133979_itest.lsp
Tác giả: phongthan123vn
Bài viết gốc: 297939
Tên lệnh: tmp
Lips move line; pline; vuông góc với line hay pline có sẵn

 

Sửa lại. Không thấy bạn test với text thế nào?

 

(defun c:tmp()
(defun dxf (id v) (cdr (assoc id...
>>

 

Sửa lại. Không thấy bạn test với text thế nào?

 

(defun c:tmp()
(defun dxf (id v) (cdr (assoc id (entget v))))
(defun getNear(v ent)
(setq tm (vl-sort (list (vlax-curve-getStartPoint v) (vlax-curve-getEndPoint v))
'(lambda(x y) (< (distance x (vlax-curve-getClosestPointTo ent x))
(distance y (vlax-curve-getClosestPointTo ent y)))))
tm1 (vlax-curve-getClosestPointTo ent (car tm)))
)
 
(defun thgoc (ent pt / param)
(if (setq param (vlax-curve-getParamAtPoint ent pt))
(- (angle '(0 0 0) (vlax-curve-getFirstDeriv ent param)) (/ pi 2))
nil)
)
(defun laydinh(v / n L node)
(setq v (vlax-ename->vla-object v)
n -1 L nil)
(vl-catch-all-error-p (vl-catch-all-apply '(lambda() 
(while (setq node (vla-get-Coordinate v (setq n (1+ n)))) 
(setq L (append L (list (vlax-safearray->list (vlax-variant-value node)))))))))
L
)
 
;;;
(vl-load-com)
(command "undo" "be")
(setq ent (car (entsel "\nChon duong dan:"))
os (getvar 'osmode))
(setvar 'osmode 0)
(prompt "\nChon doi tuong can move:")  
(mapcar '(lambda(x)
(cond ((= "LINE" (dxf 0 x)) (getNear x ent)
(command "move" x "" (car tm) tm1)
(command "rotate" x "" tm1 "r" tm1 (polar tm1 (angle (car tm) (last tm)) 1) (polar tm1 (thgoc ent tm1) 1)))
 
((vl-string-search "LINE" (dxf 0 x)) (getNear x ent) 
(command "move" x "" (car tm) tm1)
(setq tm2 (if (< (distance tm1 (car (setq tm3 (laydinh x)))) 0.1) (nth 1 tm3) (nth (- (length tm3) 2) tm3)))
(command "rotate" x "" tm1 "r" tm1 (polar tm1 (angle tm1 tm2) 1)
(polar tm1 (thgoc ent tm1) 1)))
 
((vl-string-search "TEXT" (dxf 0 x))
(command "move" x "" (dxf 10 x) (setq tm1 (vlax-curve-getClosestPointTo ent (dxf 10 x))))
(command "rotate" x "" tm1 "r" tm1 (polar tm1 (dxf 50 x) 1) (polar tm1 (thgoc ent tm1) 1)))
 
)) (acet-ss-to-list (ssget '((0 . "*LINE,*TEXT"))))
)
(command "undo" "e") (setvar 'osmode os) (princ)
)

Bác ơi. Quá tuyệt vời ạ. Bác đúng là vị cứu tinh của em. Ko biết nói j để cảm ơn sự nhiệt tình của bác. E chỉ biết chúc bác sức khỏe và hạnh phúc trong cuộc sống và công việc ạ.


<<

Filename: 297939_tmp.lsp
Tác giả: Tue_NV
Bài viết gốc: 111452
Tên lệnh: mahoa
chuyển chữ thành số
hì hì Các bạn viết vui ghê, mình góp ý chút xíu nếu sử dụng bảng mã ASCII thì viết không có dấu. Mình cũng đã viết để mã hoá lisp roài chia sẻ cho các bạn một...
>>
hì hì Các bạn viết vui ghê, mình góp ý chút xíu nếu sử dụng bảng mã ASCII thì viết không có dấu. Mình cũng đã viết để mã hoá lisp roài chia sẻ cho các bạn một chút hì hì. Bạn thử sử dụng đoạn code sau nhé.

(defun c:mahoa (/ kytu sokytu mahoatong mahokytu ktkytu)
 (setq kytu (getstring "\n NhËp key: "))
 (setq sokytu (strlen kytu))
 (setq i 1)
 (while (    (setq ktkytu (substr kytu i 1))
   (setq mahoakytu (ascii ktkytu))
   (setq mahoatong (append mahoatong (list mahoakytu)))
   (setq i (+ i 1))
   )
 (princ mahoatong)
 (princ)  
 )

Còn để dịch ngược thì các bạn dùng hàm vl-list->string chúc các bạn zui zẻ.

PS: Lisp này chỉ viết được 1 đoạn ký tự nối tiếp muốn viết thành đoạn dài thì phải nhập từ DIALOG không có cứ có dấu space là nó kết thúc.

Dài dòng quá :cheers:

Gọn bớt 1 chút :

(defun c:mahoa ()

(princ (vl-string->list (getstring "\n NhËp key: ")))

(princ)

)


<<

Filename: 111452_mahoa.lsp
Tác giả: thienchip86
Bài viết gốc: 224811
Tên lệnh: pht
lisp chèn block phong thủy

nhoc xin đóng góp cách thổ rân thế này ^^, 9 cái đó bạn dùng lệnh writeblock write từng cái cái lưu trong đường...

>>

nhoc xin đóng góp cách thổ rân thế này ^^, 9 cái đó bạn dùng lệnh writeblock write từng cái cái lưu trong đường dẫn

(C:\program files\autodesk\autocad autocad2xxx\support\).cách này nếu bạn chỉ dùng 1 máy, mà mở bất kỳ bản vẽ nào bạn dùng lsp để gọi nó cũng ra, ko phải mở đúng bản vẽ bạn đã vẽ sẵn 9 cái block đó mới xài đc.

Còn nếu đi máy khác thì chắc như bạn autocadlisp nói phải vẽ nó trong lsp lun, mà vẽ cái này trong lsp cũng mệt mỏi ah ^^. mạn phép anh Bình sữa dùm bạn ấy chỗ nhầm xíu trong lsp của anh

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=68603&pid=224775&st=0entry224775

(defun c:pht (/ bln a b c d tg gt  t1 t2 t3)
(setq year (getint "\n Hay nhap nam sinh du 4 chu so: ")
     	GT (getint "\n Hay nhap gioi tinh chu nha <1=Nam; 2=nu>: "))
(setq a (atoi (substr (itoa year) 1 1))
     	b (atoi (substr (itoa year) 2 1))
     	c (atoi (substr (itoa year) 3 1))
     	d (atoi (substr (itoa year) 4 1))
     	Tg (+ a b c d)  )
;;;;;;;;;;;;;;;;;;;
(defun ssu (a / a1 a2 t1)
(if (>  a 10);sua 9 thanh 10
(progn
  		(setq t1 (itoa a)
            		a1 (atoi (substr t1 1 1))
            		a2 (atoi (substr t1 2 1))
            		t2 (+ a1 a2)  )
  		(if (> t2 10); sua 9 thanh 10
      		(ssu t2) )
)
)
t2
)
;;;;;;;;;;;;;;;;;;
(setq tong (ssu tg))
(if (= gt 1)
(setq bln (itoa (- 11 t2)))
(progn
		(setq t3 (+ 4 t2))
		(if (> t3 9)
    		(setq t3 (ssu t3))
		)
		(setq bln (itoa t3))
)
)
(alert (strcat "\n Ten block can chen la " bln))
(command "insert" bln (getpoint "\n Nhap diem chen block") 1 1 0)
)

 

Mình cảm ơn bạn!về vấn đề copy cái block ấy mình se tao một flie setup trong đó sẽ gồm cả block và lisp tự động chạy khi khởi động cad để khi mang sang máy khác chỉ cần bung nó ra là oke nhỉ?hihi


<<

Filename: 224811_pht.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 433123
Tên lệnh: kcm tl
Xin nhờ viết Lisp đo khoảng cách giữa các đoạn thẳng (để hoàn công)

1 giờ} trướ}c, 843824 đã nói:

@ Bác Duong Nhat Duy:  dạ mấy...

>>
1 giờ} trướ}c, 843824 đã nói:

@ Bác Duong Nhat Duy:  dạ mấy nay em chưa có dịp xài tiếp Lisp của bác. Hôm nay lại gặp trường hợp mới. Mà cái này là do lỗi e đưa ra đầu đề không đầy đủ ý.

 

- E gặp thêm trường hợp là cần giá trị KCM này ra kết quả theo 1 tỷ lệ bản vẽ. (Như hiện tại là 1:1) - e muốn nhờ bác giúp thêm là nhập tỉ lệ kích thước đo: ví dụ hiện tại e đang cần là 0,1.

- Bác có thể cho nhập tay 1 lần ở lệnh TL ban đầu. Hoặc là lấy tỉ lệ Scale của Dim hiện hành đều được ạ. 

- Nhưng e nghĩ chắc nhập vào 1 lần khai báo ban đầu chắc lẹ hơn.

 

E xin cảm ơn bác rất nhiều vì đã nhiệt tình giúp đỡ và chỉnh sửa Lisp giúp e ạ.

;KHOANG CACH MIA
(defun C:kcm ( / ANG DIS ELST ENT ENT1 I LST_PT OBJ PT1 PT2 PT3)
  (DISPLAY-OFF)
  (if (not 3Duy_offset) (C:tl))
  (setq ent (ent_pick (list "LINE" "LWPOLYLINE") "\nChon duong do khoang cach: "))
  (setq obj (vlax-ename->vla-object ent))
  (print "Chon cac duong giong: ")
  (setq elst (acet-ss-to-list (ssget (list (cons -4 "<OR") (cons 0 "LINE") (cons 0 "LWPOLYLINE") (cons -4 "OR>")))))
  (setq lst_pt (unique_fuzz (apply 'append (mapcar '(lambda (ent1) (vla-inters ent ent1 0)) elst)) 0.01))
  (setq lst_pt (vl-sort lst_pt '(lambda (pt1 pt2) (< (vlax-curve-getDistAtPoint obj pt1) (vlax-curve-getDistAtPoint obj pt2)))))
  (setq i 0)
  (repeat (1- (length lst_pt))
    (setq pt1 (nth i lst_pt))
    (setq pt2 (nth (1+ i) lst_pt))
    (setq pt3 (polar (midpoint pt1 pt2) (/ pi 2) 3Duy_offset))
    (setq dis (- (vlax-curve-getDistAtPoint obj pt2) (vlax-curve-getDistAtPoint obj pt1)))
    (if (> dis (* 3Duy_width 3.)) (setq ang 0) (setq ang (/ pi 2)))
    (setq dis (/ dis sca))
    (text (rtos dis 2 2) pt3 (getvar "CLAYER") (getvar "TEXTSTYLE") 3Duy_height 3Duy_width ang "Middle")
    (setq i (1+ i))
    )
  (DISPLAY-ON)
  (print)
  )

;THIET LAP
(defun C:tl ()
  (DISPLAY-OFF)
  (setq 3Duy_height (nhapsothuc (if 3Duy_height 3Duy_height 0.25) "Cao chu"))
  (setq 3Duy_width (nhapsothuc (if 3Duy_width 3Duy_width 1.0) "Rong chu"))
  (setq 3Duy_offset (nhapsothuc (if 3Duy_offset 3Duy_offset 0.35) "Khoang cach chen Text"))

  (setq keyw (keyword (list "D" "C") "D" "Scale:Dim/Custom?"))
		       (if (= keyw "D")
			 (setq sca (getvar "dimscale")))
  			(if (= keyw "C")
			 (setq sca (getreal "\nNhap ty le Scale")))
  (DISPLAY-ON)
  (print)
  )

;LIST VAR
(setq 3DUY_SYSTEM_VARIABLES_DISPLAY_NAME '("INSUNITS" "CMDECHO" "DIMZIN" "ATTDIA" "ATTREQ"))
(setq 3DUY_SYSTEM_VARIABLES_SNAP_NAME '("OSMODE" "ORTHOMODE" "SNAPMODE"))
(setq 3DUY_SYSTEM_VARIABLES_DISPLAY_CURRENT (mapcar 'getvar 3DUY_SYSTEM_VARIABLES_DISPLAY_NAME))
(setq 3DUY_SYSTEM_VARIABLES_SNAP_CURRENT (mapcar 'getvar 3DUY_SYSTEM_VARIABLES_SNAP_NAME))

;DISPLAY-OFF
(defun DISPLAY-OFF ()
  (setq 3DUY_SYSTEM_VARIABLES_DISPLAY_CURRENT (mapcar 'getvar 3DUY_SYSTEM_VARIABLES_DISPLAY_NAME))
  (mapcar '(lambda (X) (setvar X 0)) 3DUY_SYSTEM_VARIABLES_DISPLAY_NAME)
  (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
  )

;DISPLAY-ON
(defun DISPLAY-ON ()
  (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
  (mapcar 'setvar 3DUY_SYSTEM_VARIABLES_DISPLAY_NAME 3DUY_SYSTEM_VARIABLES_DISPLAY_CURRENT)
  )

;TEXT
(defun text (str pt layer style height width rotation justify / j)
  (setq j (cond
	  ((= justify "Center") 1)
	  ((= justify "Right") 2)
          ((= justify "Middle") 4)
          (t 0)))
  (entmakex (list
	      (cons 0 "TEXT")
	      (cons 100 "AcDbEntity")
	      (cons 100 "AcDbText")
	      (cons 8 layer)
	      (cons 1 str)
	      (cons 7 style)
	      (cons 10 pt)
	      (cons 11 pt)
	      (cons 40 height)
	      (cons 41 width)
	      (cons 50 rotation)
	      (cons 72 j)
	      ))
  )

;GIAO CAT
(defun vla-inters (ent1 ent2 mode / lst1 lst2)
  (setq lst1 (vlax-invoke (vlax-ename->vla-object ent1) 'intersectwith (vlax-ename->vla-object ent2)
	       (cond
		 ((= mode 0) acextendnone)
		 ((= mode 1) acextendthisentity)
		 ((= mode 2) acextendotherentity)
		 ((= mode 3) acextendboth)
		 )))
  (repeat (/ (length lst1) 3)
    (setq lst2 (cons (list (car lst1) (cadr lst1) (caddr lst1)) lst2)
	  lst1 (cdddr lst1)
	  )
    )
  (reverse lst2)
  )

;UNIQUE-FUZZ
(defun unique_fuzz (lst fuzz / x lst1)
  (while lst
    (setq x (car lst)
	  lst (vl-remove-if (function (lambda (y) (equal x y fuzz))) (cdr lst))
	  lst1 (cons x lst1)
	  )
    )
  (reverse lst1)
  )

;TRUNG DIEM
(defun midpoint (pt1 pt2)
  (list (/ (+ (car pt1) (car pt2)) 2.) (/ (+ (cadr pt1) (cadr pt2)) 2.))
  )

;CHON DOI TUONG
(defun ent_pick (typ promp / ent)
  (if (not (listp typ)) (setq typ (list typ)))
  (setq typ (mapcar 'list typ))
  (while (not ent)
    (while (not (setq ent (car (entsel (strcat "\n" promp))))))
    (if (not (assoc (cdr (assoc 0 (entget ent))) typ)) (setq ent nil))
    )
  ent
  )

;NHAP SO THUC
(defun nhapsothuc (default promp / str)
  (while (not str)
    (setq str (getstring (strcat "\n" promp " <" (rtos (float default) 2 (getvar "DIMDEC")) "> ")))
    (if (= (substr str 1 1) ".") (setq str (strcat "0" str)))
    (setq str (cond
		((= str "") (float default))
		((numberp (read str)) (atof str))
		(t nil)
		))
    )
  )
(defun keyword (key default promp / str1 str2 str3 str4)
  (setq str1 (apply 'strcat (mapcar (function (lambda (x) (strcat x " "))) key)))
  (setq str2 (apply 'strcat (mapcar (function (lambda (x) (strcat x "/"))) key)))
  (setq str1 (substr str1 1 (1- (strlen str1))))
  (setq str2 (substr str2 1 (1- (strlen str2))))
  (initget str1)
  (setq str3 (strcat "\n" promp "  <" default "> "))
  (if (not (setq str4 (getkword str3)))
    default
    str4
    )
  )

Bạn xem đã đúng ý chưa, trong lúc chờ bác Duy giúp bạn? 


<<

Filename: 433123_kcm_tl.lsp
Tác giả: HUNGMETRO
Bài viết gốc: 235905
Tên lệnh: acs
Lisp Xoay Viewport tùy ý

 

Bạn xem lại dòng này: AB trùng AC ==> view đc xoay 1 góc BAC ==> góc quay luôn dương (??). Mình viết theo kiểu Align space của...

>>

 

Bạn xem lại dòng này: AB trùng AC ==> view đc xoay 1 góc BAC ==> góc quay luôn dương (??). Mình viết theo kiểu Align space của cad:

(defun c:ACS(/ p1 p2 p3 goc vs)
  (setq p1 (getpoint "\nChon Tam")
p2 (getpoint p1 "\nChon Phuong hien tai")
p3 (getpoint p1 "\nChon Phuong moi")
goc (-(angle p3 p1)(angle p2 p1))
vs (getvar "viewsize")
p1 (trans p1 1 0))
  (command "ucs" "z" (/(* 180 goc)pi) "")
  (command "plan" "")
  (command "zoom" "c" (trans p1 0 1) vs)
  (princ)
  )

P/s Có bác lo cho topic này em sướng rồi , cảm ơn bác nhiều bạn mà viết như thế này là đã bỏ qua biết bao ý kiến của nhiều bác khác trong diễn đàn, mà cách giải quyết của họ có thể nhanh gọn và hay hơn của mình gấp nhiều lần. Bạn rút kinh nghiệm nhá!

Bữa nay vào trang này thấy bạn viết đoạn lisp này mang về thử thấy chạy tuyệt quá, mình rất thích thanks bạn nha


<<

Filename: 235905_acs.lsp
Tác giả: hhhhgggg
Bài viết gốc: 45277
Tên lệnh: doitext
lisp đổi font cho text sang font .VnHelvetlnsH !!!
Bạn dùng thử đoạn Code này xem nhé :

(defun c:doitext()
(Prompt "\nBan chon Text can chuyen :")
(setq ss (ssget '((0 . "TEXT"))))
(setq po '(0 0))
(setq tue "I")
(command...
>>
Bạn dùng thử đoạn Code này xem nhé :

(defun c:doitext()
(Prompt "\nBan chon Text can chuyen :")
(setq ss (ssget '((0 . "TEXT"))))
(setq po '(0 0))
(setq tue "I")
(command ".-style" "Standard" ".VnHelvetInsH Medium" "250" "1" "0" "n" "n")
(command "text" "j" "TC" po "0" tue) 
(command "zoom" "all")
(command "MATCHPROP" po ss "")
(command "erase" po1 "")
(command "zoom" "p")
)

Ko được bác Tuệ à, Bác phải sửa đôi chút.

1: Lisp của bác thay đổi chiều cao của Text = 250 là sai ở đây yêu cầu chỉ đổi Font chữ thôi, giữ nguyên chiều cao ban đầu của Text

2: Lisp thay đổi Font của Style Standar, làm đổi font của các đối tượng khác.

Mong bác sửa giúp 2 lỗi, Theo ý kiến của em thì mình sẽ đổi đối tượng được chọn sang 1 Style mới là CADVIET , và

Font của Style đó là .VnHelvetInsH Medium.


<<

Filename: 45277_doitext.lsp
Tác giả: nguyen tuan hung
Bài viết gốc: 136144
Tên lệnh: clear1
Nhờ viết lisp dọn mặt bằng siêu tốc

Bạn thêm 1 dòng thôi là được. Tối r mình ngại upload quá, bạn chịu khó chép code nhé

 

(defun c:clear1()
;free...
>>

Bạn thêm 1 dòng thôi là được. Tối r mình ngại upload quá, bạn chịu khó chép code nhé

 

(defun c:clear1()
;free lisp from CADviet.com @ketxu
(vl-load-com)
(command "undo" "be")
(command "change" (ssget "X") "" "p" "c" "8" "")
(if (ssget "x" '((0 . "INSERT")(66 . 1)))
 (progn
	(setq adoc (vla-get-activedocument (vlax-get-acad-object))
		  ss (vla-get-activeselectionset adoc)
	)
    (vlax-for block (vla-get-blocks adoc)	
		(if (not (wcmatch (strcase (vla-get-name block) t) "*_space*")) 
			(vlax-for   ent block 
				(progn			
				(vla-put-color ent "8")					
				)    
			) 
		) 
	)
	(vlax-for attblock ss
		(setq atts (vlax-invoke attblock 'getattributes))
		(foreach att atts
			(vla-put-color att 8)				
		)
	)   
  );end progn
 );end if
(acet-sysvar-set (list "dimclrt" 8 "dimclre" 8 "dimclrd" 8 "cmdecho" 0 "INSUNITS" 4 "INSUNITSDEFSOURCE" 4 "INSUNITSDEFTARGET" 4)) 
(command "dim1" "update" (ssget "X" '((0 . "Leader"))) "")
(command "-layer" "c" "8" "*" "")	
(vla-regen adoc acactiveviewport) 
(command "-purge" "a" "" "N")
(command "undo" "e") 
(princ))

 

Bác cho thêm yêu cầu tất kả các đường trong layer về cỡ 0.09 cho e nhé trong lisp clear1.

Nó sẽ giúp ích cho em rất nhiều trong công việc.


<<

Filename: 136144_clear1.lsp
Tác giả: hhhhgggg
Bài viết gốc: 48579
Tên lệnh: df
Lisp đổi Font cho text được chọn tại sao lỗi với Font .vnarial narrow !!!!!!
Đây là đoạn Code đổi font của Text sang font .vnarial narrow

(defun c:df ()
(command "undo" "be")
(command "-style" "doifont" "VNARIALN.TTF" "0" "1" "0" "n" "n")
(prompt...
>>
Đây là đoạn Code đổi font của Text sang font .vnarial narrow

(defun c:df ()
(command "undo" "be")
(command "-style" "doifont" "VNARIALN.TTF" "0" "1" "0" "n" "n")
(prompt "\nChon chu muon chinh.")
(setq ss (ssget))
(setq c 0)
(if ss (setq e (ssname ss c)))
(while e
(setq e (entget e))
(if (= (cdr (assoc 0 e)) "TEXT")
(progn
(setq txt "doifont")
(setq e (subst (cons 7 txt) (assoc 7 e) e))
(entmod e)
)
)
(setq c (1+ c))
(setq e (ssname ss c))
)
(command "undo" "end")
(Princ)
)

Còn đây là đoạn Code đổi font của Text sang font .vnarial narrowH

(defun c:df ()
(command "undo" "be")
(command "-style" "doifont" "VHARIALN.TTF" "0" "1" "0" "n" "n")
(prompt "\nChon chu muon chinh.")
(setq ss (ssget))
(setq c 0)
(if ss (setq e (ssname ss c)))
(while e
(setq e (entget e))
(if (= (cdr (assoc 0 e)) "TEXT")
(progn
(setq txt "doifont")
(setq e (subst (cons 7 txt) (assoc 7 e) e))
(entmod e)
)
)
(setq c (1+ c))
(setq e (ssname ss c))
)
(command "undo" "end")
(Princ)
)

Chúc thành công ^_^

Chạy tốt rồi, cảm ơn bác Tuệ nhiều nhé !


<<

Filename: 48579_df.lsp
Tác giả: phamhuy1
Bài viết gốc: 324627
Tên lệnh: mce
Lisp vẽ trục trọng tâm của chi tiết đột cắt hình

Lisp của bạn Doan Van Ha đã áp dụng cho trường hợp đột nhiều lỗ.

Tuần trước tôi đã viết lisp cho nhiều đối tượng đơn, hôm...

>>

Lisp của bạn Doan Van Ha đã áp dụng cho trường hợp đột nhiều lỗ.

Tuần trước tôi đã viết lisp cho nhiều đối tượng đơn, hôm nay định viết tiếp cho đối tượng rỗng nhưng thấy bạn Doan Van Ha đã viết rồi.

Lisp tôi định viết dùng lệnh SUBTRACT của cad, lệnh này tổng quát hơn vì áp dụng đúng cho các đối tượng rời nhau nhưng có bounding box lồng nhau, nhưng thấy Lisp của bạn Doan Van Ha có cách tính trọng tâm nhanh hơn nên viết theo hướng này. Trong trường hợp các đối tượng rời nhau nhưng có bounding box lồng nhau (ít khi gặp) thì dùng lệnh này nhiều lần.

Đây là lisp vẽ nhiều đường trục đi qua trọng tâm của nhiều hình, các hình chỉ lồng nhau 1 cấp và không giao nhau.

 

(defun c:mce( / rg c  e m o p q r s su x y) ; multi centroid
    (command "undo" "be")
    (setq e (entlast))
    (princ "\nChon nhom doi tuong tao thanh hinh can lay trong tam: ")
    (vl-cmdf "REGION" (ssget '((0 . "Polyline,Lwpolyline,Spline,Circle,Ellipse,Line,Arc"))) "")
    (while (setq e (entnext e))
        (setq o (vlax-ename->vla-object e)    )
        (vla-getboundingbox o 'p 'q)
        (setq rg (cons  (list o (vlax-get o 'Area)(list (vlax-safearray->list p) (vlax-safearray->list q))) rg))
    )
    (setq rg (vl-sort rg '(lambda(e1 e2) (> (cadr e1) (cadr e2)))))
    (while rg
        (setq o (car rg) rg (cdr rg) s (cadr o) su s r (last o) c (vlax-get (car o) 'Centroid) x (* s (car c)) y (* s (cadr c)))
        (foreach o rg
            (if (and (setq m (last o)) (<= (caar r) (caar m)) (<= (cadar r) (cadar m)) (>= (caadr r) (caadr m)) (>= (cadadr r) (cadadr m)))
                    (setq rg (vl-remove o rg) s (cadr o) su (- su s) c (vlax-get (car o) 'Centroid) x (- x (* s (car c))) y (- y (* s (cadr c)))))
        )
        (setq x (/ x su) y (/ y su))
        (entmake (list '(0 . "Line") '(8 . "Tr\U+00F4c t\U+00A9m") (cons 10 (list (caar r) y)) (cons 11 (list (caadr r) y))))
        (entmake (list '(0 . "Line") '(8 . "Tr\U+00F4c t\U+00A9m") (cons 10 (list x (cadar r))) (cons 11 (list x (cadadr r)))))
    )
    (command "undo" "e")
)

 

@Hoằn: yêu cầu này mà gọi là thư giãn thì rất "Funny" đấy.

 

Em muốn vẽ đường trục đi qua trọng tâm theo layer hiện hành và Line đường trục là "center" mà bản vẽ chưa Load Ltype dạng "center" thì chỉnh lisp sao ạ ??? :(


<<

Filename: 324627_mce.lsp
Tác giả: 790312
Bài viết gốc: 153971
Tên lệnh: sld
Lisp chỉnh style TEXT trong block thuộc tính

Mạn phép anh gia_bach, Tue_NV xin mượn code của anh trả lời câu hỏi này

Đây là code

(defun c:SLD (/ cur_var...
>>

Mạn phép anh gia_bach, Tue_NV xin mượn code của anh trả lời câu hỏi này

Đây là code

(defun c:SLD (/ cur_var str1 str2 tmp tmplay)   
 (if (> (atof (substr (getvar "ACADVER") 1 4)) 16.1)
   (progn
     (or newdst (setq newdst (getvar "DIMSTYLE")))
     (setq str1  "" str2  "")
     (while (setq tbl (tblnext "DIMSTYLE" (null tbl)))
(setq tmp (cdr (assoc 2 tbl))
      str1 (strcat  str1 "/" tmp )
      str2 (strcat  str2 " " tmp )))      
     (setq str1 (substr str1 2)
    str2 (substr str2 2))

     (setq cur_var (mapcar 'getvar '("DYNMODE" "DYNPROMPT")))
     (mapcar 'setvar '("DYNMODE" "DYNPROMPT") '(1 1))
     (initget str2)
     (setq tmpLay (getkword (strcat "\nChon DIMENSION STYLE  <"(princ newdst)">: ") ))
     (and tmpLay (setq newdst tmpLay))
     (mapcar 'setvar '("DYNMODE" "DYNPROMPT") cur_var)
     (command "DIMSTYLE" "R" newdst)

     (alert (strcat "Ban chon DIMENSION STYLE ."))

     (princ newdst))
   (alert "Cad khong ho tro dropdown."))  
 (princ)  )

Nhờ bác bỏ giùm bảng hiện 'Ban chon DIMENSION STYLE ' giùm e,khi sổ danh sách ta chọn thì sẽ chuyển về dimension style ta chọn,không cần hiện bảng 'Ban chon DIMENSION STYLE 'e đã thử sửa trong lisp thì nó báo lỗi.Cảm ơn bác nhiều.


<<

Filename: 153971_sld.lsp
Tác giả: leemindjan
Bài viết gốc: 22696
Tên lệnh: cc
Cần lisp đánh toạ độ cọc.
Bạn dùng thử lisp này, lệnh CC, chọn hàng loạt vòng tròn. Chỗ nào chưa đúng ý (liên quan đến toạ độ quy ước, trình bày kết quả...) thì nêu cụ thể, sửa 1 phát nữa là...
>>
Bạn dùng thử lisp này, lệnh CC, chọn hàng loạt vòng tròn. Chỗ nào chưa đúng ý (liên quan đến toạ độ quy ước, trình bày kết quả...) thì nêu cụ thể, sửa 1 phát nữa là OK:

;;;-------------------------------------------------------
(defun wtxt (txt p / sty d h) ;;;Write txt on graphic screen, defaul setting
(setq
   sty (getvar "textstyle")
   d (tblsearch "style" sty)
   h (cdr (assoc 40 d))
)
(if (= h 0) (setq h (cdr (assoc 42 d))))
(entmake
   (list (cons 0 "TEXT") (cons 7 sty) (cons 1 txt) (cons 10 p) (cons 40 h) (assoc 41 d))
)
)
;;;-------------------------------------------------------
(defun C:CC( / ss e p) ;;;Coordinate of Circles
(setq ss (ssget '((0 . "CIRCLE"))))
(while (setq e (ssname ss 0))
   (setq p (cdr (assoc 10 (entget e))))
   (wtxt (strcat "x=" (rtos (car p)) "; y=" (rtos (cadr p))) p)
   (ssdel e ss)
)
(princ)
)
;;;-------------------------------------------------------

 

Mình làm được rồi,cám ơn bác ssg nhiều lắm.


<<

Filename: 22696_cc.lsp
Tác giả: Tue_NV
Bài viết gốc: 32495
Tên lệnh: cg
Chọn text là số
Hàm kiểm tra nội dung của 1 chuỗi là số

không xét t/hợp chuỗi có định dạng thêm khoảng trắng giữa hàng ngàn. vd : 23 000 -> 23000

(DEFUN IsNumeric (str)

(if...

>>
Hàm kiểm tra nội dung của 1 chuỗi là số

không xét t/hợp chuỗi có định dạng thêm khoảng trắng giữa hàng ngàn. vd : 23 000 -> 23000

(DEFUN IsNumeric (str)

(if (not(vl-string-search " " str))

(if (member (type (read str)) '(REAL INT) )

T

nil

)

nil

)

)

Đoạn code của bạn được sửa lại :

(DEFUN IsNumeric (str)
 (if (not(vl-string-search " " str))
   (if (member (type (read str)) '(REAL INT) )
     T
     nil
     )
   nil
   )
 )

(defun C:cg ()
 (setvar "CMDECHO" 0)
 (setq pre (getint "\nSo chu so sau dau phay?"))
 (command "luprec" pre)
 (setq tong 0)
 (SETQ TH (SSGET))
 (SETQ QUANT (SSLENGTH TH))
 (SETQ INDEX 0)
 (WHILE (< INDEX QUANT)
   (IF
     (AND (= "TEXT"
      (CDR (ASSOC 0 (SETQ A (ENTGET (SSNAME TH INDEX)))))
   )
     )
      (PROGN
 (setq s (entget (SSNAME TH INDEX)))
 (setq otext (assoc 1 s))
 (setq ot (cdr otext))
 (if (IsNumeric ot) ;neu noi dung ot la so
   (setq ot (atof ot)
	 tong (+ ot tong)) ; tinh tong
   ) 	 
      )
   )
   (setq index (+ index 1))
 )
 (prompt "\n Chon gia tri can thay the")
 (SETQ TT (SSGET))
 (SETQ QUAN (SSLENGTH TT))
 (SETQ INDE 0)
 (WHILE (< INDE QUAN)
   (IF
     (AND (= "TEXT"
      (CDR (ASSOC 0 (SETQ A (ENTGET (SSNAME TT INDE)))))
   )
     )
      (PROGN
 (setq s (entget (SSNAME TT INDE)))
 (setq otext (assoc 1 s))
;;;	 (setq ot (cdr otext))
;;;	 (setq ot (read (substr ot 1)))
 (setq nt (cons 1 (rtos Tong 2 pre)))
 (setq s (subst nt otext s))
 (entmod s)
      )
   )
   (setq inde (+ inde 1))
 )
)

Rất cảm ơn anh đã giúp đỡ cho em.

Nhưng tổng quát ý của em ngay từ đầu là muốn chọn đối tượng là số để xử lý sau khi chọn bằng Grid.

Vì còn nhiều lệnh AutoLisp về phép tính số học cần được giải quyết.

Hàm IsNumeric này quả thật em chưa biết.

Anh giúp em nhé. Cảm ơn anh.

(Có thể bạn chọn đối tượng đầu tiên bằng Grid rồi thực hiện lệnh AutoLisp thì các Grid biến mất. nhưng khi thực hiện lệnh Lisp thì ở trong câu Select Object : bạn nhấn chữ P(previous) các đối tượng text số chọn ra đó sẽ được chọn lại. )


<<

Filename: 32495_cg.lsp
Tác giả: w1nDream
Bài viết gốc: 72938
Tên lệnh: loctextso
Chọn text là số
Bạn chạy thử đoạn code này

(defun c:LocTextSo (/ ss ent str ss1)
 (setq ss1 (ssadd))
 (if (setq ss (ssget (list (cons 0 "TEXT"))))
   (progn
     (foreach ent (vl-remove-if...
>>
Bạn chạy thử đoạn code này

(defun c:LocTextSo (/ ss ent str ss1)
 (setq ss1 (ssadd))
 (if (setq ss (ssget (list (cons 0 "TEXT"))))
   (progn
     (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
(setq str (cdr(assoc 1 (entget ent))))
(if (distof str 2)
  (ssadd ent ss1)
  )
)      
     (if (> (sslength ss1) 0)
       (progn
         (sssetfirst nil)
  (princ (strcat "\nChon duoc " (itoa (sslength ss1)) " doi tuong Text co noi dung la so."))
         (sssetfirst nil ss1)
  )
)
     )
   )
 )

 

 

thanks pác Gia Bách! Em lọc được rồi.Em down lisp về làm mãi mới nhớ ra la phải kiểm tra font của lisp. :s_big:


<<

Filename: 72938_loctextso.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 433316
Tên lệnh: sl
NHỜ CÁC BÁC CHỈNH SỬA LISP
(defun c:SL ( / luu lay a1 a hbv c *num num demo str ent)
(setq luu 
>>
(defun c:SL ( / luu lay a1 a hbv c *num num demo str ent)
(setq luu (getvar "osmode"))
(setq lay (getvar "clayer"))
(setq a1 (getdist "\nCh\U+1ECDn kho\U+1EA3ng r\U+1EA3i th\U+00E9p: ")) 
(or (and a (or (= (type a) 'int) (= (type a) 'real))) (setq a 200))
(setq a (cond ((getdist (strcat "\nKho\U+1EA3ng c\U+00E1ch thanh th\U+00E9p <" (rtos a 2 2) ">:"))) (a)))
(or (and hbv (or (= (type hbv) 'int) (= (type hbv) 'real))) (setq hbv 10))
(setq hbv (cond ((getreal (strcat "\nduong kinh thep <" (rtos hbv 2 2) ">: "))) (hbv)))
(setq c (+ (/ a1 a) 1))
  (or *num (setq *num 500))
  (or (setq num (getreal (strcat "\n Chieu dai thanh thep <" (rtos *num 2 0) ">:" )))
  (setq num *num))
  (setq *num num)
  (setq demo (/ *num 10))
  (setq str (strcat (rtos demo 2 0) "0"))
  (while (setq ent (nentsel "\nCh\U+1ECDn ghi gi\U+00E1 tr\U+1ECB (Text ho\U+0103c ATT):" ))
(and (wcmatch (cdr (assoc 0 (entget (car ent)))) "ATTRIB,*TEXT")
(vla-put-textstring (vlax-ename->vla-object  (car ent)) (strcat (rtos c 2 0) "%%c" (rtos hbv 2 0) "a" (rtos a 2 0) "-" str ) )))
(SETVAR "clayer" lay)
(setvar "osmode" luu)
(princ)
)

Bạn xem đã đạt chưa? 


<<

Filename: 433316_sl.lsp
Tác giả: gia_bach
Bài viết gốc: 223662
Tên lệnh: ha
- Chọn nhanh các đối tượng dạng đường (line, curve..) nối tiếp nhau

Tiếp tục sửa. Bỏ hàm ssclear luôn.

(defun C:HA( / sf ss0 ent0 lst)
;Doan Van Ha - CADViet.com - Ngay 25/12/2012....
>>

Tiếp tục sửa. Bỏ hàm ssclear luôn.

(defun C:HA( / sf ss0 ent0 lst)
;Doan Van Ha - CADViet.com - Ngay 25/12/2012. Modify 26/12/2012
;Chuc nang: Chon doi tuong noi tiep nhau (LINE,ARC,LWPOLYLINE,SPLINE,POLYLINE,ELLIPSE).
...

Thanks HA.

Lisp này chạy nhanh hơn của "chính chủ".


<<

Filename: 223662_ha.lsp
Tác giả: draftsman38751
Bài viết gốc: 184414
Tên lệnh: ha
Lisp vẽ spline qua các điểm.

 

Đây bạn!

;Doan Van Ha - CADViet.com 02-12-2011
;Noi cac dau mut cua cac Line/Pline (nam ngang) thanh duong...
>>

 

Đây bạn!

;Doan Van Ha - CADViet.com 02-12-2011
;Noi cac dau mut cua cac Line/Pline (nam ngang) thanh duong Pline/Spline.
(defun C:HA( / lst lstptt lstptp kwrd1 kwrd2)
(vl-load-com)
(BAT_DAU)
(princ "\nChon cac duong Line...")
(setq lst (acet-ss-to-list (ssget (list (cons 0 "LINE,LWPOLYLINE")))))
(initget "P S")
(setq kwrd1 (getkword "\nChon kieu duong ve  <Pline>: "))
(if (null kwrd1) (setq kwrd1 "P"))
(initget "T P")
(setq kwrd2 (getkword "\nChon phia ve  <Phai>: "))
(if (null kwrd2) (setq kwrd2 "P"))
(setq lst (vl-sort lst '(lambda (x y) (<
(cadr (cdr (assoc 10 (entget x)))) (cadr (cdr (assoc 10 (entget y))))))))
(foreach n lst
 (if (< (car (car (acet-geom-object-end-points (entget n)))) (car (cadr (acet-geom-object-end-points (entget n)))))
  (setq lstptt (cons (car (acet-geom-object-end-points (entget n))) lstptt)
			lstptp (cons (cadr (acet-geom-object-end-points (entget n))) lstptp))
  (setq lstptt (cons (cadr (acet-geom-object-end-points (entget n))) lstptt)
			lstptp (cons (car (acet-geom-object-end-points (entget n))) lstptp))))
(cond
 ((and (= kwrd1 "S") (= kwrd2 "T"))
  (setq lst (list '(0 . "SPLINE")' (100 . "AcDbEntity") '(100 . "AcDbSpline") (cons 71 3) (cons 74 (length lstptt))))
  (foreach p lstptt (setq lst (append lst (list (cons 11 p)))))
  (entmake lst))
 ((and (= kwrd1 "S") (= kwrd2 "P"))
  (setq lst (list '(0 . "SPLINE")' (100 . "AcDbEntity") '(100 . "AcDbSpline") (cons 71 3) (cons 74 (length lstptp))))
  (foreach p lstptp (setq lst (append lst (list (cons 11 p)))))
  (entmake lst))
 ((and (= kwrd1 "P") (= kwrd2 "T"))
  (setq lst (list '(0 . "LWPOLYLINE")'(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lstptt)) (cons 70 0)))
  (foreach p lstptt (setq lst (append lst (list (cons 10 p)))))
  (entmake lst))
 ((and (= kwrd1 "P") (= kwrd2 "P"))
  (setq lst (list '(0 . "LWPOLYLINE")'(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lstptp)) (cons 70 0)))
  (foreach p lstptp (setq lst (append lst (list (cons 10 p)))))
  (entmake lst)))
(KET_THUC)
(princ))
;----- Hµm nµy ®Æt ®Çu ch­¬ng tr×nh.
(defun BAT_DAU()
(setq AcDoc (vla-get-activeDocument (vlax-get-acad-object)))
(vla-StartUndoMark AcDoc)
(setq err *error* *error* KHI_LOI))
;----- Hµm nµy ®Æt cuèi ch­¬ng tr×nh.
(defun KET_THUC()
(acet-sysvar-restore)
(vla-EndUndoMark AcDoc)
(setq *error* err))
;----- Hµm nµy xö lý khi cã lçi x·y ra.
(defun KHI_LOI(msg)
(acet-sysvar-restore)
(vla-EndUndoMark AcDoc)
(redraw)
(command "u")
(princ (strcat "\n" msg ", Reset System Variables\n"))
(setq *error* err))

 

Ok rùi!Thanks bác nha!Chúc bác 1 ngày dzui dxze


<<

Filename: 184414_ha.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 433343
Tên lệnh: sl
NHỜ CÁC BÁC CHỈNH SỬA LISP
13 giờ trước, vanhuyou đã nói:

Hi bạn, ở đoạn - Chiều...

>>
13 giờ trước, vanhuyou đã nói:

Hi bạn, ở đoạn - Chiều dài thanh thép (làm tròn lên 10) bạn có thể giúp mình sửa thành 2 lựa chọn:

1. Nhập trực tiếp chiều dài

2. Chọn poliline có sẵn (làm tròn lên 10)

Mong bạn giúp mình.

(vl-load-com)
(defun c:SL ( / luu lay a1 c demo str ent sel)
(setq luu (getvar "osmode"))
(setq lay (getvar "clayer"))
(setq a1 (getdist "\nCh\U+1ECDn kho\U+1EA3ng r\U+1EA3i th\U+00E9p: ")) 
(or (and a (or (= (type a) 'int) (= (type a) 'real))) (setq a 200))
(setq a (cond ((getdist (strcat "\nKho\U+1EA3ng c\U+00E1ch thanh th\U+00E9p <" (rtos a 2 2) ">:"))) (a)))
(or (and hbv (or (= (type hbv) 'int) (= (type hbv) 'real))) (setq hbv 10))
(setq hbv (cond ((getreal (strcat "\nduong kinh thep <" (rtos hbv 2 2) ">: "))) (hbv)))
(setq c (+ (/ a1 a) 1))
  (if (setq sel (car (entsel "\nPick Polyline hoac Pick khoang trang de nhap chieu dai")))
    (setq *num (vla-get-length (vlax-ename->vla-object sel))) (progn 
  (or *num (setq *num 500))
  (or (setq num (getreal (strcat "\n Chieu dai thanh thep <" (rtos *num 2 0) ">:" )))
  (setq num *num))
  (setq *num num)))
  (alert (rtos *num 2 0))
  (setq demo (/ *num 10))
  (setq str (strcat (rtos demo 2 0) "0"))
  (while (setq ent (nentsel "\nCh\U+1ECDn ghi gi\U+00E1 tr\U+1ECB (Text ho\U+0103c ATT):" ))
(and (wcmatch (cdr (assoc 0 (entget (car ent)))) "ATTRIB,*TEXT")
(vla-put-textstring (vlax-ename->vla-object  (car ent)) (strcat (rtos c 2 0) "%%c" (rtos hbv 2 0) "a" (rtos a 2 0) "-" str ) )))
(SETVAR "clayer" lay)
(setvar "osmode" luu)
(princ)
)

Pick Polyline hoặc nhập chiều dài nhé bạn


<<

Filename: 433343_sl.lsp

Trang 285/303

285