Jump to content
InfoFile
Tác giả: pikeman286
Bài viết gốc: 12328
Tên lệnh: brickcap
Nhân bản đối tượng theo một đường

Hiện tại có một lisp làm chức năng trên nhưng không hiểu sao không chạy được.Các bác xem jum em cái.

Filename: 12328_brickcap.lsp
Tác giả: tientracdia
Bài viết gốc: 259785
Tên lệnh: tdmoc
sửa lisp chọn điểm, xác định tọa độ và xuất ra excel

Xin nhờ các bạn giúp sửa lisp để thực hiện nội dung sau :

1. Nhập tên mốc, số thứ tự, Chọn điểm trên cad, ( ví dụ  MOC-01 ), khi đó khi chọn tiếp... thì số thú tự tăng dần lên 2 , 3,...

2. Xuất vào file exel : TEN MOC-STT       TOA DO X         TOA DO Y   cùng tên file Cad

(defun C:TDMOC( / p so old k tyle1 lold f s)

;; mo de ghi vao file txt
(if...
>>

Xin nhờ các bạn giúp sửa lisp để thực hiện nội dung sau :

1. Nhập tên mốc, số thứ tự, Chọn điểm trên cad, ( ví dụ  MOC-01 ), khi đó khi chọn tiếp... thì số thú tự tăng dần lên 2 , 3,...

2. Xuất vào file exel : TEN MOC-STT       TOA DO X         TOA DO Y   cùng tên file Cad

(defun C:TDMOC( / p so old k tyle1 lold f s)

;; mo de ghi vao file txt
(if (not (setq f (open (getfiled "Data save file" "" "txt" 1) "a"))) (exit));

;; ghi vao  ten cong trinh vao text
(write-line (strcat "\n"(getstring "Ghi chu ten cong trinh :" t)"\n") f);

;; chon ty le va xac dinh diem :ghi va chen ky hieu vao
  (setq lold (getvar "clayer"))
  (setq old (getvar "osmode"))
  (setvar "osmode" 9)
  (setq ltdtylein 500)
  (setq tyle1 (getint (strcat "\nTy le in ban do <" (itoa ltdtylein ) ">: ")))
  (if tyle1 (setq ltdtylein tyle1))
  (setq k (/ ltdtylein 1000.0))
  (setq so "1")
  (command "_.layer" "m" "TOADOMOC" "c" 2 "" "")
  (setvar "clayer" "TOADOMOC")
  (INITGET 128)
  (WHILE (SETQ P (GETPOINT (strcat "\nNhap so hieu diem <" so "> hoac Pick "))) 
    (cond 
      ((listp p) 
        (command "_.insert" "KHMOC" "s" k p 0.0 so)
        (setq so (itoa (1+ (atoi so))))
      )
      ((= (type p) 'STR) (setq so p))
    )
    (INITGET 128)
  )

  
;;-------------------------  ??? xac dinh TEN - TOA DO X -  TOA DO Y	vao txt hoac excel
  (write-line (strcat s "\t" (rtos (car pt) 2 3) "\t" (rtos (cadr pt) 2 3)) f) ;
  (while (not b)
		(if (/= "" (setq s (getstring "\nTen diem :" )	))
			(progn
			(command "osnap" "Node,End,Mid,Cen,Qua,Int,Per,Tan,Ext,Par")	;Tao cac truy bat diem End,Mid,Cen,Qua,Per,Tan,Ext, Par.
			(setq pt (getpoint "Vi tri lay toa do :")	)
			(write-line (strcat s "\t" (rtos (car pt) 2 3) "\t" (rtos (cadr pt) 2 3)) f)
			)
			(setq b t)
			)
		)
	(close f)
 ; ;;---------------------
 
  (setvar "osmode" old)
  (setvar "clayer" lold)
  (PRINC)
)

Rất mong được giúp đỡ

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


<<

Filename: 259785_tdmoc.lsp
Tác giả: KangKung
Bài viết gốc: 256019
Tên lệnh: tre tre
Lisp sử dụng Osnap khi đang dùng hàm Grread

Góp vui với bác Hạ chút.

http://www.cadviet.com/upfiles/3/71162_lisp_ve_hcn_nghiengosnap_ver10_1.lsp

Đây là Lisp vẽ hình chữ nhật có sử dụng grread và osnap để tạo hiệu ứng động cho đẹp mắt. Mục đích của Lisp này là vẽ hình chữnhật không chỉ theo phương đứng hoặc phương nằm ngang mà còn có thể vẽ theo hướng...

>>

Góp vui với bác Hạ chút.

http://www.cadviet.com/upfiles/3/71162_lisp_ve_hcn_nghiengosnap_ver10_1.lsp

Đây là Lisp vẽ hình chữ nhật có sử dụng grread và osnap để tạo hiệu ứng động cho đẹp mắt. Mục đích của Lisp này là vẽ hình chữnhật không chỉ theo phương đứng hoặc phương nằm ngang mà còn có thể vẽ theo hướng xiên bất kì. Lisp cho phép bắt điểm bằng osnap trong khi đang thực hiện lệnh. Có thể bấm F3 để On/Off chế độ Osnap hoặc chọn chế độ bắt điểm bằng Shift+Rightclick (or Rightclick). Ngoài ra còn có thể On/Off chế độ Orthormode để chuyển HCN từ xiên thành ngang.

;;           Lisp ve Hinh chu nhat (dung, nam ngang, nghieng)                ;;
;;---------------------------------------------------------------------------;;
;;  Author: KangKung 01-10-2013 v1.0                                         ;;
;;  Member of CADMagic Group                                                 ;;
;;---------------------------------------------------------------------------;;
(vl-load-com)
(defun OrthoRound (ang)
  (* (/ pi 2) (fix (/ (+ (/ pi 4) ang) (/ pi 2))))
)
(defun *error* (msg)
  (redraw)
  (setvar "osmode" os)
  )
(defun C:Tre( / os ANG ANG1 GR PT PT1 str LOOP N PO PT X-DIM Y-DIM rightclick batdiem os_pre pt temp)
  (setq temp '(25 0))
  (vla-startundomark (vla-get-activedocument(vlax-get-acad-object)))
  (setq os(getvar "osmode"))
  (setq rightclick 0)
  (initget 1)
  (setq pt1(getpoint "\n Specify first corner point: "))
  (setq ang(getangle pt1 "\n Angle: "))
  (setq ang1 ang)
  (prompt "\n Specify second corner point: ")
  (setq loop T)
  (while (and (setq gr (grread T 12 0)) loop)
    (cond
      ;; Dragging
      ((= 5 (car gr))
       
       (redraw)
       (setq pt (cadr gr))
       (if (and (< 0 (getvar "osmode") 16384)
	     (setq po (vl-remove-if (function null) (mapcar (function (lambda (x / o) (if (setq o (osnap pt x)) (list (distance pt o) o x pt))))
   	(get_osmode)))))
	(setq po (cdar (vl-sort po (function (lambda (a b) (< (car a) (car b)))))) pt (car po))
	(setq po nil))
    (and po (OsMark po))
    (#eMake:Rectang_grvecs pt1 pt nil nil ang nil)
       )
      ;; Picked point = ends loop
      ((= 3 (car gr))
       (#eMake:Rectang pt1 pt nil nil ang nil)
       (redraw)
       (setq loop nil))
      ;; Enter = reads the command line input
      ((or (equal gr '(2 13)) (equal gr '(2 32)))
       (cond
	 ;; valid distance = ends loop
	 ((and str (= (substr str 1 1) "@"))
	  (setq str(vl-string-left-trim "@" str))
	  (setq n(vl-string-search "," str))
	  (setq X-dim(substr str 1 n))
	  (setq Y-dim(substr str (+ n 2)))
	  (if (and (distof X-dim) (distof Y-dim) (/= (+ (distof X-dim) (distof Y-dim)) 0))
	    (progn
	      (#eMake:Rectang pt1 nil (distof X-dim) (distof Y-dim) ang nil)
	      (redraw)
	      (setq loop nil)
	      (grtext)
	      )
	    (princ "\nInvalid Input\n")
	    )
	  )
	 ;; valid point = ends loop
	 ((and str (setq pt (str2pt str)))
	  (#eMake:Rectang pt1 pt nil nil ang nil)
	  (redraw)
	  (setq loop nil)
	  (grtext)
	  )
	 ;; invalid input
	 (T
	  (setq str nil)
	  (princ "\nInvalid Input\n")
	  )
	 )
       )

      ;Right click
      ((= 25 (car gr))
       (setq rightclick(1+ rightclick))
       (if (= rightclick 1) (setq os_pre(getvar "osmode")))
       (setq temp gr)
       (setq batdiem(menu-pop500 gr))
       (foreach a '((1 "_end") (2 "_mid") (4 "_cen") (8 "_nod") (16 "_qua")
		    (32 "_int") (64 "_ins") (128 "_per") (256 "_tan") (512 "_nea")
		    (2048 "_app"))
	 (if (= batdiem (cadr a)) (setvar "osmode" (car a))))
       )

      ;Shift + Right click
      ((equal gr '(11 1000))
       (setq rightclick(1+ rightclick))
       (if (= rightclick 1) (setq os_pre(getvar "osmode")))
       (setq batdiem(menu-pop500 temp))
       (foreach a '((1 "_end") (2 "_mid") (4 "_cen") (8 "_nod") (16 "_qua")
		    (32 "_int") (64 "_ins") (128 "_per") (256 "_tan") (512 "_nea")
		    (2048 "_app"))
	 (if (= batdiem (cadr a)) (setvar "osmode" (car a))))
       )
      ;; F3 = toggles osmode
      ((equal gr '(2 6))
       (if (= (getvar "osmode") 0)
	 (setvar "osmode" (if (/= os 0) os 15359))
	 (setvar "osmode" (if (/= os 0) 0 os))
	 ))
      ;; F8 = toggles orthomode
      ((equal gr '(2 15))
       (setvar "ORTHOMODE" (boole 6 1 (getvar "ORTHOMODE")))
       (if (= (getvar "ORTHOMODE") 1)
	 (setq ang(OrthoRound ang))
	 (setq ang ang1)
	 )
       (princ (chr 8))
       (princ (chr 32))
       )
       ;; getting and printing command line input
      (T
       (if (= (cadr gr) 8) ;_ backspace
	 (or
	   (and str
		(/= str "")
		(setq str (substr str 1 (1- (strlen str))))
		(princ (chr 8))
		(princ (chr 32))
		)
	   (setq str nil)
	   )
	 (or
	   (and str (setq str (strcat str (chr (cadr gr)))))
	   (setq str (chr (cadr gr)))
	   )
	 )
       (and str (princ (chr (cadr gr))))
       )
            
      )
    )
  (if os_pre (setvar "osmode" os_pre))
  (vla-endundomark (vla-get-activedocument(vlax-get-acad-object)))
  (princ)
  )

;--------------------------------------------------------------------------- SUB FUNCTIONS
;----- T&#185;o Icon Osnap v&#181; g&#184;n v&#181;o &#174;i&#211;m po, EX: !po = ((94.4953 17.8586 0.0) "_mid" (94.0427 14.9045 0.0)), l&#202;y pt = (car po).
(defun osMark (o / s osGrv)
  (setq	osGrv (osmode-grvecs-lst
		(vla-get-AutoSnapMarkerColor
		  (vla-get-drafting
		    (vla-get-preferences (vlax-get-acad-object))
		  )
		)
		(vla-get-AutoSnapMarkerSize
		  (vla-get-drafting
		    (vla-get-preferences (vlax-get-acad-object))
		  )
		)
	      )
  )
  (setq	s (/ (getvar "viewsize") (cadr (getvar "screensize")))
	o (cons (trans (car o) 1 3) (cdr o))
  )
  (grvecs (cdr (assoc (cadr o) osGrv))
	  (list	(list s 0. 0. (caar o))
		(list 0. s 0. (cadar o))
		(list 0. 0. s 0.)
		(list 0. 0. 0. 1.)
	  )
  )
)
(defun osmode-grvecs-lst (col ass / -ass ass col) ; By Evgeniy Elpanov (Modified by Lee McDonnell)
  (setq -ass (- ass))
  (list (list "_end"
              col (list -ass -ass) (list -ass  ass)
              col (list (1-  -ass) (1- -ass)) (list (1- -ass) (1+  ass))              
              col (list -ass  ass) (list  ass  ass)
              col (list (1-  -ass) (1+  ass)) (list (1+  ass) (1+  ass))              
              col (list  ass  ass) (list  ass -ass)
              col (list (1+   ass) (1+  ass)) (list (1+  ass) (1- -ass))              
              col (list  ass -ass) (list -ass -ass)
              col (list (1+   ass) (1- -ass)) (list (1- -ass) (1- -ass)))
        (list "_mid"
              col (list -ass -ass) (list    0. ass)
              col (list (1-  -ass) (1- -ass)) (list 0. (1+  ass))
              col (list    0. ass) (list  ass -ass)
              col (list 0. (1+  ass)) (list (1+  ass) (1- -ass))
              col (list  ass -ass) (list -ass -ass)
              col (list (1+   ass) (1- -ass)) (list (1- -ass) (1- -ass)))
        (list "_cen"
              7   (list (* -ass 0.2) 0.)  (list (*  ass 0.2) 0.)
              7   (list  0. (* -ass 0.2)) (list  0.  (*  ass 0.2))
              col (list    -ass   0.) 	(list (* -ass 0.86) (* ass  0.5))
              col (list (* -ass 0.86) (* ass  0.5))  (list (* -ass  0.5) (* ass 0.86))
              col (list (* -ass  0.5) (* ass 0.86))  (list 0. ass)
              col (list 0. ass) (list (* ass 0.5)    (* ass 0.86))
              col (list (* ass 0.5)   (* ass 0.86))  (list (* ass 0.86) (* ass 0.5))
              col (list (* ass 0.86)  (* ass 0.5))   (list ass 0.)
              col (list ass 0.) (list (* ass 0.86)   (* -ass 0.5))
              col (list (* ass 0.86)  (* -ass 0.5))  (list (* ass 0.5) (* -ass 0.86))
              col (list (* ass 0.5)   (* -ass 0.86)) (list 0. -ass)
              col (list 0. -ass)(list (* -ass 0.5)   (* -ass 0.86))
              col (list (* -ass 0.5)  (* -ass 0.86)) (list (* -ass 0.86) (* -ass 0.5))
              col (list (* -ass 0.86) (* -ass 0.5))  (list -ass 0.))
        (list "_nod"
              col (list -ass -ass)    (list ass ass)
              col (list -ass ass) 	(list ass -ass)
              col (list -ass 0.)      (list (* -ass 0.86) (* ass 0.5))
              col (list (* -ass 0.86) (* ass 0.5))   (list (* -ass 0.5) (* ass 0.86))
              col (list (* -ass 0.5)  (* ass 0.86))  (list 0. ass)
              col (list 0. ass) (list (* ass 0.5)    (* ass 0.86))
              col (list (* ass 0.5)   (* ass 0.86))  (list (* ass 0.86) (* ass 0.5))
              col (list (* ass 0.86)  (* ass 0.5))   (list ass 0.)
              col (list ass 0.) (list (* ass 0.86)   (* -ass 0.5))
              col (list (* ass 0.86)  (* -ass 0.5))  (list (* ass 0.5) (* -ass 0.86))
              col (list (* ass 0.5)   (* -ass 0.86)) (list 0. -ass)
              col (list 0. -ass)(list (* -ass 0.5)   (* -ass 0.86))
              col (list (* -ass 0.5)  (* -ass 0.86)) (list (* -ass 0.86) (* -ass 0.5))
              col (list (* -ass 0.86) (* -ass 0.5))  (list -ass 0.))
        (list "_qua"
              col (list 0. -ass)   (list -ass 0.)
              col (list 0. (1- -ass))   (list (1- -ass) 0.)
              col (list -ass 0.)   (list 0. ass)
              col (list (1- -ass) 0.)   (list 0. (1+ ass))
              col (list 0. ass)    (list ass 0.)
              col (list 0. (1+ ass))    (list (1+ ass) 0.)
              col (list ass 0.)    (list 0. -ass)
              col (list (1+ ass) 0.)    (list 0. (1- -ass)))
        (list "_int"
              col (list -ass -ass) (list ass ass)
              col (list -ass (1+ -ass)) (list ass (1+ ass))
              col (list (1+ -ass) -ass) (list (1+ ass) ass)
              col (list -ass ass)  (list ass -ass)
              col (list -ass (1+ ass))  (list ass (1+ -ass))
              col (list (1+ -ass) ass)  (list (1+ ass) -ass))
        (list "_ins"
              col (list (* -ass 0.1) (* -ass 0.1)) (list -ass (* -ass 0.1))
              col (list -ass (* -ass 0.1)) (list -ass ass)
              col (list -ass ass) (list (* ass 0.1) ass)
              col (list (* ass 0.1) ass)   (list (* ass 0.1) (* ass 0.1))
              col (list (* ass 0.1) (* ass 0.1))   (list ass (* ass 0.1))
              col (list ass (* ass 0.1))   (list ass -ass)
              col (list ass -ass) (list (* -ass 0.1) -ass)
              col (list (* -ass 0.1) -ass) (list (* -ass 0.1) (* -ass 0.1))
              col (list (1- (* -ass 0.1)) (1- (* -ass 0.1))) (list (1- -ass) (1- (* -ass 0.1)))
              col (list (1- -ass) (1- (* -ass 0.1))) (list (1- -ass) (1+ ass))
              col (list (1- -ass) (1+ ass)) (list (1+ (* ass 0.1)) (1+ ass))
              col (list (1+ (* ass 0.1)) (1+ ass)) (list (1+ (* ass 0.1)) (1+ (* ass 0.1)))
              col (list (1+ (* ass 0.1)) (1+ (* ass 0.1))) (list (1+ ass) (1+ (* ass 0.1)))
              col (list (1+ ass) (1+ (* ass 0.1)))   (list (1+ ass) (1- -ass))
              col (list (1+ ass) (1- -ass)) (list (1- (* -ass 0.1)) (1- -ass))
              col (list (1- (* -ass 0.1))   (1- -ass)) (list (1- (* -ass 0.1)) (1- (* -ass 0.1))))
        (list "_tan"
              col (list -ass ass) (list ass ass)
              col (list (1- -ass) (1+ ass)) (list (1+ ass) (1+ ass))
              col (list -ass 0.)  (list (* -ass 0.86) (* ass 0.5))
              col (list (* -ass 0.86) (* ass 0.5)) (list (* -ass 0.5) (* ass 0.86))
              col (list (* -ass 0.5) (* ass 0.86)) (list 0. ass)
              col (list 0. ass) (list  (* ass 0.5) (* ass 0.86))
              col (list (* ass 0.5)  (* ass 0.86)) (list (* ass 0.86) (* ass 0.5))
              col (list (* ass 0.86)  (* ass 0.5)) (list ass 0.)
              col (list ass 0.) (list (* ass 0.86) (* -ass 0.5))
              col (list (* ass 0.86) (* -ass 0.5)) (list (* ass 0.5) (* -ass 0.86))
              col (list (* ass 0.5) (* -ass 0.86)) (list 0. -ass)
              col (list 0. -ass)(list (* -ass 0.5) (* -ass 0.86))
              col (list (* -ass 0.5)(* -ass 0.86)) (list (* -ass 0.86) (* -ass 0.5))
              col (list (* -ass 0.86)(* -ass 0.5)) (list -ass 0.))
        (list "_per"
              col (list -ass -ass) (list -ass ass)
              col (list (1- -ass)  (1- -ass)) (list (1- -ass) (1+ ass))
              col (list ass -ass)  (list -ass -ass)
              col (list (1+ ass)   (1- -ass)) (list (1- -ass) (1- -ass))
              col (list -ass 0.)   (list 0. 0.)
              col (list -ass -1.)  (list 0. -1.)
              col (list 0. 0.) 	(list 0. -ass)
              col (list -1. 0.)    (list -1. -ass))
        (list "_nea"
              col (list -ass -ass) (list ass ass)
              col (list -ass ass)  (list ass ass)
              col (list (1- -ass)  (1+ ass)) (list (1+ ass) (1+ ass))
              col (list -ass ass)  (list ass -ass)
              col (list ass -ass)  (list -ass -ass)
              col (list (1+ ass) (1- -ass)) (list (1- -ass) (1- -ass)))
        (list "_app"
              col (list -ass -ass) (list ass ass)
              col (list ass -ass)  (list -ass ass)
              col (list -ass -ass) (list -ass ass)
              col (list (1- -ass)  (1- -ass)) (list (1- -ass) (1+ ass))
              col (list -ass ass)  (list ass ass)
              col (list (1- -ass)  (1+ ass))  (list (1+ ass) (1+ ass))
              col (list ass ass)   (list ass -ass)
              col (list (1+ ass)   (1+ ass))  (list (1+ ass) (1- -ass))
              col (list ass -ass)  (list -ass -ass)
              col (list (1+ ass)   (1- -ass)) (list (1- -ass) (1- -ass)))))

(princ "\n Type TRE to run")

;;;(defun #Rectang(pt)
;;;  (redraw)
;;;  (#eMake:Rectang2 pt1 pt nil nil ang nil)
;;;  )
;; STR2PT
;; Convert a string into a 3d point (input with grread)
;;
;; Argument: a string (ex: "25,63")
;; Return: a 3d point (ex (25.0 63.0 0.0) or nil if invalid string
(defun str2pt (str)
  (setq str (mapcar 'read (str2lst str ",")))
  (if (and (vl-every 'numberp str)
	   (< 1 (length str) 4)
      )
    (trans str 0 0)
  )
)
;; STR2LST
;; Transforms a string with separator into a list of strings
;;
;; Arguments
;; str = the string
;; sep = the separator pattern

(defun str2lst (str sep / pos)
  (if (setq pos (vl-string-search sep str))
    (cons (substr str 1 pos)
	  (str2lst (substr str (+ (strlen sep) pos 1)) sep)
    )
    (list str)
  )
)
;;----------------=={ Entmake a Rectang }==--------------------------------;;
;;                                                                         ;;
;;  Make a Rectang entity by Entmake                                       ;;
;;-------------------------------------------------------------------------;;
;;  Author: KangKung 24-6-2012 v1.0                                        ;;
;;-------------------------------------------------------------------------;;
;;  Arguments: there are 2 options                                         ;;
;;  a) pt1, pt2 - First conner, opposite conner (nil if width and Height)  ;;
;;     Tilt: Tilt angle of Rectang (Radian)                                ;;
;;     lst : List of dxf / nil                                             ;;
;;  b) pt1, Width, Height - First conner point, 2 dimension (nil if pt2)   ;;
;;     Tilt: Tilt angle of Rectang (Radian)                                ;;
;;     lst : List of dxf / nil                                             ;;
;;-------------------------------------------------------------------------;;
;;  Returns:  Rectang Entity                                               ;;
;;-------------------------------------------------------------------------;;
;;  Usage:  						                   ;;
;; a) (#eMake:Rectang '(0.0 0.0 0.0) '(5.0 5.0 0.0) nil nil (/ pi 6) nil)  ;;
;; b) (#eMake:Rectang '(0.0 0.0 0.0) nil 20 40 (/ pi 6) nil)               ;;
;;-------------------------------------------------------------------------;;
(defun #eMake:Rectang (pt1 pt2 Width Heigh Tilt lst / #HEIGH #WIDTH LST_TEMP P1 P2 P3 P4)
  (if (/= nil pt2)
    (progn
      (setq #Width (* (distance pt1 pt2) (cos (- (angle pt1 pt2) Tilt))))
      (setq #Heigh (* (distance pt1 pt2) (sin (- (angle pt1 pt2) Tilt))))
      (setq p1 pt1
	    p2 (list (+ (car pt1) (* #Width (cos Tilt))) (+ (cadr pt1) (* #Width (sin Tilt))))
	    p3 pt2
	    p4 (list (- (car pt1) (* #Heigh (sin Tilt))) (+ (cadr pt1) (* #Heigh (cos Tilt))))
	    )
      )
      (setq p1 pt1
	    p2 (list (+ (car pt1) (* Width (cos Tilt))) (+ (cadr pt1) (* Width (sin Tilt))))
	    p3 (list (+ (car pt1) (* Width (cos Tilt)) (- 0 (* Heigh (sin Tilt)))) (+ (cadr pt1) (* Width (sin Tilt)) (* Heigh (cos Tilt))))
	    p4 (list (- (car pt1) (* Heigh (sin Tilt))) (+ (cadr pt1) (* Heigh (cos Tilt))))
	    )
    )
  (setq lst_Temp (list '(0 . "LWPOLYLINE")
		  '(100 . "AcDbEntity")
		  '(100 . "AcDbPolyline")
		  '(90 . 4)
		  '(70 . 1)
		  (cons 10 p1)
		  (cons 10 p2)
		  (cons 10 p3)
		  (cons 10 p4)
		  )
	)
  (if lst (setq lst_Temp(append lst_Temp lst)))
  (entmake lst_Temp)
  )

(defun #eMake:Rectang_grvecs (pt1 pt2 Width Heigh Tilt lst / #HEIGH #WIDTH LST_TEMP P1 P2 P3 P4)
  (if (/= nil pt2)
    (progn
      (setq #Width (* (distance pt1 pt2) (cos (- (angle pt1 pt2) Tilt))))
      (setq #Heigh (* (distance pt1 pt2) (sin (- (angle pt1 pt2) Tilt))))
      (setq p1 pt1
	    p2 (list (+ (car pt1) (* #Width (cos Tilt))) (+ (cadr pt1) (* #Width (sin Tilt))))
	    p3 pt2
	    p4 (list (- (car pt1) (* #Heigh (sin Tilt))) (+ (cadr pt1) (* #Heigh (cos Tilt))))
	    )
      )
      (setq p1 pt1
	    p2 (list (+ (car pt1) (* Width (cos Tilt))) (+ (cadr pt1) (* Width (sin Tilt))))
	    p3 (list (+ (car pt1) (* Width (cos Tilt)) (- 0 (* Heigh (sin Tilt)))) (+ (cadr pt1) (* Width (sin Tilt)) (* Heigh (cos Tilt))))
	    p4 (list (- (car pt1) (* Heigh (sin Tilt))) (+ (cadr pt1) (* Heigh (cos Tilt))))
	    )
    )
  (grvecs (list 1 p1 p2 2 p2 p3 5 p3 p4 4 p4 p1))
  )

(defun menu-pop500 (d / lst s)
					; Choice function of OSNAP through the shortcut menu.
					; Only, as an example.
					; Is checked up in AutoCad 2004-2007 (En)
					; by ElpanovEvgeniy
					; (2006-10-11)
					; (menu-pop500 (grread t 5))
  (setq
    lst	(reverse
	  (menu-index
	    ((lambda (x) (list (1- (vla-get-count x)) x))
	      (vla-item
		(vla-get-menus
		  (vla-item
		    (vla-get-menugroups
		      (vlax-get-acad-object)
		    ) ;_ vla-get-MenuGroups
		    "ACAD"
		  ) ;_ vla-item
		) ;_ vla-get-Menus
		"&Object Snap Cursor Menu"
	      ) ;_ vla-item
	    )
	  ) ;_ menu-index
	) ;_ reverse
  ) ;_ setq
  (while (and
	   (listp d)
	   (or (= (car d) 5)
	       (= (car d) 11)
	       (= (car d) 12)
	       (= (car d) 25)		; For old version AutoCad
	   ) ;_ or
	 ) ;_ and
    (cond
      ((= (car d) 25) (menucmd "POP500=*")) ; For old version AutoCad
      ((equal d '(11 0)) (menucmd "POP500=*"))
      ((= (car d) 11) (setq s (nth (- (cadr d) 500) lst)))
    ) ;_ cond
    (if	s
      (setq d s)
      (setq d (grread t 5))
    ) ;_ if
  ) ;_ while
  (substr s 1 4)
) ;_ defun
(defun menu-index (l)
					; Creation of the list of choices of choice of OSNAP
					; Is checked up in AutoCad 2004-2007 (En)
					; by ElpanovEvgeniy
					; (2006-10-11)
		  ;|
 (menu-index
 ((lambda (x) (list (1-(vla-get-count x)) x))
 (vla-item
 (vla-get-menus
 (vla-item
 (vla-get-menugroups
 (vlax-get-acad-object)
 ) ;_ vla-get-MenuGroups
 "ACAD"
 ) ;_ vla-item
 ) ;_ vla-get-Menus
 "&Object Snap Cursor Menu"
 ) ;_ vla-item
 )
 ) ;_ menu-index
 |;
  (if (not (minusp (car l)))
    (cond
      ((= (vla-get-type (vla-item (cadr l) (car l))) 0)
       (cons
	 (vla-get-macro (vla-item (cadr l) (car l)))
	 (menu-index (cons (1- (car l)) (cdr l)))
       ) ;_ cons
      )
      ((= (vla-get-type (vla-item (cadr l) (car l))) 1)
       (menu-index (cons (1- (car l)) (cdr l)))
      )
      ((= (vla-get-type (vla-item (cadr l) (car l))) 2)
       (append
	 (menu-index
	   ((lambda (x) (list (1- (vla-get-count x)) x))
	     (vla-get-submenu (vla-item (cadr l) (car l)))
	   ) ;_ menu-index
	 ) ;_ menu-index
	 (menu-index (cons (1- (car l)) (cdr l)))
       ) ;_ append
      )
    ) ;_ cond
  ) ;_ if
) ;_ defun

(defun get_osmode nil
					; Function create list osmode macro
					; for result (getvar "OSMODE")
					; by Evgeniy Elpanov
					; (get_osmode)
  (mapcar
    (function cdr)
    (vl-remove-if
      (function
	(lambda	(x)
	  (zerop (logand (getvar "OSMODE") (car x)))
	) ;_ lambda
      ) ;_ function
      (append
	(if (< 0 (setq cur_mode (getvar "osmode")) 16384)
	  '((1 . "_end")
	    (2 . "_mid")
	    (4 . "_cen")
	    (8 . "_nod")
	    (16 . "_qua")
	    (32 . "_int")
					;(4096 . "_ext") ; Is not realized
	   )
	) ;_ if
	(if (not (zerop (logand (getvar "autosnap") 16)))
	  '((64 . "_ins")
	    (128 . "_per")
	    (256 . "_tan")
	    (512 . "_nea")
					;(1024 . "_qui") ; Is not realized
	    (2048 . "_app")
					;(8192 . "_par") ; Is not realized
	   )
	) ;_ if
      ) ;_ append
    ) ;_ substr
  ) ;_ mapcar
) ;_ defun


<<

Filename: 256019_tre_tre.lsp
Tác giả: nghiautc
Bài viết gốc: 110948
Tên lệnh: newlayer
Ứng dụng REACTOR trong quản lý bản vẽ theo layer.


Chào duy782006
Về nguyên tắc bạn có thể viết lại hàm (defun MAKE_LAYERS ...) để cập nhật các thông số "color, linetype, linetype scale" khi tạo layer mới.
Tuy nhiên tôi thuờng tách việc tạo mới (cập nhật) Layer thành 1 LISP riêng biệt để dễ quản lý.
Mỗi khi nhận bản vẽ mới chỉ cần chạy LISP này là các LAYER sẽ đuợc Set lại theo tiêu chuẩn của mình.

Bạn thử tham...
>>

Chào duy782006
Về nguyên tắc bạn có thể viết lại hàm (defun MAKE_LAYERS ...) để cập nhật các thông số "color, linetype, linetype scale" khi tạo layer mới.
Tuy nhiên tôi thuờng tách việc tạo mới (cập nhật) Layer thành 1 LISP riêng biệt để dễ quản lý.
Mỗi khi nhận bản vẽ mới chỉ cần chạy LISP này là các LAYER sẽ đuợc Set lại theo tiêu chuẩn của mình.

Bạn thử tham khảo :
- Trong đó hàm layer_lst định nghĩa các tên Layer, color, linetype theo các loại bản vẽ : Kien Truc, Ket Cau, Dien Nuoc, ... Bạn cần thay đổi các thông số này cho phù hợp với tiêu chuẩn của bạn.


To : nghiautc
Lisp có xung đột với 1 vài lệnh.
Khắc phục tạm thời : tắt Lisp này đi Layer_Off khi có xung đột. <_<
[/qu> cảm ơn bạn gia_bach. Giờ mình đã tìm được cách khắc phục rôi
Thêm hàm (Layer_Off) vào đầu lisp bị xung đột để tắt Reactor cuối Lisp bật lại bằng hàm (Layer_On)
<<

Filename: 110948_newlayer.lsp
Tác giả: leejang
Bài viết gốc: 141773
Tên lệnh: dc
lisp đổi màu tất cả các đường DIM ?

Hatch thì dùng thêm phần command cũng được. Lưu ý với bạn là mình chưa động tới các đối tượng trong block nhé :)


Thanks bác nhé . Ok rồi ạ, nhưng khi nào bác có thời gian bác hoàn thiện lisp hơn là các đối tượng bên trong Blog cũng bị đổi màu. Như thế thì tiện hơn nhiều đấy ạ...
>>

Hatch thì dùng thêm phần command cũng được. Lưu ý với bạn là mình chưa động tới các đối tượng trong block nhé :)


Thanks bác nhé . Ok rồi ạ, nhưng khi nào bác có thời gian bác hoàn thiện lisp hơn là các đối tượng bên trong Blog cũng bị đổi màu. Như thế thì tiện hơn nhiều đấy ạ ? Lisp này sẽ giúp cho việc in ấn nhanh hơn rất nhiều đối với các bản vẽ phức tạp có nhiều layer.
<<

Filename: 141773_dc.lsp
Tác giả: 18011985
Bài viết gốc: 261123
Tên lệnh: tt
Cắt pline theo chiều dài cho trước

Của bạn đầy (defun c:tt (/ ENT KC KCTR SS SSN TD)

  (vl-load-com)
  (while (null(setq ss (entsel "\n Chon doituong: ")))) 
  (setq ssn (car ss))
  (setq ent (entget ssn))
  (setq kc (getreal "\n Nhap khoang cach: "))
  (setq td (vlax-curve-getPointAtDist ssn kc))
  (command "Break" td td "") 
  (princ)
  )

Chúc bạn may mắn.

(defun c:tt (/ ENT KC KCTR SS SSN TD)
  (vl-load-com)
  (while...
>>

Của bạn đầy (defun c:tt (/ ENT KC KCTR SS SSN TD)

  (vl-load-com)
  (while (null(setq ss (entsel "\n Chon doituong: ")))) 
  (setq ssn (car ss))
  (setq ent (entget ssn))
  (setq kc (getreal "\n Nhap khoang cach: "))
  (setq td (vlax-curve-getPointAtDist ssn kc))
  (command "Break" td td "") 
  (princ)
  )

Chúc bạn may mắn.

(defun c:tt (/ ENT KC KCTR SS SSN TD)
  (vl-load-com)
  (while (null(setq ss (entsel "\n Chon doituong: "))))  
  (setq ssn (car ss))
  (setq ent (entget ssn))
  (setq kc (getreal "\n Nhap khoang cach: "))
  (setq td (vlax-curve-getPointAtDist ssn kc))
  (command "Break" td td "")  
  (princ)
 
(defun c:tt (/ ENT KC KCTR SS SSN TD)
  (vl-load-com)
  (while (null(setq ss (entsel "\n Chon doituong: "))))  
  (setq ssn (car ss))
  (setq ent (entget ssn))
  (setq kc (getreal "\n Nhap khoang cach: "))
  (setq td (vlax-curve-getPointAtDist ssn kc))
  (command "Break" td td "")  
  (princ)
 
(defun c:tt (/ ENT KC KCTR SS SSN TD)
  (vl-load-com)
  (while (null(setq ss (entsel "\n Chon doituong: "))))  
  (setq ssn (car ss))
  (setq ent (entget ssn))
  (setq kc (getreal "\n Nhap khoang cach: "))
  (setq td (vlax-curve-getPointAtDist ssn kc))
  (command "Break" td td "")  
  (princ)

<<

Filename: 261123_tt.lsp
Tác giả: 18011985
Bài viết gốc: 261140
Tên lệnh: tt
Cắt pline theo chiều dài cho trước

Tặng bạn VOI rồi. Giờ tặng bạn HAI BÀ TRƯNG

(defun c:tt (/ C10 C40 C41 C42 C50 C70 CC40 CC41 CC42 DINH ENT2 I N N10 N40 N41 N42 N50 N70 NC40 NC41 NC42 OSMODEC SSN2 TEST0 TEST1 TEST2)

  (vl-load-com)
  (setq osmodec (getvar "osmode"))
  (setvar "osmode" 1)
  (while (null(setq ss (entsel "\n Chon doituong: ")))) 
  (setq ssn (car ss))
  (setq ent (entget...

>>

Tặng bạn VOI rồi. Giờ tặng bạn HAI BÀ TRƯNG

(defun c:tt (/ C10 C40 C41 C42 C50 C70 CC40 CC41 CC42 DINH ENT2 I N N10 N40 N41 N42 N50 N70 NC40 NC41 NC42 OSMODEC SSN2 TEST0 TEST1 TEST2)

  (vl-load-com)
  (setq osmodec (getvar "osmode"))
  (setvar "osmode" 1)
  (while (null(setq ss (entsel "\n Chon doituong: ")))) 
  (setq ssn (car ss))
  (setq ent (entget ssn))
  (setq dinh (getpoint "\n Chon diem dau: "))
  (if (= (cdr(assoc 0 ent)) "POLYLINE")
    (progn
      (setq test1 (vlax-curve-getEndPoint ssn))
      (setq test2 (vlax-curve-getStartPoint ssn))
      (if (=(cdr(assoc 66 ent)) 1)
(progn
   (setq ssn2 (entnext ssn))
   (setq ent2 (entget ssn2))
   (setq test0 (cdr(assoc 10 ent2)))
   (if (or(equal dinh test1 0.00001)(equal test1 test2))
     (progn
       (setq c42 (append c42 (list(cons 42 0))))
       (setq c40 (append c40 (list(cons 40 0))))
       (setq c41 (append c41 (list(cons 41 0))))
       (While(/= (cdr(assoc 0 ent2)) "SEQEND")
  (setq c10 (append c10 (list(assoc 10 ent2))))
  (setq c40 (append c40 (list(assoc 40 ent2))))
  (setq c41 (append c41 (list(assoc 41 ent2))))
  (setq c42 (append c42 (list(assoc 42 ent2))))
  (setq c70 (append c70 (list(assoc 70 ent2))))
  (setq c50 (append c50 (list(assoc 50 ent2))))
  (setq ssn2 (entnext ssn2))
  (setq ent2 (entget ssn2))
  );end while
       (setq n (- (length c42) 2))
       (setq i 0)
       (while (<= i n)
  (setq nc42 (append nc42 (list(nth i c42))))
  (setq nc40 (append nc40 (list(nth i c40))))
  (setq nc41 (append nc41 (list(nth i c41))))
  (setq i (1+ i))
  );end while
       (setq i 1)
       (while (<= i n)
  (setq cc42 (append cc42 (list(nth i c42))))
  (setq cc41 (append cc41 (list(nth i c41))))
  (setq cc40 (append cc40 (list(nth i c40))))
  (setq i (1+ i))
  );end while
       (setq c42 nil c42 cc42 c41 nil c41 cc41 c40 nil c40 cc40)
       (setq ss (ssget "_P"))
       (setq ent (entget ssn))
       (if (=(cdr(assoc 66 ent)) 1)
  (progn
    (setq i 0)
    (setq ssn2 (entnext ssn))
    (setq ent2 (entget ssn2))
    (setq n10 (reverse c10))
    (setq n40 (reverse nc40))
    (setq n41 (reverse nc41))
    (setq n42 (reverse nc42))
    (setq n70 (reverse c70))
    (setq n50 (reverse c50))
    (While(/= (cdr(assoc 0 ent2)) "SEQEND")
      (setq ent2 (subst (nth i n10) (nth i c10) ent2))
      (setq ent2 (subst (cons 40 (cdr(nth i n41))) (nth i c40) ent2))
      (setq ent2 (subst (cons 41 (cdr(nth i n40))) (nth i c41) ent2))
      (setq ent2 (subst (cons 42 (- 0 (cdr(nth i n42)))) (nth i c42) ent2))
      (setq ent2 (subst (nth i n70) (nth i c70) ent2))
      (setq ent2 (subst (nth i n50) (nth i c50) ent2))
      (entmod ent2)
      (setq i (1+ i))
      (setq ssn2 (entnext ssn2))
      (setq ent2 (entget ssn2))
      );end while
    (entupd ssn)
    );end progn
  );end if
       );end progn
     );end if
   );end progn
);end if
      );end progn
    );end if 
  (setq kc (getreal "\n Nhap khoang cach: "))
  (setq td (vlax-curve-getPointAtDist ssn kc))
  (setvar "osmode" 0)
  (command "Break" td td "") 
  (princ)
  )

:D


<<

Filename: 261140_tt.lsp
Tác giả: 18011985
Bài viết gốc: 261326
Tên lệnh: tes
Loại phần tử giống nhau trong list

Mình đang cần loại bỏ phần tử giống nhau trong 1 biến list. Nhưng không được. Mình tìm trên Diễn đàn có của bác TUEVN nhưng up vào lisp không làm được. Các bác sửa giúp em.

(defun c:tes (/ a)

  (setq a (list(558911.0 2.37805e+006 130.0) (558906.0 2.37805e+006 129.0) (558902.0 2.37805e+006 128.0) (558899.0 2.37804e+006 127.0) (558896.0 2.37804e+006 126.0) (558894.0 2.37804e+006 125.0) (558892.0 2.37804e+006 124.0) (558890.0...

>>

Mình đang cần loại bỏ phần tử giống nhau trong 1 biến list. Nhưng không được. Mình tìm trên Diễn đàn có của bác TUEVN nhưng up vào lisp không làm được. Các bác sửa giúp em.

(defun c:tes (/ a)

  (setq a (list(558911.0 2.37805e+006 130.0) (558906.0 2.37805e+006 129.0) (558902.0 2.37805e+006 128.0) (558899.0 2.37804e+006 127.0) (558896.0 2.37804e+006 126.0) (558894.0 2.37804e+006 125.0) (558892.0 2.37804e+006 124.0) (558890.0 2.37804e+006 123.0) (558887.0 2.37804e+006 122.0) (558885.0 2.37804e+006 121.0) (558883.0 2.37804e+006 120.0) (558881.0 2.37804e+006 119.0) (558878.0 2.37804e+006 118.0) (558875.0 2.37803e+006 117.0) (558872.0 2.37803e+006 116.0) (558872.0 2.37803e+006 116.0) (558870.0 2.37803e+006 115.0) (558869.0 2.37803e+006 114.0) (558867.0 2.37803e+006 113.0) (558865.0 2.37803e+006 112.0) (558863.0 2.37803e+006 111.0) (558862.0 2.37803e+006 110.0) (558862.0 2.37803e+006 110.0) (558860.0 2.37803e+006 109.0) (558858.0 2.37803e+006 108.0) (558857.0 2.37803e+006 107.0) (558855.0 2.37803e+006 106.0) (558853.0 2.37803e+006 105.0) (558852.0 2.37803e+006 104.0) (558850.0 2.37803e+006 103.0) (558849.0 2.37802e+006 102.0) (558847.0 2.37802e+006 101.0) (558845.0 2.37802e+006 100.0) (558843.0 2.37802e+006 99.0) (558842.0 2.37802e+006 98.0) (558840.0 2.37802e+006 97.0) (558838.0 2.37802e+006 96.0) (558836.0 2.37802e+006 95.0) (558834.0 2.37802e+006 94.0) (558832.0 2.37802e+006 93.0) (558830.0 2.37802e+006 92.0) (558828.0 2.37802e+006 91.0) (558826.0 2.37802e+006 90.0) (558824.0 2.37801e+006 89.0) (558823.0 2.37801e+006 88.0) (558821.0 2.37801e+006 87.0) (558819.0 2.37801e+006 86.0) (558817.0 2.37801e+006 85.0) (558815.0 2.37801e+006 84.0) (558813.0 2.37801e+006 83.0) (558813.0 2.37801e+006 83.0) (558812.0 2.37801e+006 82.0) (558810.0 2.37801e+006 81.0) (558810.0 2.37801e+006 81.0) (558810.0 2.37801e+006 81.0) (558810.0 2.37801e+006 81.0) (558808.0 2.37801e+006 80.0) (558806.0 2.37801e+006 79.0) (558804.0 2.37801e+006 78.0) (558802.0 2.37801e+006 77.0) (558800.0 2.37801e+006 76.0) (558798.0 2.378e+006 75.0) (558796.0 2.378e+006 74.0) (558795.0 2.378e+006 73.0) (558793.0 2.378e+006 72.0) (558789.0 2.378e+006 71.0) (558784.0 2.378e+006 70.0) (558784.0 2.378e+006 70.0) (558784.0 2.378e+006 70.0) (558784.0 2.378e+006 70.0) (558784.0 2.378e+006 70.0)))
  (defun relist (lst / lst1)
;;;writen by Tue_NV
  (foreach x lst
   (if (not (member x lst1)) (setq lst1 (append lst1 (list x))))
   (Progn
   (foreach y lst1
   (if (equal y x 1.0e-8)
   (setq lst1 (vl-remove y lst1))
   )
)
   (setq lst1 (append lst1 (list x)) )
    )
)
    lst1
    )
  (relist a)
  (princ a)
  (princ)
  )


<<

Filename: 261326_tes.lsp
Tác giả: 18011985
Bài viết gốc: 261372
Tên lệnh: tt
Loại phần tử giống nhau trong list

ops sorry bác.

Để em ngăt phần không liên quan.

(defun c:tt (/ E1 E2 ELE ELE1 PLST PST SSL)

  ;;;;----------------------------Relist------------------------------
  (defun relist (lst / lst1)
;;;writen by Tue_NV
  (foreach x lst
   (if (not (member x lst1)) (setq lst1 (append lst1 (list x))))
   (Progn
   (foreach y lst1
   (if (equal y x 1.0e-8)
   (setq lst1 (vl-remove y lst1))
   );end if
);end...

>>

ops sorry bác.

Để em ngăt phần không liên quan.

(defun c:tt (/ E1 E2 ELE ELE1 PLST PST SSL)

  ;;;;----------------------------Relist------------------------------
  (defun relist (lst / lst1)
;;;writen by Tue_NV
  (foreach x lst
   (if (not (member x lst1)) (setq lst1 (append lst1 (list x))))
   (Progn
   (foreach y lst1
   (if (equal y x 1.0e-8)
   (setq lst1 (vl-remove y lst1))
   );end if
);end Foreach
   (setq lst1 (append lst1 (list x)))
    );end progn
);end Foreach
    )
  ;;;;;-------------------------Chay chuong trinh----------------------
(princ "\n Chon duong dong muc: ")
(setq ssl (acet-ss-to-list (ssget))
          plst (list)
          e2 (car (entsel "\n Chon duong tim")))
  ;;;;--------------------------Tim giao diem khong gian------------------------
(foreach en ssl
       (cond
             ((= (cdr (assoc 0 (entget en))) "LWPOLYLINE") (setq ele (cdr (assoc 38 (entget en)))))
             ((= (cdr (assoc 0 (entget en))) "POLYLINE")(setq ele (last (cdr (assoc 10 (entget en))))))      
             ((= (cdr (assoc 0 (entget en))) "LINE") (setq ele (last (cdr (assoc 10 (entget en))))))
      ((= (cdr (assoc 0 (entget en))) "TEXT") (progn (setq ele 0)(setq ele1 (cdr (assoc 10 (entget en))))))
             (T (setq ele nil))
       )
      (if ele
(progn
   (if (= ele 0)
     (progn
       (setq plst (append plst (list ele1)))
       )
     (progn
       (command "copy" e2 "" (list 0 0 0) (list 0 0 ele))
       (setq e1 (entlast)
      plst (append plst (acet-geom-intersectwith e1 en 0)) )
       (command "erase" e1 "")
       )
     )
   )
)
  )
  ;;;;;;;-----------------------------Sap xep va xoa diem trung--------------------------
  (setq plst (relist plst))
  (setq pst (vlax-curve-getStartPoint e2))
  (setq plst (vl-sort plst '(lambda (x y) (< (distance pst (list (car x) (cadr x) 0)) (distance pst (list (car y) (cadr y) 0))))))
  )

Bác xem giúp hộ em nhé.


<<

Filename: 261372_tt.lsp
Tác giả: gia_bach
Bài viết gốc: 261298
Tên lệnh: dc
Cắt pline theo chiều dài cho trước

Tham khảo Lisp chia Curve tôi viết cách đây 4 năm : link here 

(defun c:DC(/ vl ov Ent isClosed lst_pt dis dis0 bit khcach sodoan p pt ); DC -> Divide Curve
  (if (and (setq Ent (car (entsel "\nChon doi tuong can chia :")))
	   (wcmatch (cdr (assoc 0 (entget ent))) "*POLYLINE,LINE,ARC")
	   (not (setq isClosed...
>>

Tham khảo Lisp chia Curve tôi viết cách đây 4 năm : link here 

(defun c:DC(/ vl ov Ent isClosed lst_pt dis dis0 bit khcach sodoan p pt ); DC -> Divide Curve
  (if (and (setq Ent (car (entsel "\nChon doi tuong can chia :")))
	   (wcmatch (cdr (assoc 0 (entget ent))) "*POLYLINE,LINE,ARC")
	   (not (setq isClosed (vlax-curve-isClosed ent)))  )
    (progn
      (command "undo" "be")
      (setq vl '("osmode" "orthomode" "cmdecho")
	    ov (mapcar 'getvar vl)) 
      (mapcar 'setvar vl '(0 0 0))      
      
      (setq lst_Pt nil
	    dis0 (vlax-curve-getDistAtParam Ent (vlax-curve-getEndParam Ent))  )
      (initget "K D")
      (setq bit (getkword "\nChia theo Khoang cach hay chia deu theo so Doan <K/D>: " ) )
      (if (= bit "K")
	(progn
	  (or *khcach* (setq *khcach* 250))
	  (setq khcach (getreal (strcat"\nNhap khoang cach <" (rtos *khcach*) ">:")) )
	  (if khcach (setq *khcach* khcach) (setq khcach *khcach*))
	  (initget "G B")
	  (setq bit (getkword "\nCan Giua hay can tu Bien <G/B>: " ) )
	  (if (= bit "G")
	    (progn
	      (setvar "osmode" 513)
	      (setq p (getpoint (vlax-curve-getPointAtDist Ent (/ dis0 2))"\nDiem bat dau:"))
	      (if (< (distance p (vlax-curve-getStartPoint ent))(distance p (vlax-curve-getEndPoint ent)))
		(setq dis 0)
		(setq dis (rem dis0 khcach)) )   )
	    (setq dis (/(rem dis0 khcach)2))  ) )
	(progn
	  (or *sodoan* (setq *sodoan* 10))
	  (setq sodoan (getint (strcat"\nNhap so doan <" (itoa *sodoan*) ">:")) )
	  (if sodoan (setq *sodoan* sodoan) (setq sodoan *sodoan*))
	  (setq dis 0
		khcach (/ dis0 sodoan) ) )	)
      (while (< dis dis0)
	(setq pt (vlax-curve-getPointAtDist Ent dis)
	      dis (+ dis khcach)
	      lst_Pt (append lst_Pt (list pt)) ))
      (if lst_Pt
	(foreach pt (reverse lst_Pt)
	  (command "._break" ent "_non" (trans pt 0 1) "_non" (trans pt 0 1)) ))
      (mapcar 'setvar vl ov)
      (command "undo" "e")  )
    (if isClosed
      (alert "List khong chay duoc tren doi tuong kin ")
      (alert "Khong chon duoc doi tuong !")))
  (princ))

<<

Filename: 261298_dc.lsp
Tác giả: sgcq
Bài viết gốc: 261497
Tên lệnh: tlset utl tlc tlf tl settl atc
Nhờ các cao thủ viết giúp lisp chải mái ta luy

:D :D :D

Bác tét xem cái lược này có OK ko?

 

;;;=======================================
;;; TLF draw fill
;;; TLC draw cut
;;; TLSET Set global variable for double tl
;;; SETTL  set for single tl
;;; TL draw single TL
;;; USES WORLD COORDINATE SYSTEM
(setq distmin 1.0)
(setq distmax 3.5)
(setq segmin 1.0)
;====================================================================
(setq distmin 0.5) ; min distance between segment
(setq...
>>

:D :D :D

Bác tét xem cái lược này có OK ko?

 

;;;=======================================
;;; TLF draw fill
;;; TLC draw cut
;;; TLSET Set global variable for double tl
;;; SETTL  set for single tl
;;; TL draw single TL
;;; USES WORLD COORDINATE SYSTEM
(setq distmin 1.0)
(setq distmax 3.5)
(setq segmin 1.0)
;====================================================================
(setq distmin 0.5) ; min distance between segment
(setq distmax 1.5) ; max distance between segment
(setq segmin 0.25) ; khoang cach noi suy khi ve ta luy
(setq kctl 1) ; distance between line
(setq dngan 1) ; Length of short line
(setq ddai 2) ; Length of long line
(setq chieutl 1)
(setq chieutl 1)
;=================================================================
;============== Doc toa do duong polyline =====
(defun readpl (pl / e l  ds p)
  (if (not (equal pl etcam)) (progn
    (setq ds '())
    (setq e (entget pl))
    (setq l (cdr (assoc 0 e)))
    (if (= l "lwPOLYLINE")
        (progn
          (setq pl (entnext pl))
          (setq e (entget pl))
          (setq l (cdr (assoc 0 e)))
          (while  (= l "VERTEX")
                (setq p (cdr (assoc 10 e)))
                (setq ds (cons p ds))
                (setq pl (entnext pl))
                (setq e (entget pl))
                (setq l (cdr (assoc 0 e)))
          )
        )
    )
    (if (= l "LINE")
        (setq ds (list
                    (cdr(assoc 11 e))
                    (cdr(assoc 10 e))
                )
        )  
    )
    (setq ds (reverse ds))
    (if (= l "LWPOLYLINE")
      (setq ds (xddstd pl)  )
    )
 ))
    (setq ds ds)
)
;;;--- Setup for taluy --
(defun c:tlset (/ mi ma mg)
    (setq mi (getreal (strcat "Min Distance : " ) ))
    (if mi (setq distmin mi))
    (setq ma (getreal (strcat "Max Distance : " ) ))
    (if ma (setq distmax ma))
    (setq mg (getreal (strcat "Segmin  : " ) ))
    (if mg (setq segmin mg))
)
;;;---- lay ds td cua pline --
(defun xddstd ( pl / e ds len td1 p)
  (setq e (entget pl))
  (if (=(cdr (assoc 0 e) ) "LWPOLYLINE")
    (progn 
        (setq len (length e))
        (setq td1 0) 
        (repeat len
          (setq p (nth td1 e))
          (setq td1 (+ 1 td1))
          (if (= (car p) 10) 
              (setq ds (cons (cdr p) ds ))  
          )
        )
    )
  )
(setq ds (reverse ds))
)
;;;--- Xac dinh doan gan nhat --
(defun xdmin(dstd p / p1 p2 len td2 d dmin k)
    (setq len (length dstd))
    (setq td2 0)
    (setq k td2) 
    (setq dmin (distance (car dstd) p))
    (repeat (-  len 1)
      (setq p1 (nth td2 dstd))
      (setq td2 (+ td2 1))    
      (setq p2 (nth td2 dstd))
      (setq d (distance p1 p))
      (if (< d dmin)
          (progn
            (setq  dmin d)
            (setq k (- td2 1))
          )
      )
      (setq d (distance p2 p))
      (if (< d dmin)
          (progn
            (setq  dmin d)
            (setq k td2)
          )
      )
    ) 
(if (> k 0)
  (setq td2 (- k 1))
  (setq td2 0) 
)
(setq p1 (nth td2 dstd))
(setq td2 (+ td2 1))    
(setq p2 (nth td2 dstd))
(list p1 p2)
)
;----- Xac dinh chieu p - pl
(defun chieu ( p / ds a1 a2 a c)
  ;(setq ds (xddstd pl)) 
  (setq ds ds111 )
  (setq ds111 ds)
  (if ds (progn
    (setq ds (xdmin ds p))
    (setq a1 (angle (car ds) (cadr ds) ))
    (setq a2 (angle (car ds) p ))
    (setq a (- a2 a1))
    ;(if (and (> a 0) (< a pi))
    (if  (> (sin a)  0)
        (setq c 1)
        (setq c -1)
    )
  ))
(setq c c)
)
;;;- ke mot duong thang  ---
(defun mkl (p1 p2 / e)
  (setq p1 (cons 10 p1)  ) 
  (setq p2 (cons 11 p2)  ) 
  (setq e (list
      '(0 . "LINE")
      p1
      p2 
  ))  
  (entmake e)
)
;=================================
;;;============================================================
;;; Ve duong taluy
(defun tlx (/ dsp pl  p1 p2 ag  pc pl1 td3 l sumdist dist pv overdist cl el pchieu)
  (setq ds111 nil)
  (setq pl (entsel "First Polyline"))
  (redraw (car pl) 3)
  (setq pl1 (entsel "\n Second Polyline"))
  (redraw (car pl1) 3)
  ;(setq pchieu (getpoint "\nside of Polyline"))
  (setq pchieu (cadr pl1)) 
  (redraw (car pl) 3)
  (redraw (car pl1) 3)
  (if (and pl pl1) (progn
    ;;;--------------------- 
    ;(setq dsp (xddstd (car pl))) 
    (setq ds111 (dspm pl segmin))
    (setq dsp ds111)
    (setq dsxoa (ssadd)) 
    (setq pc (cadr pl1))
    (setq pl1 (car pl1)) 
    ;------------------------
    (setq chieutl (chieu  pchieu)) 
    (setq td3 0)
    (setq l (-(length dsp)1)) 
    (setq sumdist 0)
    ;--------
    (while (< td3 l)
        (progn
          (setq distover (- sumdist))
          (setq p1  (nth td3 dsp)) 
          (setq td3 (+ td3 1)) 
          (setq p2  (nth td3 dsp))
          (setq sumdist (distance p1 p2))
          (setq pv (angle p1 p2))
          (setq  p1 (polar p1 pv distover) );jjjj
          (setq sumdist (- sumdist distover)) 
          (while (> sumdist 0)
              (setq dist (veline p1 pv chieutl pl1))
              (if (or (not dist) (< dist distmin))
                  (setq dist distmin) 
              )
              (if (> dist distmax)
                  (setq dist distmax)
              ) 
              (setq  p1 (polar p1 pv dist) )
              (setq sumdist (- sumdist dist)) 
          ) 
        )  
    ) 
    ;-------
  ))  
  (setq dscuoi dsxoa)
)
;----- Xoa cuoi ---
(defun c:utl ()
  (command "ERASE" dsxoa "")
)
;---- Ve 1 duong va keo dai -----
(defun veline ( p1 agd chieutl pl1 / ag vd kq dist ec em)
                (setq ag (+ agd (*(/ pi 2)chieutl)) )  
                (setq p2 (polar p1 ag segmin)) 
                (mkl p1 p2)
                ;------------------ 
                (setq vd (entlast)) 
                (REDRAW VD 3)
                (setq ec (entget vd)) 
                (setq vd (list vd p2)) 
                (command "EXTEND" pl1 "" vd ""  ) 
                (setq vd (car vd))
                (setq em (entget vd))
                (if (equal ec em)
                    (entdel vd)
                    (progn
                        (setq p1 (cdr (assoc 10 em)))
                        (setq p2 (cdr (assoc 11 em)))
                        (setq kq (/(mykc p1 p2)2))
                        (setq dsxoa (ssadd vd dsxoa)) 
                    )
                )  
(setq kq kq)
)
;---- doi thanh doan dap ------
(defun nganf (vd / e p1 p2 d)
  (if vd (progn
      (setq e (entget vd)) 
      (setq p1 (cdr (assoc 10  e ) ))
      (setq p2 (cdr (assoc 11  e ) ))
      (setq d (/(mykc p1 p2)2))
      (if (> d distmax)
        (setq d distmax)
      )
      (setq pv (angle p1 p2)) 
      (setq p2 (polar p1 pv d))
      (setq e (subst (cons 11 p2) (assoc 11 e) e ))  
      (entmod e)
      (entupd vd)
  ))
)
;---- ve ta luy dao --
(defun c:tlc ( / l td4 e)
    (command "UNDO" "group")
    (setq dscuoi nil) 
    (command "LAYER" "m" "TLCUT" "") 
    (tlx) 
    (if dscuoi
      (progn
          (setq l (sslength dscuoi))
          (setq td4 0)
          (repeat (+(/ l 2)1)
            (setq e (ssname dscuoi td4)) 
            (setq td4 (+ td4 2))
            (nganc e) 
          )  
      )  
    ) 
    (command "UNDO" "end")
)
;---- doi thanh doan dao ------
(defun nganc (vd / e p1 p2 d)
  (if vd (progn
      (setq e (entget vd)) 
      (setq p1 (cdr (assoc 10  e ) ))
      (setq p2 (cdr (assoc 11  e ) ))
      (setq d (/(mykc p1 p2)2))
      (if (> d distmax)
        (setq d  distmax)
      )
      (setq pv (angle p2 p1)) 
      (setq p1 (polar p2 pv d))
      (setq e (subst (cons 10 p1) (assoc 10 e) e ))  
      (entmod e)
      (entupd vd)
  ))
)
;---- ve ta luy dap --
(defun c:tlf ( / l td5 e)
    (command "UNDO" "group")
    (command "LAYER" "m" "TLFIL" "") 
    (setq dscuoi nil) 
    (tlx)
    (if dscuoi
      (progn
          (setq l (sslength dscuoi))
          (setq td5 0)
          (repeat (+(/ l 2)1)
            (setq e (ssname dscuoi td5)) 
            (setq td5 (+ td5 2))
            (nganf e) 
          )  
      )  
    ) 
    (command "UNDO" "end")
)
;-- tinh kc 2 diem ---
(defun mykc (p1 p2 / x1 y1 x2 y2 dx dy)
  (setq x1 (car p1))
  (setq y1 (cadr p1))
  (setq x2 (car p2))
  (setq y2 (cadr p2))
  (setq dx (- x2 x1)) 
  (setq dy (- y2 y1))
  (sqrt (+(* dx dx) (* dy dy)))
)
;--- Lay danh sach diem bang mesure ---
(defun dspm (e segmin /  el p dskq sst l)
  ;(setq e (entsel))
  (setq el (entlast)) 
  (setq sst (ssadd))
  (command "MEASURE" e segmin)
  (setq el (entnext el))
  (while el
      (setq p (cdr (assoc 10  (entget el) ) ))
      (setq l (cdr (assoc 0  (entget el) ) ))
      (if (and (= l "POINT") p)
        (setq dskq (cons p dskq))
      )
      (setq sst (ssadd el sst))
      (setq el (entnext el))
  )

(setq dskq (reverse dskq))
) 
;;;=======================================
TL - Ve taluy 
;;;=======================================
;;; Ve ta luy
;;;-------------------------
;;; Ve duong taluy
(defun c:tl (/ pl  el e0 es p1 p2 ag ss ek cl  pc)
  (command "UNDO" "group")
  (command "LAYER" "m" "slopes" "")
  (setq pl (entsel))
  (if pl (progn
    (setq pc (getpoint "Side of TL"))
    (setq chieutl (chieupl (car pl) pc )) 
    (setq el (entlast)) 
    (command "MEASURE" pl kctl)
    (setq ek (entlast)) 
    (setq ss (ssadd))
    ;--------
    (while (and el
                (not (equal el ek) )
            )
      (setq el (entnext el)) 
      (if el (setq ss (ssadd el ss)) )
      (if el  
            (setq es (entnext el))
      )
      (if (and el es (= (cdr (assoc 0 (entget el))) "POINT") ) 
        (progn
          (setq p1 (cdr(assoc 10 (entget el)))    )
          (setq p2 (cdr(assoc 10 (entget es)))    )
          ;------------- 
          (if (not(equal el ek))(progn
                (setq ag (angle p1 p2))
                (setq ag (+ ag (*(/ pi 2)chieutl)) )  
          )) 
          (if cl 
              (setq p2 (polar p1 ag dngan)) 
              (setq p2 (polar p1 ag ddai)) 
          ) 
          (if cl
              (setq cl nil)
              (setq cl 1)
          ) 
          ;(command "LINE" p1 p2 "")
          (mkl p1 p2)
          ;---------------------
        )  
      ) 
    ) 
    ;-------
    
  ))  
  (command "UNDO" "end")
)
;----------------
;----- Xac dinh chieu p - pl
(defun chieupl (pl p / ds a1 a2 a c)
  ;(setq ds (xddstd pl)) 
  (setq c 1)
  (setq ds (readpl pl)) 
  (if ds (progn
    (setq ds (xdmin ds p))

    (setq a1 (angle (car ds) (cadr ds) ))
    (setq a2 (angle (car ds) p ))
    (setq a (- a2 a1))
    (if (and (> a 0) (< a pi))
        (setq c 1)
        (setq c -1)
    )
  ))
(setq c c)
)

;;;;;;;;;;;;;;;
(defun c:settl (/ a1 a2 a3)
    (setq a1 (getstring (strcat "Distance between line " (rtos kctl 2 2) ": "  ) )) 
    (setq a2 (getstring (strcat "\nLength of short line " (rtos dngan 2 2)": "  ) )) 
    (setq a3 (getstring (strcat "\nLength of long line " (rtos ddai 2 2) ": " ) )) 
    (if (/= a1 "")
      (setq kctl (atof a1))
    ) 
    (if (/= a2 "")
      (setq dngan (atof a2))
    ) 
    (if (/= a3 "")
      (setq ddai (atof a3))
    ) 
)

;========= AUTO CONNECT 2d POLYLINE ==========
;;;; auto conevt 2 pl
(defun c:atc (/ ss ss1 ss2 l td6 e0 l1 t1 e1 co)
 (command "UNDO" "Group")
 (setq co (getstring "Do you want to joint 2D LINE :" ))
 (if (= (strcase co nil) "Y") (progn

  (ltopl)
  (setq ss (ssget "X" '((0 . "lwPOLYLINE" ) )  ))
  (if ss (progn
      (setq ss1 ss)
      (setq l (sslength ss))
      (setq td6 0)
      (repeat l
        (setq e0 (ssname ss td6))
        (setq td6 (+ td6 1))
        (if (and (entget e0) (> (sslength  ss1) 0)  ) (progn
              (command "PEDIT" e0 "J" ss1 "" "")
        ))
        (setq ss1 (locss ss1))
      )
  ))
  ))
  (command "UNDO" "end")
)
;;;; auto conevt 2 Line
(defun ltopl (/ ss ss1 ss2 l td7 e0 l1 t1 e1 eg p1 p2)
  (setq ss (ssget "X" '((0 . "LINE" ) )  ))
  (if ss (progn
      (setq ss1 ss)
      (setq l (sslength ss))
      (setq td7 0)
      (repeat l
        (setq e0 (ssname ss td7))
        (setq td7 (+ td7 1))
        (setq eg (entget e0))
        (setq p1 (cdr (assoc 10 eg) ))
        (setq p2 (cdr (assoc 11 eg) ))
        (if (= (nth 2 p1) (nth 2 p2))
              (command "PEDIT" e0 "Y"  "" )
        )
      )
  ))
 ;))
)
;;-----------------------------------
(defun locss (ss1 / ss2 l1 t1 e1)
        (if ss1 (progn
            (setq l1 (sslength ss1))
            (setq t1 0)
            (setq ss2 (ssadd) )
            (repeat l1
                (setq e1 (ssname ss1 t1))
                (setq t1 (+ t1 1))
                (if (entget e1)  (setq ss2 (ssadd e1 ss2) ))
            )
        ))
 (setq ss1 ss2)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

<<

Filename: 261497_tlset_utl_tlc_tlf_tl_settl_atc.lsp
Tác giả: duy782006
Bài viết gốc: 262022
Tên lệnh: shopdrawing
Dùng Autolisp vẽ shop drawing tự động

-Dòng dùng hỏi chọn 1 điểm gán cho biến diemchon

(setq diemchon (getpoint "\nChon diem"))

-Dòng dùng hỏi nhập một giá trị số gán cho biến sonhap

(setq sonhap (getreal "\nSo can nhap: "))

-Dòng xác định một điểm từ 1 điểm cho trước theo phương cho trước với độ dài cho trước.

(setq diemtim (polar diemcoso goc dodai))

Lưu ý góc ở đây tính bằng radian. Pi = 180độ cứ thế mà...

>>

-Dòng dùng hỏi chọn 1 điểm gán cho biến diemchon

(setq diemchon (getpoint "\nChon diem"))

-Dòng dùng hỏi nhập một giá trị số gán cho biến sonhap

(setq sonhap (getreal "\nSo can nhap: "))

-Dòng xác định một điểm từ 1 điểm cho trước theo phương cho trước với độ dài cho trước.

(setq diemtim (polar diemcoso goc dodai))

Lưu ý góc ở đây tính bằng radian. Pi = 180độ cứ thế mà tính.

-Dòng vẽ line từ điểm a đến điểm b.

(command ".line" a b "")

 

Vậy sơ bộ lisp như sau:

(defun c:shopdrawing ()
(setq diemchon (getpoint "\nChon diem de ve"))
(setq soa (getreal "\nnhap gia tri A: "))
(setq sob (getreal "\nnhap gia tri B: "))
(setq diemngang (polar diemchon pi soa))
(setq diemdoc (polar diemchon (/ pi 2) sob))
(command ".line" diemngang diemchon diemdoc "")
(princ)
)

 

Đại khái là thế cái sườn đó bạn dựa vào mà viết. Nếu u u minh minh quá thì theo học lớp lisp của két xù nhé.


<<

Filename: 262022_shopdrawing.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 262299
Tên lệnh: giao
Đố vui

Quick code cho Haanh đây. Tìm giao của khối 3D và Line, đồng thời Trim phần Line nằm bên trong khối 3D. Lệnh: TR3D

P/S: edit 12h05' - 4/11/2013

;; Doan Van Ha - CADViet.com - Ngay 03/11/2013
;; Chuc nang: tim giao cua line voi 3DSolid va trim phan line nam ben trong solid.
(defun C:TR3D ( / #Inter:2Ent #List:UniqueFuzz lst sol lin lin1 p3 rec reg g1 g2)
 (setq osm (getvar "osmode") cmd (getvar "cmdecho"))...
>>

Quick code cho Haanh đây. Tìm giao của khối 3D và Line, đồng thời Trim phần Line nằm bên trong khối 3D. Lệnh: TR3D

P/S: edit 12h05' - 4/11/2013

;; Doan Van Ha - CADViet.com - Ngay 03/11/2013
;; Chuc nang: tim giao cua line voi 3DSolid va trim phan line nam ben trong solid.
(defun C:TR3D ( / #Inter:2Ent #List:UniqueFuzz lst sol lin lin1 p3 rec reg g1 g2)
 (setq osm (getvar "osmode") cmd (getvar "cmdecho")) (command "undo" "be") (or cal (arxload "geomcal")) (command "ucs" "w")
 (defun #Inter:2Ent(ent1 ent2 flag / l r)
  (setq l (vlax-invoke (vlax-ename->vla-object ent1) 'intersectwith (vlax-ename->vla-object ent2) flag))
  (repeat (/ (length l) 3)
   (setq r (cons (list (car l) (cadr l) (caddr l)) r) l (cdddr l)))
  (reverse r))
 (defun #List:UniqueFuzz(l f / x r)
  (while l
   (setq x (car l) l (vl-remove-if '(lambda(y) (equal x y f)) (cdr l)) r (cons x r)))
  (reverse r))
 (if
  (and
   (setq lin (car (entsel "\nChon Line: ")))
   (setq sol (car (entsel "\nChon khoi 3D: ")))
   (setq p3 (getpoint "\nChon 1 diem tren khoi 3D (nhung khong nam tren Line): ")))
  (progn
   (setvar "osmode" 0) (setvar "cmdecho" 0)
   (command "copy" lin "" '(0 0) '(0 0))
   (setq lin1 (entlast))
   (command "section" sol "" (cdr (assoc 10 (entget lin1))) (cdr (assoc 11 (entget lin1))) p3)
   (setvar "osmode" osm) (setvar "cmdecho" cmd)
   (setq reg (entlast))
   (setq lst (#List:UniqueFuzz (#Inter:2Ent lin1 reg acExtendNone) 1E-8))
   (cond
    ((= (length lst) 2) (setq p1 (car lst) p2 (cadr lst)) (command "trim" reg "" (cal "plt(p1,p2,0.5)") ""))
((= (length lst) 1) (setq p (getpoint "\nChon 1 diem tren Line va nam phia trong khoi 3D: ")) (setvar "osmode" 0) (setvar "cmdecho" 0) (command "trim" reg "" p ""))
((= (length lst) 0) (alert "Line khong cat khoi 3D nen khong Trim duoc."))
(T (alert "Line cat khoi 3D nhieu hon 2 diem nen khong Trim kieu nay duoc.")))
   (entdel reg) (entdel lin)))
 (command "ucs" "p") (command "undo" "e") (setvar "osmode" osm) (setvar "cmdecho" cmd)
 (princ))
(vl-load-com)
(princ "\nLenh su dung: TR3D")  
 
;; Doan Van Ha - CADViet.com - Ngay 03/11/2013
;; Chuc nang: tim giao cua line voi 3DSolid va trim phan line nam ben trong solid.
(defun C:TR3D ( / #Inter:2Ent #List:UniqueFuzz lst sol lin p3 rec reg g1 g2)
 (setq osm (getvar "osmode") cmd (getvar "cmdecho")) (command "undo" "be") (or cal (arxload "geomcal")) (command "ucs" "w")
 (defun #Inter:2Ent(ent1 ent2 flag / l r)
  (setq l (vlax-invoke (vlax-ename->vla-object ent1) 'intersectwith (vlax-ename->vla-object ent2) flag))
  (repeat (/ (length l) 3)
   (setq r (cons (list (car l) (cadr l) (caddr l)) r) l (cdddr l)))
  (reverse r))
 (defun #List:UniqueFuzz(l f / x r)
  (while l
   (setq x (car l) l (vl-remove-if '(lambda(y) (equal x y f)) (cdr l)) r (cons x r)))
  (reverse r))
 (if
  (and
   (setq lin (car (entsel "\nChon Line: ")))
   (setq sol (car (entsel "\nChon khoi 3D: ")))
   (setq p3 (getpoint "\nChon 1 diem tren khoi 3D (nhung khong nam tren Line): ")))
  (progn
   (setvar "osmode" 0) (setvar "cmdecho" 0)
   (command "section" sol "" (cdr (assoc 10 (entget lin))) (cdr (assoc 11 (entget lin))) p3)
   (setvar "osmode" osm) (setvar "cmdecho" cmd)
   (setq reg (entlast))
   (setq lst (#Inter:2Ent lin reg acExtendNone))
   (cond
    ((>= (length lst) 2) (setq lst (#List:UniqueFuzz lst 1E-8) p1 (car lst) p2 (cadr lst)) (command "trim" reg "" (cal "plt(p1,p2,0.5)") ""))
((= (length lst) 1) (setq p (getpoint "\nChon 1 diem tren Line va nam phia trong khoi 3D: ")) (setvar "osmode" 0) (setvar "cmdecho" 0) (command "trim" reg "" p ""))
((= (length lst) 0) (alert "Line khong cat khoi 3D nen khong Trim duoc.")))
   (entdel reg)))
 (command "ucs" "p") (command "undo" "e") (setvar "osmode" osm) (setvar "cmdecho" cmd)
 (princ))
(vl-load-com)
(princ "\nLenh su dung: TR3D")  

<<

Filename: 262299_giao.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 262299
Tên lệnh: tr3d
Đố vui

Quick code cho Haanh đây. Tìm giao của khối 3D và Line, đồng thời Trim phần Line nằm bên trong khối 3D.

(defun C:TR3D ( / #Inter:2Ent sol lin p3 rec reg lst g1 g2)

 (setq osm (getvar "osmode") cmd (getvar "cmdecho")) (command "undo" "be") (or cal (arxload "geomcal"))
 (defun #Inter:2Ent(ent1 ent2 flag / l r)
  (setq l (vlax-invoke (vlax-ename->vla-object ent1) 'intersectwith (vlax-ename->vla-object ent2)...
>>

Quick code cho Haanh đây. Tìm giao của khối 3D và Line, đồng thời Trim phần Line nằm bên trong khối 3D.

(defun C:TR3D ( / #Inter:2Ent sol lin p3 rec reg lst g1 g2)

 (setq osm (getvar "osmode") cmd (getvar "cmdecho")) (command "undo" "be") (or cal (arxload "geomcal"))
 (defun #Inter:2Ent(ent1 ent2 flag / l r)
  (setq l (vlax-invoke (vlax-ename->vla-object ent1) 'intersectwith (vlax-ename->vla-object ent2) flag))
  (repeat (/ (length l) 3)
   (setq r (cons (list (car l) (cadr l) (caddr l)) r) l (cdddr l)))
  (reverse r))
 (if
  (and
   (setq lin (car (entsel "\nChon Line: ")))
   (setq sol (car (entsel "\nChon khoi 3D: ")))
   (setq p3 (getpoint "\nChon 1 diem tren khoi 3D (nhung khong nam tren Line): ")))
  (progn
   (setvar "osmode" 0) (setvar "cmdecho" 0)
   (command "section" sol "" (cdr (assoc 10 (entget lin))) (cdr (assoc 11 (entget lin))) p3)
   (setvar "osmode" osm) (setvar "cmdecho" cmd)
   (setq reg (entlast))
   (setq lst (#Inter:2Ent lin reg acExtendNone))
   (cond
    ((= (length lst) 2) (setq p1 (car lst) p2 (cadr lst)) (command "trim" reg "" (cal "plt(p1,p2,0.5)") ""))
((= (length lst) 1) (setq p (getpoint "\nChon 1 diem tren Line va nam phia trong khoi 3D: ")) (setvar "osmode" 0) (setvar "cmdecho" 0) (command "trim" reg "" p ""))
((= (length lst) 0) (alert "Line khong cat khoi 3D nen khong Trim duoc.")))
   (entdel reg)))
 (command "undo" "e") (setvar "osmode" osm) (setvar "cmdecho" cmd)
 (princ))
(vl-load-com)
(princ "\nLenh su dung: TR3D")  
 

 

<<

Filename: 262299_tr3d.lsp
Tác giả: Tue_NV
Bài viết gốc: 53705
Tên lệnh: x%3Cspan+clas
Cần giúp về Lisp Scale 1 chiều !

Đây là đoạn Code Scale 1 chiều, Tue_NV đã cải tiến lại với lựa chọn thêm tham số R giống như Scale 2 chiều. Các bạn sử dụng và cho biết ý kiến thêm để Tue_NV hoàn thiện nhé.
Cảm ơn các bạn

Filename: 53705_x%3Cspan+clas.lsp
Tác giả: Tue_NV
Bài viết gốc: 44248
Tên lệnh: x%3Cspan+clas
Lisp scale theo 1 trục hay bị lỗi, nhờ sửa giúp !!!!
Líp của bạn không có lỗi gì cả. Tuy nhiên, có chỉnh sửa đôi chút để Lisp chạy tốt hơn

:cheers:

Filename: 44248_x%3Cspan+clas.lsp
Tác giả: gia_bach
Bài viết gốc: 262999
Tên lệnh: sxt
VIẾT LISP THEO YÊU CẦU

Đây là Lisp sắp xếp Text theo yêu cầu.

Do có 2 "Text đặt không đúng qui luật" nên k/quả bỏ qua.

(defun c:sxt(/ ent i lst nd oo p1 p2 pt ss ss_circle ss_txt stt)
  ;; By : Gia_Bach 2013 ;;
  (if (setq ss (ssget  (list(cons 0 "TEXT")(cons 1 "*d*@*")) ) )
    (progn
      (setq i 0)
      (repeat (sslength ss)
	(setq ent (entget (ssname ss i))
	      p1 (dxf 10 ent) nd (dxf 1 ent))
	(if (= (dxf 50...
>>

Đây là Lisp sắp xếp Text theo yêu cầu.

Do có 2 "Text đặt không đúng qui luật" nên k/quả bỏ qua.

(defun c:sxt(/ ent i lst nd oo p1 p2 pt ss ss_circle ss_txt stt)
  ;; By : Gia_Bach 2013 ;;
  (if (setq ss (ssget  (list(cons 0 "TEXT")(cons 1 "*d*@*")) ) )
    (progn
      (setq i 0)
      (repeat (sslength ss)
	(setq ent (entget (ssname ss i))
	      p1 (dxf 10 ent) nd (dxf 1 ent))
	(if (= (dxf 50 ent) 0) (setq p2 (polar p1 pi 426)) (setq p2 (polar p1 (* 3(/ pi 2)) 426)) )
	(if (setq ss_circle (ssget "c" p1 p2 (list(cons 0 "CIRCLE"))))
	  (progn
	    (setq oo (dxf 10 (entget(ssname ss_circle 0)))
		  p1 (polar oo (/ pi -4) 150) p2 (polar oo (* 3(/ pi 4)) 150) )
	    (if (setq ss_txt (ssget "c" p1 p2 (list(cons 0  "TEXT") ) ) )
	      (progn
		(setq stt (dxf 1 (entget(ssname ss_txt 0))))
		(if (setq stt (distof stt))
		  (setq lst (cons (cons stt nd) lst)))))))
	(setq i (1+ i)) )
      (if (> (length lst)0)
	(progn
	  (setq pt (getpoint "Diem dat text:"))
	  (command "undo" "be")
	  (foreach item  (vl-sort lst '(lambda (t1 t2) (< (car t1) (car t2))))
	    (setq stt (car item) nd (cdr item))
	    (entmake (list '(0 . "TEXT")(cons 10 pt)(cons 40 294)(cons 1(rtos stt 2 0))))
	    (entmake (list '(0 . "TEXT")(cons 10(polar pt 0 1000))(cons 40 294)(cons 1 nd)))
	    (setq pt (polar pt(/ pi 2) -600)))
	  (command "undo" "e") ))))
  (princ))

<<

Filename: 262999_sxt.lsp
Tác giả: Tue_NV
Bài viết gốc: 65704
Tên lệnh: bg%3Cspan+clas
Hỏi cách thêm kí tự bất kỳ vào text

Tue_NV nâng cấp Lisp thêm text giữa theo ý của bạn

Các bạn sử dụng thử và cho mình biết ý kiến nhé.

Filename: 65704_bg%3Cspan+clas.lsp
Tác giả: hiepttr
Bài viết gốc: 261387
Tên lệnh: vli test d vc
Chương 5.5 : Bài tập

Bài 5 đánh trúng vào điểm yếu nhất của mình: Loạt hàm mapcar, lambda, Apply.

Tuy có hiểu đc đôi chút nhưng vẫn còn lơ mơ lắm lắm thầy Ket àh,

Thời gian này lại bận, tranh thủ đc tí nào thì đọc bài giảng & help nhưng mãi vẫn chưa thông :D :D :D

vẫn chưa hiểu cách tìm ra list 4 bằng cách nào ?! :P

 

Mình sửa lại mấy bài trước:

;Bai...
>>

Bài 5 đánh trúng vào điểm yếu nhất của mình: Loạt hàm mapcar, lambda, Apply.

Tuy có hiểu đc đôi chút nhưng vẫn còn lơ mơ lắm lắm thầy Ket àh,

Thời gian này lại bận, tranh thủ đc tí nào thì đọc bài giảng & help nhưng mãi vẫn chưa thông :D :D :D

vẫn chưa hiểu cách tìm ra list 4 bằng cách nào ?! :P

 

Mình sửa lại mấy bài trước:

;Bai 1:
;CHUONG TRINH VE LINE TU DIEM A DEN DIEM B, A & b DO NGUOI DUNG CHI DINH:
(defun c:VLI( / pa pb old)
(setq old (mapcar 'getvar '("osmode" "cmdecho")))
(mapcar 'setvar '("osmode" "cmdecho") '(0 0))
(princ "\nBAN DANG CHAY CHUONG TRINH VE LINE TU DIEM A DEN DIEM B !")
(initget 1)
(setq pa (getpoint "\nNhap diem A: "))
(initget 1)
(setq pb (getpoint pa "\nNhap diem B: "))
(command ".line" pa pb "")
(mapcar 'setvar '("osmode" "cmdecho") old)
(princ "\nDa ve xong !")
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Bai 2:
;VIET HAM (iPos n lst) TRA VE PHAN TU n TRONG LIST lst, GIA TRI AO TINH LA nil
(defun iPos(n lst)
(if (< n 1) nil (nth (- n 1) lst))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Bai 3:
;DUNG HAM GETDIST LAY KHOANG CACH, HIEN THONG BAO XEM NGUOI DUNG DA NHAP MOT KHOANG CACH NGUYEN HAY SO THUC
(defun c:test_d( / d1 so)
(getdist "\nVao khoang cach: ")
(setq d1 (getvar "lastprompt"))
(cond
	((numberp (setq so (read (substr d1 18))))
		(if (= so (fix so)) (princ "\nNguoi dung da nhap so nguyen !") (princ "\nNguoi dung da nhap so thuc !")))
	(t (princ "\nNguoi dung da pick 2 diem !"))
	)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Bai 4:
(defun c:VC( / r1 old)
(setq old (mapcar 'getvar '("osmode" "cmdecho")))
(mapcar 'setvar '("osmode" "cmdecho") '(0 0))
(initget 1)
(setq p (getpoint "\nChon tam: "))
(if (not r) (setq r 10))
(if (setq r1 (getdist p (strcat "\nBan kinh <" (rtos r 2 4)">: ")))
	(setq r r1))
(command ".circle" p r)
(mapcar 'setvar '("osmode" "cmdecho") old)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

<<

Filename: 261387_vli_test_d_vc.lsp
Tác giả: hiepttr
Bài viết gốc: 260522
Tên lệnh: jhh
[Hỏi]Mọi người hướng dẫn cách viết lisp mà mình muốn ?

Thể theo nguyện vọng này ở #181

http://www.cadviet.com/forum/topic/18-hatch/page-10

 

Và công việc của mình, mình viết một "cục gạch" như thế này:

 

(defun c:jhh(/ ent1 ss bo1 i bo2 ename)
(setq old (mapcar 'getvar '("osmode" "cmdecho")))
(mapcar 'setvar '("osmode" "cmdecho") '(0 0))
(command "undo"...
>>

Thể theo nguyện vọng này ở #181

http://www.cadviet.com/forum/topic/18-hatch/page-10

 

Và công việc của mình, mình viết một "cục gạch" như thế này:

 

(defun c:jhh(/ ent1 ss bo1 i bo2 ename)
(setq old (mapcar 'getvar '("osmode" "cmdecho")))
(mapcar 'setvar '("osmode" "cmdecho") '(0 0))
(command "undo" "be")
(initget 1)(setq ent1 (car (entsel "\nChon phan thu nhat: ")))
(command "-hatchedit" ent1 "b" "r" "n")
(setq bo1 (entlast))
(prompt "\nChon cac phan con lai: ")
(setq i 0)
(if (setq ss (ssget '((0 . "HATCH"))))
    (progn
        (princ "\nVui long doi...")
        (while (< i (sslength ss))
            (setq ename (ssname ss i))
            (command "-hatchedit" ename "b" "r" "n")
            (setq bo2 (entlast))
            (command "regen")
            (command "union" bo1 bo2 "")
            (setq bo1 (entlast)
                i (1+ i)
            )
        )
        (command "-hatch" "a" "h" "n" "" "p" "s" "s" bo1 "" "")
        (command "matchprop" ent1 "last" "")
        (princ "\nCoi nhu ngon an !\n")
        (command "erase" ent1 bo1 ss "")
    )
    (princ "\nChua chon duoc phan con lai !")
)
(command "undo" "end")
(mapcar 'setvar '("osmode" "cmdecho") old)
(princ)
)

 

Với 1 VD sơ sơ thì đã chạy được ngon lành

nhưng với 1 số bản vẽ (kèm theo làm VD) lại ko làm đc mà còn xóa hết cả thể ???

- Coi như phần chọn hatch mẫu ko tạo ra lỗi, Mong các bác chỉ giáo cho

 

file ko làm đc:

http://www.cadviet.com/upfiles/3/80156_hatch.dwg


<<

Filename: 260522_jhh.lsp

Trang 145/330

145