Jump to content
InfoFile
Tác giả: Bee
Bài viết gốc: 449903
Tên lệnh: s2p
Lisp chuyển từ Spline sang 3DPolyline
Vào lúc 3/9/2020 tại 15:42, tienhuy93 đã nói:

Nhờ các bác cho em xin...

>>
Vào lúc 3/9/2020 tại 15:42, tienhuy93 đã nói:

Nhờ các bác cho em xin lisp chuyển từ SPLINE thành 3DPolyline với ạ . Em cảm ơn

SPL to 3Dpolyline.dwg

Hỏi a GG là ra tương đối nhiều. Đây là 1 ví dụ :D

;;CADALYST 12/03 AutoLISP Solutions  SPLINE-TO-PLINE.LSP
;;(c) 2003 Tony Hotchkiss

(defun spline-to-pline (/ i)
  (vl-load-com)
  (setq	*thisdrawing* (vla-get-activedocument
			(vlax-get-acad-object)
		      ) ;_ end of vla-get-activedocument
	*modelspace*  (vla-get-ModelSpace *thisdrawing*)
  ) ;_ end of setq
  (setq spline-list (get-spline))
  (setq i (- 1))
  (if spline-list
    (progn
      (setq msg "\nNumber of segments <100>: ")
      (initget 6)
      (setq num (getint msg))
      (if (or (= num 100) (= num nil))
	(setq num 100)
      ) ;_ end of if
      (repeat (length spline-list)
	(setq splobj (nth (setq i (1+ i)) spline-list))
	(convert-spline splobj num)
      ) ;_ end of repeat
    ) ;_ end of progn
  ) ;_ end of if
) ;_ end of spline-to-pline

(defun get-spline (/ spl-list obj spline no-ent i)
  (setq	spl-list nil
	obj	 nil
	spline	 "AcDbSpline"
	selsets	 (vla-get-selectionsets *thisdrawing*)
	ss1	 (vlax-make-variant "ss1")
  ) ;_ end of setq
  (if (= (vla-get-count selsets) 0)
    (setq ssobj (vla-add selsets ss1))
  ) ;_ end of if
  (vla-clear ssobj)
  (setq no-ent 1)
  (while no-ent
    (prompt "\nSelect splines: ")
    (vla-Selectonscreen ssobj)
    (if	(> (vla-get-count ssobj) 0)
      (progn
	(setq no-ent nil)
	(setq i (- 1))
	(repeat	(vla-get-count ssobj)
	  (setq
	    obj	(vla-item ssobj
			  (vlax-make-variant (setq i (1+ i)))
		) ;_ end of vla-item
	  ) ;_ end of setq
	  (cond
	    ((= (vlax-get-property obj "ObjectName") spline)
	     (setq spl-list
		    (append spl-list (list obj))
	     ) ;_ end of setq
	    )
	  ) ;_ end-of cond
	) ;_ end of repeat
      ) ;_ end of progn
      (prompt "\nNo entities selected, try again.")
    ) ;_ end of if
    (if	(and (= nil no-ent) (= nil spl-list))
      (progn
	(setq no-ent 1)
	(prompt "\nNo splines selected.")
	(quit)
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of while  
  (vla-delete (vla-item selsets 0))
  spl-list
) ;_ end of get-spline

(defun convert-spline (splobj n / i)
  (setq	point-list   nil
	2Dpoint-list nil
	z-list	     nil
	spl-lyr	     (vlax-get-property splobj 'Layer)
	startSpline  (vlax-curve-getStartParam splobj)
	endSpline    (vlax-curve-getEndParam splobj)
	i	     (- 1)
  ) ;_ end of setq
  (repeat (+ n 1)
    (setq i (1+ i))
    (setq p (vlax-curve-getPointAtParam
	      splobj
	      (* i
		 (/ (- endspline startspline) n)
	      ) ;_ end of *
	    ) ;_ end of vlax-curve-getPointAtParam
    ) ;_ end of setq
    (setq 2Dp	       (list (car p) (cadr p))
	  2Dpoint-list (append 2Dpoint-list 2Dp)
	  point-list   (append point-list p)
	  z	       (caddr p)
	  z-list       (append z-list (list z))
    ) ;_ end of setq
  ) ;_ end of repeat
  (setq summ (apply '+ z-list))
  (setq	arraySpace
	 (vlax-make-safearray
	   vlax-vbdouble ; element type
	   (cons 0
		 (- (length point-list) 1)
	   ) ; array dimension
	 ) ;_ end of vlax-make-safearray
  ) ;_ end of setq
  (setq vert-array (vlax-safearray-fill arraySpace point-list))
  (vlax-make-variant vert-array)
  (if (and (= :vlax-true (vlax-get-property splobj 'IsPLanar))
	   (= summ 0.0)
      ) ;_ end of and
    (setq plobj	(add-polyline
		  2Dpoint-list
		  vla-AddLightweightPolyline
		) ;_ end of add-polyline
    ) ;_ end of setq
    (setq plobj	(add-polyline
		  point-list
		  vla-Add3DPoly
		) ;_ end of add-polyline
    ) ;_ end of setq
  ) ;_ end of if
  (vlax-put-property plobj 'Layer spl-lyr)
  (vla-delete splobj)
  (vlax-release-object splobj)
) ;_ end of convert-spline

(defun add-polyline (pt-list poly-func)
  (setq	arraySpace
	 (vlax-make-safearray
	   vlax-vbdouble
	   (cons 0
		 (- (length pt-list) 1)
	   ) ; array dimension
	 ) ;_ end of vlax-make-safearray
  ) ;_ end of setq
  (setq	vertex-array
	 (vlax-safearray-fill arraySpace pt-list)
  ) ;_ end of setq
  (vlax-make-variant vertex-array)
  (setq	plobj (poly-func
		*modelspace*
		vertex-array
	      ) ;_ end of poly-func
  ) ;_ end of setq
) ;_ end of add-polyline

(defun c:s2p ()
  (spline-to-pline)
  (princ)
) ;_ end of c:s2p

(prompt
  "SPLINE-TO-PLINE by Tony Hotchkiss. Enter S2P to start"
) ;_ end of prompt

 


<<

Filename: 449903_s2p.lsp
Tác giả: truongthanh
Bài viết gốc: 72408
Tên lệnh: tn
Viết lisp theo yêu cầu [phần 2]
Chào truongthanh,

2 lisp Thiep đã chỉnh sửa theo ý của bạn. Còn khi đánh lệnh tn xong, bị lỗi là do dòng lệnh này:

(command ".style" "ahs-Arial" "Arial" "" "0.8" "" "" "" "" "")....

>>
Chào truongthanh,

2 lisp Thiep đã chỉnh sửa theo ý của bạn. Còn khi đánh lệnh tn xong, bị lỗi là do dòng lệnh này:

(command ".style" "ahs-Arial" "Arial" "" "0.8" "" "" "" "" ""). Thiep cũng chỉnh sửa xong. Phải mất nhiều thời gian mới tìm ra lỗi này, tác giả trước đây đã thêm 2 lần enter.

;;; -------------------------------
(defun existLinetype (doc LineTypeName / item loaded)
 (vlax-for item (vla-get-linetypes doc)
   (if (= (strcase (vla-get-name item)) (strcase LineTypeName))
     (setq loaded T)
   )
 )
)
(defun loadLinetype (doc LineTypeName FileName)
 (if (and
       (not (existLinetype doc LineTypeName))
       (vl-catch-all-error-p
         (vl-catch-all-apply
           'vla-load
           (list
             (vla-get-Linetypes doc)
             LineTypeName
             FileName
           )
         )
       )
     )
   nil
   T
 )
)
(vl-load-com)
(defun c:tn (/	   *layer*     enlay lay   SS	 ent   n     obj
     len   pc	 pd    pdx   pdy   pcx	 pcy   goc   ang
     dodoc p1	 p2    p3    p4	   p5	 p6
    )
 (princ "\nLISP THÔNG SÔ CÔNG THOAT NUOC - free lisp from cadviet.com")
 (setq	ActDoc	(vla-get-ActiveDocument (vlax-get-acad-object))
*Model*	(vla-get-ModelSpace ActDoc)
*layer*	(vla-get-Layers ActDoc)
*LT*	(vla-get-linetypes ActDoc)
 )
 (loadLinetype ActDoc "ACAD_ISO10W100" "acad.lin")
 (vla-StartUndoMark ActDoc)
 (setvar "cmdecho" 0)
 (setvar "orthomode" 0)
 (setvar "gridmode" 0)
 (setvar "snapmode" 0)
 (setvar "osmode" 0)
 (if (not (setq enlay (tblobjname "layer" "ahs-tnt-TSC")))
   (progn
     (setq lay (vla-add *layer* "ahs-tnt-TSC"))
     (vla-put-color lay acMagenta)
     (vla-put-Linetype lay "ACAD_ISO10W100")
   )
   (progn
     (setq lay (vlax-ename->vla-object enlay))
     (setq lay (vla-add *layer* "ahs-tnt-TSC"))
     (vla-put-color lay acWhite)
     (vla-put-Linetype lay "ACAD_ISO10W100")
   )
 )
 (setvar "clayer" "ahs-tnt-TSC")
 (command ".style" "ahs-Arial"	"Arial"	"" "0.8" "" "" "")
 (setq SS (ssget '((0 . "LWPOLYLINE,LINE"))))
 (setq	dk (cond (dk)
	 (300)
   )
 )
 (setq olddk dk)
 (setq	dk (getreal (strcat "\nNhap tiet dien day <"
		    (rtos olddk 2 1)
		    "> : "
	    )
   )
 )
 (if (null dk)
   (setq dk olddk)
 )
 (setq	chu (cond (chu)
	  (3)
    )
 )
 (setq oldchu chu)
 (setq	chu (getreal (strcat "\nChon chieu cao chu <"
		     (rtos oldchu 2 1)
		     "> : "
	     )
    )
 )
 (if (null chu)
   (setq chu oldchu)
 )
 (setq N 0)
 (repeat (sslength SS)
   (setq ent (ssname SS N))
   (setq obj (vlax-ename->vla-object ent))
   (setq len (vlax-curve-getdistatpoint obj (vlax-curve-getendpoint obj))
  PC  (vlax-curve-getendpoint obj) ; dien cuoi
  PD  (vlax-curve-getstartpoint obj) ; diem dau
   )
   (setq PDx (car PD)
  PDY (cadr PD)
   )
   (setq PCx (car PC)
  PCY (cadr PC)
   )
   (If	(< PDx PCx)
     (progn
(setq goc (angle PD PC)
      p1  (polar PD goc (/ len 2))
)
     )
     (progn
(setq goc (angle PC PD)
      p1  (polar PD goc (- (/ len 2)))
)
     )
   )
   (setq ang	(cvunit goc "radians" "degrees")
  p2	(polar p1 (+ (/ pi 2) goc) chu)
  p3	(polar p1 (+ (/ pi 2) goc) (- chu))
  p4	(polar p3 goc -16.25)
  p5	(polar p4 goc 25)
  p6	(polar p5 goc 7.5)
  dodoc	(/ 1000 dk)
   )
   (command ".text"
     "j"
     "mc"
     p2
     chu
     ang
     (strcat (chr 216)
	     (rtos dk 2 0)
	     " - L"
	     (rtos len 2 0)
	     " - i"
	     (rtos dodoc 2 2)
     )
     ".pline"
     p4
     "w"
     0.5
     0.5
     p5
     "w"
     2
     0
     p6
     ""
   )
   (setq N (1+ N))
 ); dong vong lap repeat
 (setvar "osmode" 7)
 (vla-EndUndoMark ActDoc)
 (princ)
)

cho mình hỏi tí nhen!mình muốn đổi chiều dài mũi tên và bề rộng điểm đầu,bề rộng điểm cuối của Pline mũi tên thì mình chỉnh chỗ nào vậy Thiep!


<<

Filename: 72408_tn.lsp
Tác giả: dinhvantrang
Bài viết gốc: 419942
Tên lệnh: cpt
Nhờ Viết Lisp Rải Text Dạng Số

 

Quick code 

(defun c:cpt(/ ss pt1)
  (setq pt1 (getpoint "\nChon diem goc copy : "))
  (setq ss (car (entsel "\n...
>>

 

Quick code 

(defun c:cpt(/ ss pt1)
  (setq pt1 (getpoint "\nChon diem goc copy : "))
  (setq ss (car (entsel "\n Chon Text:")))
 
  (while (and ss pt1)
    (command "._copy" ss "" pt1 (setq pt1 (getpoint pt1 "\n diem dich copy :")))
    (setq ss (entlast))
    (command "_.ddedit" "L" "") 
  )
)

Mình xóa mấy  khoảng trắng giữa dấu ngoặc thì okie, bạn thử tải lại nhé.


<<

Filename: 419942_cpt.lsp
Tác giả: trinhvqh
Bài viết gốc: 84539
Tên lệnh: pid
Viết lisp theo yêu cầu [phần 2]
Cám ơn các lời nhận xét của bác trinhvqh. (do chủ quan của nguời viết nên 1 số chi tiết chưa hoàn chỉnh)

 

Gửi bác Lisp đã cập nhật theo các yêu cầu ở...

>>
Cám ơn các lời nhận xét của bác trinhvqh. (do chủ quan của nguời viết nên 1 số chi tiết chưa hoàn chỉnh)

 

Gửi bác Lisp đã cập nhật theo các yêu cầu ở trên.

 

về ý kiến : khoảng cách Text trong Table so với đường ngang bên dưới (hơi sát quá)

- tương tự Text và dimension, CAD cung cấp TABLE STYLE để quản lý các đối tuợng Table. Do đó khoảng cách Text trong Table (do LISP tạo ra) chỉ là tạm thời, tùy theo chủ quan và quy định mỗi nguời (cty) sẽ tự tạo TABLE STYLE theo ý mình.

 

Quản lý đối tuợng CAD theo các xì-tin (Style) cũng đuợc xem là một "PRỒ" chứ nhỉ ?! :cheers:

(defun c:Pid(/ cen doc i h height lst msp ov pt row str stt tblobj vl width x y) ;Point ID out
;;  By : Gia Bach, Copyrightゥ December 2009                    ;;
;;  Contact : gia_bach @  www.CadViet.com                      ;;
 (if (> (atof (substr (getvar "ACADVER") 1 4)) 16.0) (progn
 (princ "\nChon cac POINT de xuat ra Bang toa do :")
 (if (ssget '((0 . "POINT")))
   (progn
     (vl-load-com)
     (setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object))
    msp (vla-get-modelspace doc))
     (vlax-for e (vla-get-ActiveSelectionSet doc)
(setq cen (vlax-safearray->list (variant-value (vla-get-Coordinates e)))
      lst (cons (list e cen )lst))
);vlax-for
     (setq lst (vl-sort lst '(lambda (x y) (or	(< (car (cadr x)) (car (cadr y)));Check X
					(and (> (cadr (cadr x)) (cadr (cadr y)));Check Y
					     (= (car (cadr x)) (car (cadr y)));Equal X
					     )	) ) )
    str (cadr (last lst))
    lst (append (mapcar 'car lst) ) )      
     (setq vl '("dimzin" "cmdecho")    ; Sys Var list  
    ov  (mapcar 'getvar vl))    ; Get Old values
     (mapcar 'setvar vl '(0 0))
     (or *h* (setq *h* 175))
     (initget 6)
     (setq h (getreal (strcat "\nChieu cao chu <" (rtos *h*) "> :")))
     (if h (setq *h* h) (setq h *h*) )
     (if (> (car str)(cadr str) )
(setq str (car str))
(setq str (cadr str)))
     (setq width (* 2(TxtWidth (rtos str) h msp))
    width1 (* 2 (TxtWidth "STT" h msp))
    height (* 2 h))
     (if (> h 3)
(setq width (* (fix (/ width 10))10)
      width1 (* (fix (/ width1 10))10)
      height (* (fix (/ height 5))5)))
     (setq i 1
    row 2
    pt (getpoint "\nDiem dat Bang :")
    TblObj (vla-addtable msp (vlax-3d-point pt) (+ (length lst) 2) 3 height width))
     (vla-put-vertcellmargin TblObj (/ h 4))
     (vla-SetColumnWidth TblObj 0 width1)
     (mapcar '(lambda (x)(vla-setTextHeight TblObj x h))
      (list acTitleRow acHeaderRow acDataRow) )
     (mapcar '(lambda (x)(vla-setAlignment TblObj x 8))
      (list acTitleRow acHeaderRow acDataRow))
     (vla-setText TblObj 0 0 "Bang toa do")
     (vla-setText TblObj 1 0 "STT")
     (vla-setText TblObj 1 1 "X")
     (vla-setText TblObj 1 2 "Y")
     (foreach e lst
(setq stt (itoa i)
      pt (vlax-safearray->list (variant-value (vla-get-Coordinates e)))
      obj_id (rtos (vla-get-objectid e))) 
(vla-AddText msp stt (vlax-3d-point (polar pt (/ pi 4) (/ h 4))) h)
(vla-setText TblObj row 0 stt)
(vla-setText TblObj row 1 (strcat "%<\\AcObjProp Object(%<\\_ObjId " obj_id ">%).Coordinates \\f \"%lu6%pt1\">%"))
(vla-setText TblObj row 2 (strcat "%<\\AcObjProp Object(%<\\_ObjId " obj_id ">%).Coordinates \\f \"%lu6%pt2\">%"))
(setq row (1+ row) i (1+ i))
)
     (vlax-release-object TblObj)
     (mapcar 'setvar vl ov)                     ;reset Sys Vars
     (princ)      
     )
   )
 )
 (alert "\nPhien ban Cad cua ban khong ho tro tao Bang (TABLE)")
 )
 )

(defun TxtWidth (val h msp / txt minp maxp)
 (setq	txt (vla-AddText msp val (vlax-3d-point '(0 0 0)) h))
 (vla-getBoundingBox txt 'minp 'maxp )
 (vla-Erase txt)
 (-(car(vlax-safearray->list maxp))(car(vlax-safearray->list minp)))
 )

 

Pid.Lsp của gia_bach như vậy là OK rồi

Nhưng tôi vẫn muốn hoàn hảo hơn một chút nữa

Điều này đồng nghĩa với việc bổ sung thêm Update Pid

 

Thực tế trong quá trình vẽ Việc Di chuyển Point và Delete point xảy ra rất thường xuyên

cho nên cần phải Update Table

Update phai dam bao cac truong hop nhu: Add Point; Reselect; Unselect,..

 

Nhu vay, Kể ra cũng hơi khó cho gia_bach vì Point; Text; Table là những đối tượng rời rạc không liên kết

Tôi xin đề xuất thế này gia_bach xem được không nhé:

 

Command: Pid (New/Update) N:

Chọn: U (Update)

Chọn Text và Table cần Xoá:

Chọn lại Point:

Chiều cao chữ (175):

Chọn điểm đặt bảng:


<<

Filename: 84539_pid.lsp
Tác giả: kid112
Bài viết gốc: 67710
Tên lệnh: ghitd1
Viết Lisp theo yêu cầu
Chào bạn Kid112 mình đã có nhờ bác q288 sữa lại 1 lisp cũng giống yêu cầu như bạn

Nếu bạn chưa hiểu thì có thể coi từ trang 111

Hy vọng lisp này sẽ giải...

>>
Chào bạn Kid112 mình đã có nhờ bác q288 sữa lại 1 lisp cũng giống yêu cầu như bạn

Nếu bạn chưa hiểu thì có thể coi từ trang 111

Hy vọng lisp này sẽ giải quyết được vấn đề của bạn đưa ra.

Tên lệnh : ghitd1

Yêu cầu: 1: nhập chiều cao chữ

2: chữ số thập phân ( dùng để định là cm hay mm)

3: bán kính vòng tròn ( dùng để tô đỉnh thửa)

4: có lưu file hay không ( file được save dạng .txt ngay tại thư mục của bản vẽ)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Chuong trinh danh so va lap bang toa do ho so thua dat dia chinh
;;;Bang toa do tao thanh block, duoc dat ten theo so thu tu 1, 2, 3...
;;;Chap nhan cac doi tuong la Region, Polyline, Line va Arc khep kin
;;;Written by ssg and elleHCSC - January 2009 - www.cadviet.com
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;PUBLIC FUNCTIONS
;;;-------------------------------------------------------------------------------
(Defun DTR (x) (/ (* x pi) 180))
;;;change degree to radian, return REAL
;;;-------------------------------------------------------------------------------
(defun lineP (p0 a r / p1)
;;;Line polar: point, degree angle, radius
 (setq p1 (polar p0 (dtr a) r))
 (command "line" p0 p1 "")
)
;;;-------------------------------------------------------------------------------
(defun linePX (p0 x) (lineP p0 0 x))
;;;Horizontal line: length x, from p0
;;;-------------------------------------------------------------------------------
(defun linePY (p0 y) (lineP p0 90 y))
;;;Vertical line: length y, from p0
;;;-------------------------------------------------------------------------------
(defun getVert (e / i L)
;;;Return list of all vertex from pline e
 (setq	i 0
L nil
 )
 (vl-load-com)
 (repeat (fix (+ (vlax-curve-getEndParam e) 1))
   (setq L (append L (list (vlax-curve-getPointAtParam e i))))
   (setq i (1+ i))
 )
 L
)

;;; First point of List rearrangement
(defun relist(pt0 Lst / i rt)
 (setq i 0)
 (foreach pt Lst
   (if (equal pt0 pt 0.001)
     (setq rt i))
   (setq i (1+ i)))
 (append (append (member (nth rt Lst) Lst)
     (cdr (reverse (cdr (member (nth rt Lst) (reverse Lst))))))
  (list (nth rt Lst)))
)

;;;New Layer
(defun newlayer(a b c d) 
   (if (not (tblsearch "layer" a))
      (command "-layer" "n" a "c" b a "l" c a "lw" d a ""))
)
;;;-------------------------------------------------------------------------------
(defun wtxtMC (txt p h k)
;;;Write text Middle Center, specify text, point, height
 (entmake (list (cons 0 "TEXT")
	 (cons 7 (getvar "textstyle"))
	 (cons 1 txt)
	 (cons 10 p)
	 (cons 11 p)
	 (cons 40 h)
	 (cons 72 1)
	 (cons 73 2)
	 (if k (cons 51 (DTR 18)) (cons 51 0))
   )
 )
)
;;;-------------------------------------------------------------------------------
(defun Collect (e / e2 SS)
;;;Selection set from e to entlast
 (setq SS (ssadd))
 (ssadd e SS)
 (while (setq e2 (entnext e)) (ssadd e2 SS) (setq e e2))
 SS
)
;;;-------------------------------------------------------------------------------
(defun Collect1	(e / ss)
;;;Selection set after e to entlast. If e nil, select all from fist entity of drawing.
 (if (= e nil)
   (setq ss (collect (entnext)))
   (progn (setq ss (collect e)) (ssdel e ss))
 )
)
;;;-------------------------------------------------------------------------------

;;;PRIVATE FUNCTIONS
;;;-------------------------------------------------------------------------------
(defun txt1 (txtL / p1 p2 p3 p4 pL i)
;;;Write texts in 1 row
 (setq
   p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
   p2 (polar p1 0 (* 7 h))
   p3 (polar p2 0 (* 10 h))
   p4 (polar p3 0 (* 9 h))
   pL (list p1 p2 p3 p4)
   i  0
 )
 (repeat 4
   (wtxtMC (nth i txtL) (nth i pL) h t)
   (setq i (1+ i))
 )
)
;;;-------------------------------------------------------------------------------
(defun txt2 (txtL / p1 p2 p3 p4 pL i)
;;;Write texts in 1 row
 (setq
   p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
   p2 (polar p1 0 (* 7 h))
   p3 (polar p2 0 (* 10 h))
   p4 (polar p3 0 (* 9 h))
   p4 (polar p4 (* 0.5 pi) h)
   pL (list p1 p2 p3 p4)
   i  0
 )
 (repeat 4
   (wtxtMC (nth i txtL) (nth i pL) h t)
   (setq i (1+ i))
 )
)
;;;-------------------------------------------------------------------------------
;;;MAIN PROGRAM
;;;-------------------------------------------------------------------------------
(defun C:ghitd1 (/ h p et p0 p00 p01 p02 pt pvL n j pv num txtL ss bn ntp)
 (setvar "cmdecho" 0)

;;;New layer check
 (newlayer "kichthuoc" 7 "continuous" "default")
 (newlayer "stt" 1 "continuous" "default")
 (newlayer "bangtd" 7 "continuous" "default")

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

;;;GET DECIMAL PRECISION
 (if (not ntp0)  (setq ntp0 2))
 (setq ntp (getint (strcat "\nSo chu so thap phan <" (itoa ntp0) ">:")))
 (if (not ntp)  (setq ntp ntp0)  (setq ntp0 ntp))

;;;GET CIRCLE RADIUS
 (if (not cr0)  (setq cr0 0.3))
 (setq cr (getreal (strcat "\nNhap ban kinh vong tron <" (rtos cr0) ">:")))
 (if cr (setq cr0 cr))

;;;PICK & BASE POINT
 (initget "Y")
 (setq save (getkword "\nBan co muon luu file? < Y / Enter for No >:"))

 (setq oldos (getvar "osmode")
pdau (getpoint "\nPick diem dau tien (so thu tu = 1) :"))  

 (while pdau
   (setq p (getpoint "\nPick 1 diem giua mien kin:")
  pvL nil pvL1 nil)
   (command "boundary" p "")
   (setq et (entlast)
         pvL1 (reverse (getvert et)))  
   (redraw et 3)  
   (setq p00 (getpoint "\nDiem dat Bang TDGR:"))
   (command "erase" et "")
   (setq  p0 p00
          p01  (polar p00 (* 1.5 pi) (* h 3))    
          pvL  (relist pdau pvL1)
          n	(length pvL)
          p02	(polar p01 (* 1.5 pi) (+ (* h 3) (* (1- n) h 2)))
   )  
   (setvar "osmode" 0)
;;;HEADER
 (setvar "CLAYER" "bangtd")
 (linepx p0 (* 32 h))
 (command "copy" "L" "" "m" p00 p01 p02 "")
 (linepy p0 (- (distance p0 p02)))
 (command "copy" "L" "" "m"  p0
   (list (+ (car p0) (* 4 h)) (cadr p0))
   (list (+ (car p0) (* 14 h)) (cadr p0))
   (list (+ (car p0) (* 24 h)) (cadr p0))
   (list (+ (car p0) (* 32 h)) (cadr p0))
   "")
 (setq Lkqua nil)
 (wtxtMC "BAÛNG TOÏA ÑOÄ GOÙC RANH"
  (polar (polar p0 0 (* 16 h)) (* 0.5 pi) (* 2 h))
	 (* 1.2 h) nil)
 (txt1 (setq Lkq (list "TT" "X (m)" "Y (m)" "S (m)")))
 (setq Lkqua (append Lkqua (list Lkq)))
 (setq p0 (polar p0 (* 1.5 pi) (* 3 h)))

;;;MAKE RECORDS
 (setq	j  0
pt nil)
 (repeat n
   (setq
     pv  (nth j pvL)
     num (itoa (1+ j))
   )
   (if	pt
     (setq S (rtos (distance pt pv) 2 ntp))
     (setq S "")
   )
   (setq
     txtL (list num (rtos (car pv) 2 ntp) (rtos (cadr pv) 2 ntp) S)
     Lkqua (append Lkqua (list txtL))
   )
   (txt2 txtL)
   (setq p0 (polar p0 (* 1.5 pi) (* 2 h)))
   (setq pt pv)
   (setq j (1+ j))
   (if	(= j (- n 1))  (setq j 0))
 )

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

;;;WRITE POINT NAME
 (setvar "CLAYER" "stt")
 (setq j 0)
 (repeat (1- n)
   (setq
     pv  (nth j pvL)
     num (itoa (1+ j))
   )
   (wtxtMC num (polar pv 0 h) h t)
   (command "circle" pv cr0)
   (command "hatch" "S" (setq vtron (entlast)) "")
   (command "erase" vtron "")
   (setq j (1+ j))
 )

;;;GHI CANH THUA
   (setvar "CLAYER" "kichthuoc")
   (ghicanh)  

;;;FINISH
   (savef)
   (setvar "osmode" oldos)
   (setq pdau (getpoint "\nPick diem dau tien (so thu tu = 1) :"))
 )  
 (setvar "cmdecho" 1)
 (princ)
)

;;;-------------------------------------------------------------------------------
(defun savef()  
 (if save
   (progn
     (setq file (open (setq tenfile (strcat (getvar "dwgprefix")
 (vl-filename-base (vl-string-right-trim "\\" (getvar "dwgname"))) ".txt")) "a"))
     (foreach line Lkqua
(setq line1 "")
(foreach it line
  (setq line1 (strcat line1 " " it)))
(write-line line1 file)
     )
     (close file)
     (princ (strcat "\nDa luu thanh file " tenfile))
   )
 )
)

;;;PHAN BO SUNG CUA elleHCSC
;;;------------------------------------------------------------------------------------
(defun Text_canh_TCA (S p a)
;;;Entmake text S at p with angle A - Top Center
 (if (/= p nil)
   (entmake (list
       (cons 0 "TEXT")
       (cons 62 5)
       (cons 10 p)
       (cons 40 h)
       (cons 1 S)
       (cons 50 a)
       (cons 41 0.7)
       (cons 7 (getvar "textstyle"))
       (cons 72 1)
       (cons 11 p)
       (cons 73 3)
     )
   )
 )
)
;;;------------------------------------------------------------------------------------
(defun Text_canh_BCA (S p a)
;;;Entmake text S at p with angle A - Bottom Center
 (if (/= p nil)
   (entmake (list
       (cons 0 "TEXT")
       (cons 62 5)
       (cons 10 p)
       (cons 40 h)
       (cons 1 S)
       (cons 50 a)
       (cons 41 0.7)
       (cons 7 (getvar "textstyle"))
       (cons 72 1)
       (cons 11 p)
       (cons 73 1)
     )
   )
 )
)
;;;-------------------------------------------------------------------------------
(defun Ghicanh (/ i k p1 p2 dist rad x_mp y_mp mp)
 (setq
   i	0   
   k	(1- (length pvL))
 )
 (repeat k
   (setq
     p1   (nth i pvL)
     p2   (nth (+ i 1) pvL)
     dist (distance p1 p2)
     rad  (angle p1 p2)
     x_mp (* (+ (car p1) (car p2)) 0.5)
     y_mp (* (+ (cadr p1) (cadr p2)) 0.5)
     mp   (list x_mp y_mp)
   )
   (if	(and (> rad (* 0.5 pi)) (<= rad (* 1.5 pi)))
     (setq mp (polar mp (+ rad (* 0.5 pi)) (* 0.3 h)))
   )
   (if	(and (> rad (* 0.5 pi)) (<= rad (* 1.5 pi)))
     (progn
(setq rad (+ rad pi))
(Text_canh_TCA (rtos dist 2 2) mp rad)
     )
     (Text_canh_BCA (rtos dist 2 2) mp rad)
   )
   (setq i (1+ i))
 )
 ;; repeat k;
)
;;;--------------------------

 

Chân thành cảm ơn anh.

 

Em có thêm 1 vấn đề phát sinh là mình muốn xuất các toạ độ đó qua Excel thì phải edit chỗ nào đây ạ?


<<

Filename: 67710_ghitd1.lsp
Tác giả: naturooo
Bài viết gốc: 449035
Tên lệnh: betmbb+%3B+%3D+block+entities+transparency+%26+material+to+byblock
Đặt giá trị Transparency cho block

Nhờ các bác chỉnh lại lisp đăt giá trị Transparency cho các Block được chọn bởi entsel chứ không phải cho toàn bộ Block trong bản vẽ trong lisp sau ạ:

(defun C:BETMBB ; = Block Entities Transparency & Material to ByBlock
  (/ blkdata ent obj)
(setq numTr (getstring "- Nhap gia tri Transparency:"))

  (while (setq blkdata (tblnext "block" (not blkdata))); still any...
>>

Nhờ các bác chỉnh lại lisp đăt giá trị Transparency cho các Block được chọn bởi entsel chứ không phải cho toàn bộ Block trong bản vẽ trong lisp sau ạ:

(defun C:BETMBB ; = Block Entities Transparency & Material to ByBlock
  (/ blkdata ent obj)
(setq numTr (getstring "- Nhap gia tri Transparency:"))

  (while (setq blkdata (tblnext "block" (not blkdata))); still any Block definitions left?
    (if
      (and
        (not (assoc 1 blkdata)); not an Xref 
        (not (wcmatch (cdr (assoc 2 blkdata)) "`*D*")); not a Dimension
      ); and
      (progn ; then -- process it
        (setq ent (tblobjname "block" (cdr (assoc 2 blkdata)))); Block definition as entity
        (while (setq ent (entnext ent)); still something left in definition?
          (setq obj (vlax-ename->vla-object ent))
          (vla-put-EntityTransparency obj numTr)
          (vla-put-Material obj "ByBlock")
        ); while
      ); progn
    ); if
  ); while
(command "REGEN")
  (princ)
); defun

Em cảm ơn!


<<

Filename: 449035_betmbb+%3B+%3D+block+entities+transparency+%26+material+to+byblock.lsp
Tác giả: hieuhx68
Bài viết gốc: 297198
Tên lệnh: vg
Lips cắt nhanh hàng đường thẳng

Của bạn đây.

 

(defun c:Vg (/ curve pt dai ang)
  (if (setq curve (car (entsel "\nChon Curve : "))
   pt (getpoint...
>>

Của bạn đây.

 

(defun c:Vg (/ curve pt dai ang)
  (if (setq curve (car (entsel "\nChon Curve : "))
   pt (getpoint "\nChon diem tren Curve : ")
   dai (getreal "\nChieu dai line: ")) 
 
    (progn (setq pt  (vlax-curve-getClosestPointTo curve (trans pt 1 0))
ang (angle '(0 0) (Vlax-curve-getfirstderiv curve (vlax-curve-getParamAtPoint curve pt))))
  (entmake (list '(0 . "LINE") (cons 10 pt) (cons 11 (polar pt (+ ang (/ pi 2)) dai))  (cons 62 3)))
  (entmake (list '(0 . "LINE") (cons 10 pt) (cons 11 (polar pt (- ang (/ pi 2)) dai))  (cons 62 4)))
    )
  )
  (princ)
)

Em Không biết nói j để cảm ơn bác cho hết lời nữa. Quá tuyệt bác ạ. Cảm ơn bác thật nhiều. Chúc bác sức khỏe và thành công.


<<

Filename: 297198_vg.lsp
Tác giả: ketxu
Bài viết gốc: 450535
Tên lệnh: bmm
Hỏi về record con trong mã DFX của Dimension
(100 . "AcDbRotatedDimension")
    (-3
      (
        "ACAD"
        (1000 . "DSTYLE")
        (1002 . "{")
        (1070 . 69) ;; <--------------- Background Text Fill Colour
        (1070 . 1)  ;; <--------------- Background Text Fill Colour
        (1002 . "}")
      )
    )
  )

@Lee-Mac : nằm trong dữ liệu Dim Xdata override. Bạn muốn biết rõ thì...

>>
(100 . "AcDbRotatedDimension")
    (-3
      (
        "ACAD"
        (1000 . "DSTYLE")
        (1002 . "{")
        (1070 . 69) ;; <--------------- Background Text Fill Colour
        (1070 . 1)  ;; <--------------- Background Text Fill Colour
        (1002 . "}")
      )
    )
  )

@Lee-Mac : nằm trong dữ liệu Dim Xdata override. Bạn muốn biết rõ thì nó nằm trong code của lisp Mask v1.5, chú ý 2 hàm mask:getdimxdata và mask:setdimxdata  để biết cách append thêm 2 mã này cho đối tượng
http://lee-mac.com/mask.html

Trước việc này bạn có thể làm bằng Dim Update sau khi gán Dimtfill rồi Dim -> Update -> All. 
Giờ thì lệnh Dim bị bỏ rồi, bạn cũng có thể làm bằng Dim1.
Code kruuger  / Theswamp . Bạn có thể search

(Defun C:BMM (/ lst object SC STYL)
  (vl-load-com)
  (setq lst (entsel "\nSelect dimension object: "))
  (setq object (car lst))
  (setq object (vlax-ename->vla-object object))
  (if (wcmatch (vla-get-objectname object) "AcDb*Dimension")
    (progn
      (setq STYL (vla-get-StyleName object))
      (command ".dimstyle" "r" STYL)
      (setq SC (vla-get-ScaleFactor object))
      (setvar "dimscale" SC)
      (setvar "dimtfill" 1)
      (command "DIM1" "UPDATE" lst "")
      (command ".draworder" (car lst) "" "front")
      (setvar "dimtfill" 0)
    );progn
  );if
)


Hoặc bạn cũng có thể chỉnh bằng Dimtfill -> 1 -> -Dimstyle -> Apply -> Chọn các Dim -> Draw order -> Front

 

(defun c:foo(/ s oTF)
;@Ketxu 10/2020
	(setq 	s (ssget (list (cons 0 "DIMENSION")))
			oTF (getvar 'Dimtfill)
	)
	(setvar 'Dimtfill 1)
	(command "-dimstyle" "Apply" s "")
	(command ".draworder" s "" "front")
	(setvar 'Dimtfill oTF)
)

 


<<

Filename: 450535_bmm.lsp
Tác giả: ketxu
Bài viết gốc: 450535
Tên lệnh: foo
Hỏi về record con trong mã DFX của Dimension
(100 . "AcDbRotatedDimension")
    (-3
      (
        "ACAD"
        (1000 . "DSTYLE")
        (1002 . "{")
        (1070 . 69) ;; <--------------- Background Text Fill Colour
        (1070 . 1)  ;; <--------------- Background Text Fill Colour
        (1002 . "}")
      )
    )
  )

@Lee-Mac : nằm trong dữ liệu Dim Xdata override. Bạn muốn biết rõ thì...

>>
(100 . "AcDbRotatedDimension")
    (-3
      (
        "ACAD"
        (1000 . "DSTYLE")
        (1002 . "{")
        (1070 . 69) ;; <--------------- Background Text Fill Colour
        (1070 . 1)  ;; <--------------- Background Text Fill Colour
        (1002 . "}")
      )
    )
  )

@Lee-Mac : nằm trong dữ liệu Dim Xdata override. Bạn muốn biết rõ thì nó nằm trong code của lisp Mask v1.5, chú ý 2 hàm mask:getdimxdata và mask:setdimxdata  để biết cách append thêm 2 mã này cho đối tượng
http://lee-mac.com/mask.html

Trước việc này bạn có thể làm bằng Dim Update sau khi gán Dimtfill rồi Dim -> Update -> All. 
Giờ thì lệnh Dim bị bỏ rồi, bạn cũng có thể làm bằng Dim1.
Code kruuger  / Theswamp . Bạn có thể search

(Defun C:BMM (/ lst object SC STYL)
  (vl-load-com)
  (setq lst (entsel "\nSelect dimension object: "))
  (setq object (car lst))
  (setq object (vlax-ename->vla-object object))
  (if (wcmatch (vla-get-objectname object) "AcDb*Dimension")
    (progn
      (setq STYL (vla-get-StyleName object))
      (command ".dimstyle" "r" STYL)
      (setq SC (vla-get-ScaleFactor object))
      (setvar "dimscale" SC)
      (setvar "dimtfill" 1)
      (command "DIM1" "UPDATE" lst "")
      (command ".draworder" (car lst) "" "front")
      (setvar "dimtfill" 0)
    );progn
  );if
)


Hoặc bạn cũng có thể chỉnh bằng Dimtfill -> 1 -> -Dimstyle -> Apply -> Chọn các Dim -> Draw order -> Front

 

(defun c:foo(/ s oTF)
;@Ketxu 10/2020
	(setq 	s (ssget (list (cons 0 "DIMENSION")))
			oTF (getvar 'Dimtfill)
	)
	(setvar 'Dimtfill 1)
	(command "-dimstyle" "Apply" s "")
	(command ".draworder" s "" "front")
	(setvar 'Dimtfill oTF)
)

 


<<

Filename: 450535_foo.lsp
Tác giả: trinhhoanghieu090
Bài viết gốc: 331133
Tên lệnh: test
Một số hàm con VL- hữu ích

 

Đánh lệnh vlide, bấm f1, vào ActiveX and VBA reference > Objects > Line object. Bên phần Properties bạn thấy 1 dãy. Tất cả những cái...

>>

 

Đánh lệnh vlide, bấm f1, vào ActiveX and VBA reference > Objects > Line object. Bên phần Properties bạn thấy 1 dãy. Tất cả những cái đó đều có thể ghép với vla-get- để biết thuộc tính của line, nhưng chỉ 1 số có thể ghép với vla-put- để thay đổi thuộc tính. Muốn biết cái nào dùng dc với vla-put- thi bạn cứ ghép thử, thấy cái nào chuyển màu xanh là ok, còn màu đen là not ok.

Dưới đây là lsp test, tôi chỉ lấy vài cái prop đẻ thử thôi. bạn vẽ 1 line rồi chạy lsp.

 

(defun c:test ()
  (defun v2p (a)  (vlax-safearray->list (vlax-variant-value a)))
  (setq a (car (entsel "\nChon Line:"))
obj (vlax-ename->vla-object a))
  (alert  (strcat "\nAngle : " (rtos (vla-get-Angle obj))
 "\nDelta : " (vl-prin1-to-string (v2p (vla-get-Delta obj)))
 "\nLength : " (rtos (vla-get-Length obj))
 "\nStartPoint : " (vl-prin1-to-string (setq dd (v2p (vla-get-StartPoint obj))))
 "\nEndPoint : " (vl-prin1-to-string (setq dc (v2p (vla-get-EndPoint obj))))
 "\nLayer : " (vla-get-Layer obj)
 "\nLinetype : " (vla-get-Linetype obj)
 "\nLinetypeScale : " (rtos (vla-get-LinetypeScale obj))
 "\nLineweight : " (rtos (vla-get-Lineweight obj))      
   ))
  (vla-put-StartPoint obj (vlax-3d-point (polar dd 0 1)))
  (vla-put-EndPoint obj (vlax-3d-point (polar dc 0 -1)))
  (alert  (strcat "\nNew StartPoint : " (vl-prin1-to-string  (v2p (vla-get-StartPoint obj)))
 "\nNew EndPoint : " (vl-prin1-to-string  (v2p (vla-get-EndPoint obj)))))
)

Cái này hay quá, các bác ơi nổ tiếp để em học hỏi với 


<<

Filename: 331133_test.lsp
Tác giả: bkhn_2011
Bài viết gốc: 282528
Tên lệnh: dlp dls alp als
Lisp thêm tiền tố vào tên của hàng loạt layer

Nếu bạn k thích kiểu Old - New thì dùng tạm cái này < search nhanh cho bạn trên mạng - K có copyright - không viết >

 

>>

Nếu bạn k thích kiểu Old - New thì dùng tạm cái này < search nhanh cho bạn trên mạng - K có copyright - không viết >

 

(defun c:DLP ( / p x n ) (vl-load-com)
  (if (< 1 (setq x (strlen (setq p (strcat (strcase (getstring t "\nSpecify Prefix: ")) "*")))))
    (vlax-for l (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
      (if (wcmatch (strcase (setq n (vla-get-name l))) p)
        (vl-catch-all-apply 'vla-put-name (list l (substr n x)))
      )
    )
  )
  (princ)
)

(defun c:DLS ( / s x n ) (vl-load-com)
  (if (< 1 (setq x (strlen (setq s (strcat "*" (strcase (getstring t "\nSpecify Suffix: ")))))))
    (vlax-for l (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
      (if (wcmatch (strcase (setq n (vla-get-name l))) s)
        (vl-catch-all-apply 'vla-put-name (list l (substr n 1 (- (strlen n) x -1))))
      )
    )
  )
  (princ)
)

(defun c:ALP ( / p w n ) (vl-load-com)
  (setq p (getstring t "\nSpecify Prefix: ") w (strcat (strcase p) "*"))
  (vlax-for l (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
    (if (not (wcmatch (strcase (setq n (vla-get-name l))) w))
      (vl-catch-all-apply 'vla-put-name (list l (strcat p n)))
    )
  )
  (princ)
)

(defun c:ALS ( / s w n ) (vl-load-com)
  (setq s (getstring t "\nSpecify Suffix: ") w (strcat "*" (strcase s)))
  (vlax-for l (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
    (if (not (wcmatch (strcase (setq n (vla-get-name l))) w))
      (vl-catch-all-apply 'vla-put-name (list l (strcat n s)))
    )
  )
  (princ)
)

Có 4 thằng : thêm trước (ALP), thêm sau (ALS), xóa trước (DLP), xóa sau (DLS)

 

Đã chuẩn với những gì em cần. Cám ơn anh Ketxu nhé. Chúc anh công tác tốt và nhiệt tình giúp những anh em còn bỡ ngỡ trên diễn đàn nữa.


<<

Filename: 282528_dlp_dls_alp_als.lsp
Tác giả: minhngockt
Bài viết gốc: 168715
Tên lệnh: tt
Chọn đối Tượng Pline Sau Khi Break

 

Yêu cầu của bạn tương tự như copy Text, nên dùng cái này thì chủ động hơn :

(defun C:tt( / source )
;@Ketxu...
>>

 

Yêu cầu của bạn tương tự như copy Text, nên dùng cái này thì chủ động hơn :

(defun C:tt( / source )
;@Ketxu 15 -9 base on CAB copy
 (vl-load-com)
 (and
 (setq source (car (nentsel "\nCh\U+1ECDn Text / Mtext / Attdef / Attrib ngu\U+1ED3n : ")))
 (setvar "errno" 0)
 (or
  (vl-position (cdadr (entget source))'("TEXT" "ATTRIB" "MTEXT" "ATTDEF"))
  (prompt "\nCh\U+1ECDn sai lo\U+1EA1i \U+0111\U+1ED1i t\U+01B0\U+1EE3ng !")
 )
)
(setq text (vla-get-textstring (vlax-ename->vla-object source)))
(princ (strcat "\Text ngu\U+1ED3n : " text))
(while (/= (getvar "errno") 52)
 	(and
   	(setq pick (nentsel "\nCh\U+1ECDn \U+0111\U+1ED1i t\U+01B0\U+1EE3ng c\U+1EA7n thay \U+0111\U+1ED5i : "))
   	(setq target (car pick))
   	(setq ent	(entget target)
         	layer  (cdr (assoc 8 ent))
         	target (vlax-ename->vla-object target)
   	)
   	(or
     	(= (length pick) 2)
     	(prompt "\n\U+0110\U+1ED1i t\U+01B0\U+1EE3ng n\U+1EB1m s\U+00E2u trong Block ho\U+1EB7c Xref !")
   	)
   	(or
     	(vl-position (cdadr ent) '("TEXT" "ATTRIB" "MTEXT" "ATTDEF"))
     	(prompt "\nCh\U+1ECDn sai lo\U+1EA1i \U+0111\U+1ED1i t\U+01B0\U+1EE3ng !")
   	)
   	(or
     	(/= (logand 4 (cdr (assoc 70 (tblsearch "layer" layer)))) 4)
     	(prompt (strcat "\nLayer " layer " \U+0111ang b\U+1ECB kh\U+00F3a !"))
   	)      
   	(and
     	(not (vla-put-textstring target text))
     	(/= (vla-get-textstring target) text)
     	(princ "\nCopy Text th\U+1EA5t b\U+1EA1i !")
   	)
 	)
)
 )

em cảm ơn bác. Đúng là cái em cần


<<

Filename: 168715_tt.lsp
Tác giả: minhnghi
Bài viết gốc: 60278
Tên lệnh: d5 t6 t11 t5 t7 rx5 rxa rxb rxc rx rc r rr r5 rdc rdb7 tdb5 tdb tdb2
Lisp thiết kế taluy trong Nova14
Mình lục lọi mấy "đồ nghề" của các bậc tiền bối thì thấy có cái này:

(defun C:D5 ()
 (setq p (getpoint "\nChon phia ta luy can sua ..."))
 (command "TL" P "1"...
>>
Mình lục lọi mấy "đồ nghề" của các bậc tiền bối thì thấy có cái này:

(defun C:D5 ()
 (setq p (getpoint "\nChon phia ta luy can sua ..."))
 (command "TL" P "1" "66.67"  "")
 )

(defun C:T6 ()
 (setq p (getpoint "\nChon phia ta luy can sua ..."))
 (command "TL" P "1" "6"  "")
 )
(defun C:T11 ()
 (setq p (getpoint "\nChon phia ta luy can sua ..."))
 (command "TL" P "1" "100"  "")
 )

(defun C:T5 ()
 (setq p (getpoint "\nChon phia ta luy can sua ..."))
 (command "TL" P "1" "-200"  "")
 )

(defun C:T7 ()
 (setq p (getpoint "\nChon phia ta luy can sua ..."))
 (command "TL" P "1" "-133.33"  "")
 )
(defun C:RX5 ()
 (setq p (getpoint "\nChon phia ta luy can gia co ranh ..."))
 (command "TL" P "0.5254" "133.33"  "0.7" "0" "0.5254" "-133.33" "0.01" "-200" "")
 )

(defun C:RXa ()
 (setq p (getpoint "\nChon phia ta luy can gia co ranh ..."))
 (command "TL" P "0.5254" "133.33"  "0.7" "0" "0.5254" "-133.33" "0.01" "-6" "")
 )

(defun C:RXb ()
 (setq p (getpoint "\nChon phia ta luy can gia co ranh ..."))
 (command "TL" P "0.5254" "133.33"  "0.7" "0" "0.5254" "-133.33" "0.01" "66.67" "")
 )

(defun C:RXc ()
 (setq p (getpoint "\nChon phia ta luy can gia co ranh ..."))
 (command "TL" P "0.5254" "133.33"  "0.7" "0" "0.5254" "-133.33" "0.01" "6" "")
 )

(defun C:RX ()
 (setq p (getpoint "\nChon phia ta luy can gia co ranh ..."))
 (command "TL" P "0.5254" "133.33"  "0.7" "0" "0.5254" "-133.33" "0.01" "-133.33" "")
 )

(defun C:RC ()
 (setq p (getpoint "\nChon phia ta luy can gia co ranh ..."))
 (command "TL" P "0.5254" "133.33"  "0.7" "0" "0.5254" "-133.33" "4.5" "-133.33" "2" "2" "0.01" "-133.33" "")
 )

(defun C:R ()
 (setq p (getpoint "\nChon phia ta luy can TK ranh ..."))
 (command "TL" P "0.3" "133.33"  "0.4" "0" "0.3" "-133.33" "0.01" "-133.33" "")
 )

(defun C:Rr ()
 (setq p (getpoint "\nChon phia ta luy can TK ranh ..."))
 (command "TL" P "0.3" "133.33"  "0.4" "0" "0.3" "-133.33" "4.5" "-133.33" "2" "2" "0.01" "-133.33" "")
 )

(defun C:R5 ()
 (setq p (getpoint "\nChon phia ta luy can TK ranh ..."))
 (command "TL" P "0.3" "133.33"  "0.4" "0" "0.3" "-133.33" "0.01" "-200" "")
 )

(defun C:RdC ()
 (setq
   kc (getreal "\nKhoang cach tu vai duong toi taluy ranh : ")
   p (getpoint "\nChon phia ta luy can gia co ranh ..."))
 (command "TL" P kc "66.67" "0.5254" "133.33"  "0.7" "0" "0.5254" "-133.33" "4.5" "-133.33" "2" "2" "0.01" "-133.33" "")
 )

(defun C:RDB7 ()
 (setq
   kc (getreal "\nKhoang cach tu vai duong toi taluy ranh : ")
   idoc 66.67;(getreal "\nDo doc ta luy (%): ")
   p (getpoint "\nChon phia ta luy can gia co ranh ..."))
 (command "TL" P kc idoc "0.5254" "133.33"  "0.7" "0" "0.5254" "-133.33" "0.01" "-133.33" "")
 )

(defun C:TDB5 ()
 (setq p (getpoint "\nChon phia ta luy can dat cap ..."))
 (command "TL" P "0.5254" "133.33"  "0.7" "0" "0.5254" "-133.33" "3" "-200" "2" "2" "0.01" "-200" "")
 )

(defun C:TDB ()
 (setq p (getpoint "\nChon phia ta luy can dat cap ..."))
 (command "TL" P "0.5254" "133.33"  "0.7" "0" "0.5254" "-133.33" "4.5" "-133.33" "2" "2" "0.01" "-133.33" "")
 )
(defun C:TDB2 ()
 (setq p (getpoint "\nChon phia ta luy can dat cap ..."))
 (command "TL" P "0.5254" "133.33"  "0.7" "0" "0.5254" "-133.33" "4.5" "-133.33" "2" "2" "4.5" "-133.33" "2" "2" "0.01" "-133.33" "")
 )

Đây là mấy lệnh thiết kế taluy nhanh trong Nova14. Tuy nhiên mình thử chạy ở trong Nova 14 thì cái lisp này ko có tác dụng j. Cũng có thể có một thiết lập nào đó trước mà mình chưa phát hiện ra. Anh em có ai dùng đến cái này rồi hướng dẫn hộ mình chút nhé :mellow: . Cám ơn nhiều !

Mình cũng đã xem qua mấy lisp này nhưng cũng thực sự chưa bít là nó dùng để làm gì, mình có xem mấy lisp vẽ taluy trong cad nhưng nó chưa được ổn lắm. Không bít bác nào rành thì chỉ giáo cho anh em xem phát nhẩy.


<<

Filename: 60278_d5_t6_t11_t5_t7_rx5_rxa_rxb_rxc_rx_rc_r_rr_r5_rdc_rdb7_tdb5_tdb_tdb2.lsp
Tác giả: ketxu
Bài viết gốc: 451026
Tên lệnh: mindist md mindistmove mdm mindistcopy mdc mindistline mdl
khoảng cách ngắn nhất giữa 2 đường parabol trong 3D
;; http://www.theswamp.org/index.php?topic=23170.60
;; By Joe Burke, Charles Alan Butler and VovKa at theswamp.

;; Bug reports may be sent to me (Joe Burke) directly at 
;; lowercase@hawaii.rr.com

;; Version 1.0 - 5/28/2008.
;;  Find the minimum distance between two vlax-curve objects. 
;;  Supported object types: line, circle, arc, ellipse, polyline and spline.
;;  Shortcut: MD

;; Notes...
>>
;; http://www.theswamp.org/index.php?topic=23170.60
;; By Joe Burke, Charles Alan Butler and VovKa at theswamp.

;; Bug reports may be sent to me (Joe Burke) directly at 
;; lowercase@hawaii.rr.com

;; Version 1.0 - 5/28/2008.
;;  Find the minimum distance between two vlax-curve objects. 
;;  Supported object types: line, circle, arc, ellipse, polyline and spline.
;;  Shortcut: MD

;; Notes version 1.0:
;;  If two lines are parallel they are reported as such.
;;  If the Z values of the two points found are not equal,
;;  report at command line Z1 = x Z2 = x. When the objects
;;  are not coplanar, the apparent minimum distance will 
;;  usually differ from the actual minimum distance.
;;  There's an option to add a line on the current layer
;;  drawn between the two closest points.
;;  The object types selected are reported at the command line.

;;  Version history:

;;  Version 1.2 beta - 5/31/2008
;;   Added the MinDistLine routine. Shortcut: MDL.
;;   Allows the user to place a line between the last two closest points
;;   calculated by MinDist after it ends. This avoids having to choose
;;   whether a line is placed within MinDist itself. The idea is MinDist
;;   is primarily a measuring tool. As such a minimum distance line is
;;   rarely needed. Note, If the line drawn by MDL is off-screen it is 
;;   selected, otherwise not.

;;  Version 1.3 beta - 6/8/2008
;;   Added support for nested objects in blocks and xrefs.
;;   Added MD:GetXrefs, MD:GetObject, MD:UnlockLayers, MD:RelockLayers 
;;   and MD:XMark sub-functions.
;;   The first object selected is highlighted until the the second
;;   object is selected similar to the fillet tool. If the first object
;;   is contained in an xref it is not highlighted. Rather a temporary 
;;   X mark is placed where the object was selected to indicate the
;;   the object is contained in an xref.

;;  Version 1.4 beta - 6/10/2008
;;   Added error checking for non-uniformly scaled blocks.

;;  Version 1.4a - 6/21/2008
;;   Bug fix for 2D (heavy) and 3D polylines.
;;   Bug fix to avoid error if a dimension is selected.
;;   Revised report when the Z values of the two points are not the same.

;;  Version 1.5 beta - 6/30/2008
;;   Added support for object types point, ray and xline.
;;   If a ray or xline is involved the search for closest point along its 
;;   length is limited by the current view. The search extends beyond the
;;   limits of the current view by a factor of approximately two both ways.

;;  Version 1.5a beta - 7/1/2008
;;   Fixed a bug with rays and xlines.
;;   Both MD and MDL now report when both closest points are off screen.
;;   Revised the MDL routine so it will not draw a very short or zero
;;   length line. Added report for this case.
;;   Added miscellaneous error checking.

;;  Version 1.5b beta - 7/2/2008
;;   Enter at select object prompt ends the routine.
;;   Revised the UniformScale sub-routine to allow operation with objects
;;   nested in dimensions. Thanks to Steve Doman.

;;  Version 1.5c beta - 7/14/2008
;;   Revised the fuzz factor in the MD:UniformScale function.

;;  Version 1.5d - 8/24/2008
;;   Added vla-StartUndoMark and vla-EndUndoMark. An undo after the 
;;   routine would restore a copied object.
;;   Added function MinDistMove (MDM). Moves a selection set from
;;   the first MinDist point to the second. The first object selected
;;   within MinDist is the first point.

;;  Version 1.5e - 9/6/2008
;;   Fixed a minor bug which effected the MinDistMove function when
;;   a ray or xline is involved.

;;  Version 1.5f - 10/1/2008
;;   Added Copy version of move. Shourtcut MDC.

  ;; Both MinDist and MinDistLine use the following two functions.

  ;; Returns the coordinates of the current view, lower left and upper right.
  ;; Works in a rotated view. Returns a list of two 2D UCS points.
  (defun MD:GetScreenCoords ( / ViwCen ViwDim ViwSiz VptMin VptMax)
   (setq ViwSiz (/ (getvar "VIEWSIZE") 2.0)
         ViwCen (getvar "VIEWCTR")
         ViwDim (list
                  (* ViwSiz (apply '/ (getvar "SCREENSIZE")))
                  ViwSiz
                )
         VptMin (mapcar '- ViwCen ViwDim)
         VptMax (mapcar '+ ViwCen ViwDim)
   )
   (list VptMin VptMax)
  ) ;end

  ;; Arguments: 
  ;;  p1 - WCS or UCS point which defines the first corner of area
  ;;  p2 - WCS or UCS point which defines the second corner of area
  ;;  pt - point translated to UCS.
  ;; Returns: T if pt falls within area.
  (defun MD:PointInside (p1 p2 pt / xval yval)
    (and 
      pt
      (setq pt (trans pt 0 1)
            xval (car pt)
            yval (cadr pt)
      )
      (< (min (car p1) (car p2)) xval (max (car p1) (car p2)))
      (< (min (cadr p1) (cadr p2)) yval (max (cadr p1) (cadr p2)))
    )
  ) ;end

(defun c:MinDist ( / *error* doc blocks units obj1 obj2 typ1 typ2 pkpt p2 sc 
                     div fuzz d bd len inc idx resdist dellst res1 res2 pts 
                     locklst interflag z1 z2 diff temp reverseflag 
                     MD:Wait MD:NormalAngle MD:ParallelObjects MD:Pick 
                     MD:GetXrefs MD:UnlockLayers MD:RelockLayers MD:GetObject 
                     MD:XMark MD:UniformScale MD:XlineOrRay)
                     ;; global vars: *mdp1* and *mdpt*

  (vl-load-com)

  (defun *error* (msg)
    (cond
      ((not msg))
      ((wcmatch (strcase msg) "*QUIT*,*CANCEL*"))
      (T (princ (strcat "\nError: " msg)))
    )
    (setvar "lunits" units)
    (if 
      (and 
        obj1
        (not (vlax-erased-p obj1))
      )
      (vla-highlight obj1 acFalse)
    )
    ;; Objects may be switched when a ray or xline
    ;; is involved.
    (if 
      (and 
        obj2
        (not (vlax-erased-p obj2))
      )
      (vla-highlight obj2 acFalse)
    )
    (MD:Wait 0.2)
    (redraw)
    (foreach x dellst (vla-delete x))
    (MD:RelockLayers locklst)
    (vla-EndUndoMark doc)
    (princ)
  ) ;end error

  ;;; START SUB-FUNCTIONS ;;;

  ;; Unlock locked layers.
  ;; Argument: document object.
  ;; Returns a list of layer objects which were locked, 
  ;; or nil if none are locked.
  ;; Typically the function filters out xref layers,
  ;; but not in this case.
  (defun MD:UnlockLayers (doc / laylst)
    (vlax-for x (vla-get-Layers doc)
      (if (eq :vlax-true (vla-get-lock x))
        (progn
          (setq laylst (cons x laylst))
          (vla-put-lock x :vlax-false)
        )
      )
    )
    laylst
  ) ;end

  ;; Argument: a list of layer objects from UnlockLayers above.
  ;; Use vl-catch-all-apply in case a locked
  ;; layer was deleted in the calling function.
  (defun MD:RelockLayers (lst)
    (foreach x lst
      (vl-catch-all-apply 'vla-put-lock (list x :vlax-true))
    )
  ) ;end

  (defun MD:GetXrefs (blklst / lst)
    (if (vl-every '(lambda (x) (= (type x) 'ENAME)) blklst)
      (foreach blk (mapcar 'vlax-ename->vla-object blklst)
        (if (vlax-property-available-p blk 'Path)
          (setq lst (cons blk lst))
        )
      )
    )
    (reverse lst)
  ) ;end

  (defun MD:Wait (seconds / stop)
    (setq stop (+ (getvar "DATE") (/ seconds 86400.0)))
    (while (> stop (getvar "DATE"))
      (princ)
    )
  ) ;end

  ;; Argument: angle in radians, any number including negative.
  ;; Returns: normalized angle in radians between zero and (* pi 2)
  (defun MD:NormalAngle (a)
    (if (numberp a)
      (angtof (angtos a 0 14) 0))
  ) ;end

  ;; Returns T if two lines, rays or xlines are parallel.
  (defun MD:ParallelObjects (obj1 obj2 fuzz / ang1 ang2)
    (if (eq "AcDbLine" (vlax-get obj1 'ObjectName))
      (setq ang1 (MD:NormalAngle (vlax-get obj1 'Angle)))
      (setq ang1 (MD:NormalAngle 
        (angle (vlax-get obj1 'BasePoint) (vlax-get obj1 'SecondPoint)))
      )
    )
    (if (eq "AcDbLine" (vlax-get obj2 'ObjectName))
      (setq ang2 (MD:NormalAngle (vlax-get obj2 'Angle)))
      (setq ang2 (MD:NormalAngle 
        (angle (vlax-get obj2 'BasePoint) (vlax-get obj2 'SecondPoint)))
      )
    )
    (or 
      (equal ang1 ang2 fuzz)
      (equal ang1 (MD:NormalAngle (+ pi ang2)) fuzz)
      (equal ang2 (MD:NormalAngle (+ pi ang1)) fuzz)
      (equal (MD:NormalAngle (+ pi ang1)) (MD:NormalAngle (+ pi ang2)) fuzz)
    )
  ) ;end

  (defun MD:Pick (msg / typlst e obj typ scflag)

    (setq typlst '("AcDbLine" "AcDbArc" "AcDbCircle" "AcDbEllipse" 
                   "AcDbPolyline" "AcDb2dPolyline" "AcDb2dVertex"
                   "AcDb3dPolyline" "AcDb3dPolylineVertex" "AcDbSpline"
                   "AcDbRay" "AcDbXline" "AcDbPoint"))

    (setvar "errno" 0)
    
    (while 
      (or
        (not (setq e (nentselp msg)))
        (not (setq obj (vlax-ename->vla-object (car e))))
        (not (vl-position (setq typ (vlax-get obj 'ObjectName)) typlst))
        (and
          (cadddr e)
          (not (apply 'and (mapcar 'MD:UniformScale (last e))))
          (setq scflag T)
        )
      )
      (cond
        ((= 52 (getvar "errno"))
          (exit)
        )
        ((not e)
          (princ "\nMissed pick. ")
        )
        (scflag
          (princ "\nNon-uniformly scaled block detected, try again. ")
          (setq scflag nil)
        )
        (typ
          (princ (strcat "\n " (substr typ 5) " selected, try again. "))
          (setq typ nil)
        )
      )
    )
    
    (if
      (or
        (eq "AcDb2dVertex" typ)
        (eq "AcDb3dPolylineVertex" typ)
      )
      (setq obj (vlax-ename->vla-object (cdr (assoc 330 (entget (car e)))))
            typ (vlax-get obj 'ObjectName)
      )
    )

    ;; Used to mark xref. Point passed to MD:XMark. 
    ;; The variable is local in the main routine.
    (setq pkpt (cadr e))
    (if (= 2 (length e))
      (list obj typ)
      (list obj typ (caddr e) (cadddr e))
    )
  ) ;end

  ;; Argument: UCS point.
  ;; Returns: nil
  (defun MD:XMark (pt / len p1 p2 p3 p4)
    (setq len (/ (getvar "viewsize") 75.0)
          p1 (polar pt (* pi 0.3) len)
          p2 (polar pt (* pi 0.7) len)
          p3 (polar pt (* pi 1.3) len)
          p4 (polar pt (* pi 1.7) len)
    )
    (grdraw p1 p3 7)
    (grdraw p2 p4 7)
  ) ;end

  ;; Test for uniformly scaled block reference.
  (defun MD:UniformScale (obj / x y z)
    (if (= (type obj) 'ENAME)
      (setq obj (vlax-ename->vla-object obj))
    )
    ;; Added 7/2/2008.
    (if (wcmatch (vlax-get obj 'ObjectName) "*Dimension")
      T
      (progn
        (setq x (vlax-get obj 'XScaleFactor)
              y (vlax-get obj 'YScaleFactor)
              z (vlax-get obj 'ZScaleFactor)
        )
        (and
          (equal (abs x) (abs y) 1e-12)
          (equal (abs y) (abs z) 1e-12)
        )
      )
    )
  ) ;end

  ;; Argument: a list returned by MD:Pick.
  ;; Returns: a vla-object. The first object in list if the object is
  ;; not nested. Otherwise a transformed copy of the object. 
  (defun MD:GetObject (lst / blkref blk obj)
    (cond
      ;; Object is not nested.
      ((= 2 (length lst))
        (setq obj (car lst))
      )
      ;; Object is nested in an xref. Copy it within the xref database.
      ;; The owner is not specified within the CopyObjects function.
      ((setq blkref (car (MD:GetXrefs (last lst))))
        (setq blk (vla-item blocks (vlax-get blkref 'Name)))
        (setq obj
          (car 
            (vlax-invoke
              (vlax-get blk 'XRefDatabase) 'CopyObjects (list (car lst)))))
        (vla-transformby obj (vlax-tmatrix (caddr lst)))
        (setq dellst (cons obj dellst))
        ;; Grdraw X mark on xref where it was selected
        ;; if it is the first object selected.
        (if (not obj1) (MD:XMark pkpt))
      )
      ;; Object is nested in a block reference. 
      ;; Copy it from the block and highlight in the main 
      ;; routine if it is the first object selected.
      (T
        (setq obj 
          (car (vlax-invoke doc 'CopyObjects (list (car lst))
            (vlax-get (vla-get-ActiveLayout doc) 'Block))))
        (vla-transformby obj (vlax-tmatrix (caddr lst)))
        (setq dellst (cons obj dellst))
      )
    )
    obj
  ) ;end

  ;; Argument: ray or xline vla-object.
  ;; Returns: a list of two 3D WCS points beyond where the object
  ;; intersects the edges of the current view.
  ;; The base point of a ray may be returned depending on its
  ;; location relative to the view.
  ;; Revised 6/30/2008.
  (defun MD:XlineOrRay (obj / basept zval secpt lst p pts p2 d typ 
                              expt1 expt2 MD:RectanglePts MD:RectangleList 
                              MD:FarthestPoint)

    ;;;; Sub-functions...

    ;; Pass two points representing a diagonal.
    ;; Returns a list of four UCS points.
    (defun MD:RectanglePts (p1 p2)
      (list
        p1
        (list (car p2) (cadr p1) (caddr p1)) ; revised 6/27/2008 
        p2
        (list (car p1) (cadr p2) (caddr p2)) ; should be OK within context, testing
      )
    ) ;end

    (defun MD:RectangleList ( p1 p2 / rpts)
      (setq rpts (MD:RectanglePts p1 p2))
      (mapcar '(lambda (a b) (list a b)) rpts (append (cdr rpts) (list (car rpts))))
    ) ;end

    (defun MD:FarthestPoint (pt ptlst / x dist res)
      (setq x 0)
      (foreach p ptlst
        (setq dist (distance p pt))
        (if (> dist x)
          (setq x dist res p)
        )
      )
      res
    ) ;end

    ;;;; End Sub-functions

    (setq basept (trans (vlax-get obj 'BasePoint) 0 1)
          zval (caddr basept)
          secpt (trans (vlax-get obj 'SecondPoint) 0 1)
          typ (vlax-get obj 'ObjectName)
    )

    ;; two 2D UCS points
    (if (not sc)
      (setq sc (MD:GetScreenCoords))
    )
    
    (setq d (distance (car sc) (cadr sc))
          sc (mapcar '(lambda (x) (append x (list zval))) sc)
          lst (MD:RectangleList (car sc) (cadr sc))
          sc nil
    )

    (foreach x lst
      (if 
        (and
          (setq p (inters basept secpt (car x) (cadr x) nil))
          (inters basept p (car x) (cadr x))
        )
        (setq pts (cons p pts))
      )
    )

    (cond
      ((eq "AcDbXline" typ)
        (setq expt1 (polar (cadr pts) (angle (cadr pts) (car pts)) (* 2 d))
              expt2 (polar (car pts) (angle (car pts) (cadr pts)) (* 2 d))
              pts (reverse (list expt1 expt2))
        )
      )
      ;; Revised 6/29/2008
      ((eq "AcDbRay" typ)
        (setq expt1 (MD:FarthestPoint basept pts)
              expt1 (polar expt1 (angle basept secpt) (* 2 d))
              pts (list basept expt1)
        )
        ;; If base point is far away attempt to get a closer point 
        ;; by testing for param at point.
        (setq expt2 (polar expt1 (angle secpt basept) (* 5 d)))
        (if (vlax-curve-getParamAtPoint obj (trans expt2 1 0))
          (setq pts (reverse (list expt2 expt1)))
        )
      )         
    )
    ;; Trans UCS points to WCS as needed.
    (mapcar '(lambda (x) (trans x 1 0)) pts)
  ) ;end MD:XlineOrRay

  ;;; END SUB-FUNCTIONS ;;;

  ;;; START MAIN FUNCTION ;;;

  (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
        blocks (vla-get-Blocks doc)
        locklst (MD:UnlockLayers doc)
        units (getvar "lunits")
  )
  
  (vla-StartUndoMark doc)

  (sssetfirst)

  (princ "\nSelect line, circle, arc, ellipse, polyline, spline, point, ray or xline.")

  (if 
    (and
      (setq res1 (MD:Pick "\nFirst object: "))
      (setq typ1 (cadr res1))
      (princ (substr typ1 5))
      (setq obj1 (MD:GetObject res1))
      (not (vla-highlight obj1 acTrue))
      ;; Get the screen coordinates here in case
      ;; the user pans between select objects.
      (if
        (or
          (eq "AcDbRay" typ1)
          (eq "AcDbXline" typ1)
        )
        (setq sc (MD:GetScreenCoords))
        T
      )
      (setq res2 (MD:Pick "\nSecond object: "))
      (setq typ2 (cadr res2))
      (princ (substr typ2 5))
      (setq obj2 (MD:GetObject res2))
    )
    (progn
      (cond 
        ((equal obj1 obj2)
          (princ "\n Same object selected twice. ")
          (setq resdist 0.0
                interflag T
          )
        )
        ((vlax-invoke obj1 'IntersectWith obj2 acExtendNone)
          (princ "\n Objects intersect. ")
          (setq resdist 0.0
                interflag T
          )
        )
        ((and
           (eq typ1 "AcDbPoint")
           (eq typ2 "AcDbPoint")
          )
          (setq *mdpt* (vlax-get obj1 'Coordinates)
                *mdp1* (vlax-get obj2 'Coordinates)
                d (distance *mdpt* *mdp1*)
          )
        )
        ((or
           (eq typ1 "AcDbPoint")
           (eq typ2 "AcDbPoint")
          )
          (if (eq typ1 "AcDbPoint")
            (setq *mdpt* (vlax-get obj1 'Coordinates)
                  *mdp1* (vlax-curve-getClosestPointTo obj2 *mdpt*)
            )
            (setq *mdpt* (vlax-get obj2 'Coordinates)
                  *mdp1* (vlax-curve-getClosestPointTo obj1 *mdpt*)
            )
          )
          (setq d (distance *mdpt* *mdp1*))
        )
        ;; Core stuff follows.
        (T
          (if 
            (or
             (eq typ2 "AcDbRay")
             (eq typ2 "AcDbXline")
            )
            ;; Reverse the objects and set a flag to reverse 
            ;; the points later.
            (setq temp obj1 obj1 obj2 obj2 temp reverseflag T)
          )
          
          (if (vlax-curve-getEndParam obj1)
            (setq len (vlax-curve-getDistAtParam obj1 (vlax-curve-getEndParam obj1)))
            ;; Obj1 is an xline or ray.
            (progn 
              (setq pts (MD:XlineOrRay obj1)
                    len (distance (car pts) (cadr pts))
                    idx1 (vlax-curve-getParamAtPoint obj1 (car pts))
                    idx2 (vlax-curve-getParamAtPoint obj1 (cadr pts))
              )
              (if (< idx1 idx2)
                (setq idx idx1)
                (setq idx idx2)
              )
            )
          )

          (if (not idx) (setq idx 0))

          ;; Number of divisions seems more than sufficient.
          (setq div 200
                inc (/ len div)
                fuzz 1e-8
          )

          ;; Check first object for the closest point on second object.
          (setq bd 
            (distance 
              (setq *mdp1* (vlax-curve-getPointAtDist obj1 idx))
              (vlax-curve-getClosestPointTo obj2 *mdp1*)
            )
          )
          (repeat (1+ div)
            (if 
              (and
                (setq *mdp1* (vlax-curve-getPointAtDist obj1 idx))
                (setq p2 (vlax-curve-getClosestPointTo obj2 *mdp1*))
              )
              (progn
                (setq d (distance *mdp1* p2))
                (setq idx (+ idx inc))
                (if (<= d bd)
                  (setq bd d *mdpt* *mdp1*)
                )
              )
            )
          )
          ;; Refine the minimum distance as needed. Start with closest
          ;; point on first object. Bounce the closest points back and
          ;; forth between the two objects until delta distance is less
          ;; than the fuzz factor.
          (while 
            (not
              (minusp
                (- (distance *mdpt* 
                   (setq *mdp1* (vlax-curve-GetClosestPointTo obj2 *mdpt*)))
                   (setq d 
                     (distance *mdp1* 
                       (setq *mdpt* (vlax-curve-GetClosestPointTo obj1 *mdp1*))))
                   fuzz
                )
              )
            )
          )
        )
      ) ;cond

      (if (and d *mdpt* *mdp1*)
        (progn
          (setq resdist d)
          ;; Added 9/6/2008.
          ;; If objects were reversed, reverse the points.
          (if reverseflag
            (setq temp *mdpt* *mdpt* *mdp1* *mdp1* temp)
          )          
          (grdraw (trans *mdpt* 0 1) (trans *mdp1* 0 1) -7 1)
          (if
            (and
              (or
                (eq "AcDbLine" typ1)
                (eq "AcDbXline" typ1)
                (eq "AcDbRay" typ1)
              )
              (or
                (eq "AcDbLine" typ2)
                (eq "AcDbXline" typ2)
                (eq "AcDbRay" typ2)
              )
            )
            (if (MD:ParallelObjects obj1 obj2 1e-8)
              (if (and (eq "AcDbLine" typ1) (eq "AcDbLine" typ2))
                (princ "\n Lines are parallel. ")
                (princ "\n Linear objects are parallel. ")
              )
            )
          )
          ;; Check the Z values of the two closest points.
          (setq z1 (caddr *mdpt*) z2 (caddr *mdp1*) diff (abs (- z1 z2)))
          (cond
            ((equal z1 z2 1e-10))
            ;; Units are scientific, decimal or engineering.
            ((< units 4)
              (princ 
                (strcat "\n Z values of the points differ by: "
                  (rtos diff units 10)
                )
              )
            )
            ;; The maximum display accuracy of architectural or
            ;; fractional units is 0.00196. If diff is less, 
            ;; change units to decimal.
            ((and
               (> units 3)
               (< diff 0.00196)
              )
              (princ 
                (strcat "\n Z values of the points differ by: "
                  (rtos diff (setvar "lunits" 2) 10)
                )
              )
              (setvar "lunits" units)
            )
            ;; Otherwise display diff in architectural or fractional units.
            (T
              (princ 
                (strcat "\n Z values of the points differ by: "
                  (rtos diff)
                )
              )
            )
          ) ;cond
        ) ;progn
      ) ;if
    ) ;progn
  ) ;if

  (if (and resdist *mdpt* *mdp1*)
    (progn
      (princ (strcat "\n Distance: " (rtos resdist)))
      (if (not interflag)
        (progn
          (setq sc (MD:GetScreenCoords))
          (if 
            (or
              (MD:PointInside (car sc) (cadr sc) *mdpt*)
              (MD:PointInside (car sc) (cadr sc) *mdp1*)
            )
            (princ "  Enter MDL to place minimum distance line. ")
            (princ "  Off screen points. MDL to place minimum distance line.")
          )
        )
      )
    )
    (princ "\n Could not calculate minimum distance. ")
  )
  
  (*error* nil)
) ;end MinDist

;shortcut
(defun c:MD () (c:MinDist))


;; Added 8/24/2008.
;; Allows a selection set to be moved from the first MinDist point to
;; the second MinDist point. So the order of object selection within 
;; MinDist is important in terms of which way the selection set will move.
;; IOW, if the user anticipates using this function after MD, the first object 
;; selected determines move from point. The second object selected is 
;; the move to point.
(defun c:MinDistMove ( / *error* doc osm ss)

  (defun *error* (msg)
    (cond
      ((not msg))
      ((wcmatch (strcase msg) "*QUIT*,*CANCEL*"))
      (T (princ (strcat "\nError: " msg)))
    )
    (setvar "osmode" osm)
    (vla-EndUndoMark doc)
    (princ)
  ) ;end error

  (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (vla-StartUndoMark doc)
  (setq osm (getvar "osmode"))
  (if (and *mdpt* *mdp1* (setq ss (ssget)))
    (progn
      (setvar "osmode" 0)
      ;; Added trans 8/27/2008.
      (command "._move" ss "" (trans *mdpt* 0 1) (trans *mdp1* 0  1))
    )
    (princ "\nNothing selected or minimum distance points not set. ")
  )
  (*error* nil)
) ;end
;shortcut
(defun c:MDM () (c:MinDistMove))

(defun c:MinDistCopy ( / *error* doc osm ss)

  (defun *error* (msg)
    (cond
      ((not msg))
      ((wcmatch (strcase msg) "*QUIT*,*CANCEL*"))
      (T (princ (strcat "\nError: " msg)))
    )
    (setvar "osmode" osm)
    (vla-EndUndoMark doc)
    (princ)
  ) ;end error

  (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (vla-StartUndoMark doc)
  (setq osm (getvar "osmode"))
  (if (and *mdpt* *mdp1* (setq ss (ssget)))
    (progn
      (setvar "osmode" 0)
      ;; Added trans 8/27/2008.
      (command "._copy" ss "" (trans *mdpt* 0 1) (trans *mdp1* 0  1))
    )
    (princ "\nNothing selected or minimum distance points not set. ")
  )
  (*error* nil)
) ;end
;shortcut
(defun c:MDC () (c:MinDistCopy))


;; Revised 6/30/2008.
;; Draw minimum distance line on the current layer.
(defun c:MinDistLine ( / d sc ss)
  (cond
    ((not (and *mdpt* *mdp1*))
      (princ "\n Minimum distance points not found. Run MD and then MDL to draw line.")
    )
    ((and 
       (setq d (distance *mdpt* *mdp1*))
       ;(print d) ;testing
       (< d 1e-5)
      )
      (princ "\n Minimum distance points are too close together. ")
    )
    (T
      (entmake 
        (list 
          '(0 . "LINE")
           (cons 8 (getvar "clayer"))
           (cons 10 *mdpt*)
           (cons 11 *mdp1*)
        )
      )
      (setq sc (MD:GetScreenCoords))
      (if 
        (or
          (MD:PointInside (car sc) (cadr sc) *mdpt*)
          (MD:PointInside (car sc) (cadr sc) *mdp1*)
        )
        (princ "\n Minimum distance line placed. ")
        (progn
          (princ "\n Minimum distance line placed off screen and selected. ")
          (sssetfirst nil (setq ss (ssget "L")))
        )
      )
    )
  )
  (princ)
) ;end MinDistLine

;shortcut
(defun c:MDL () (c:MinDistLine))

 


<<

Filename: 451026_mindist_md_mindistmove_mdm_mindistcopy_mdc_mindistline_mdl.lsp
Tác giả: hanam1210
Bài viết gốc: 173573
Tên lệnh: sn
Lisp số học để kiểm tra san nền !

(defun c:sn (/ ss tDt tKq dt len hs)
(defun dxf (code en)(cdr(assoc code (entget en))))
(defun chdxf (code val en) (entmod (subst (cons code val)...
>>

(defun c:sn (/ ss tDt tKq dt len hs)
(defun dxf (code en)(cdr(assoc code (entget en))))
(defun chdxf (code val en) (entmod (subst (cons code val) (assoc code (entget en)) (entget en))))
(if
(and
   	(setq ss (ssget (list (cons 0 "TEXT,MTEXT"))))      
   	(setq tDt (car (entsel "\nText DT :")))
   	(wcmatch (dxf 0 tDt) "TEXT,MTEXT")
   	(setq dt (distof (dxf 1 tDt)))
   	(setq tkQ (car (entsel "\nText kQ :")))
   	(wcmatch (dxf 0 tkQ) "TEXT,MTEXT")
)
(progn
(setq len (sslength ss) hs
   	(cond	((= len 1)3)((= len 2)4)((= len 3)5)((= len 4)4)(T 1))	;gia tri he so
)  
(chdxf 1  (rtos (/ (* (apply '+ (mapcar '(lambda(x)(distof (acet-dxf 1 (entget x))))(acet-ss-to-list ss))) dt) hs) 2 2) tkq)
(chdxf 8 "0" tKq) ;Thay 0 bang Layer khac
)  
))

 

Chuẩn không cần chỉnh. Cảm ơn bác KETXU nhé.hii. Lisp của bác thay cả 4 cái lisp em viết !


<<

Filename: 173573_sn.lsp
Tác giả: trongquan
Bài viết gốc: 57408
Tên lệnh: ch3
Viết lisp chia đoạn thẳng thành 3 phần
Còn một điều nữa khi làm việc với đường cong là mình thấy hằng số acExtendBoth trong hàm ints không thích hợp, vì nó có thể cắt ở điểm giao "ảo", tức là điểm extend...
>>
Còn một điều nữa khi làm việc với đường cong là mình thấy hằng số acExtendBoth trong hàm ints không thích hợp, vì nó có thể cắt ở điểm giao "ảo", tức là điểm extend của đg cong. Mình xin sửa lại là acExtendNone để chỉ cắt ở điểm giao "thực". CT sửa lại như sau:

(vl-load-com)

(defun ints (o1 o2 / obj1 obj2 li a1)
  (setq obj1 (vlax-EName->vla-Object o1)
    	 obj2 (vlax-EName->vla-Object o2)
 li nil)
 (setq a1  (vlax-Invoke obj1 "IntersectWith" obj2 acExtendNone))
 (if a1
   (while a1
(setq li (append li (list (list (car a1) (cadr a1) (caddr a1)))))
(repeat 3 (setq a1 (cdr a1)))))
 li
)

(defun c:ch3()
 (prompt "\nChon vat bi cat:")
 (setq ss (ssget '((0 . "LINE,LWPOLYLINE,ARC,SPLINE"))))
 (prompt "\nChon vat cat:")
 (setq ss1 (ssget '((0 . "LINE,LWPOLYLINE,ARC,CIRCLE,ELLIPSE,SPLINE")))
os (getvar "OSMODE"))

 (setvar "OSMODE" 0)
 (setvar "CMDECHO" 0)
 (while (and ss (> (sslength ss) 0))
   (setq v (ssname ss 0)
  n 0
  L nil)
   (repeat (sslength ss1)
     (setq v1 (ssname ss1 n)
    n (1+ n)
    L (ints v v1))
     (if L
(foreach p L 
    (command "break" v p p)
    (ssadd (entlast) ss)))
   )
   (ssdel v ss)
 )
 (setvar "OSMODE" os)
 (setvar "CMDECHO" 1)
)

Đoạn code này của bạn đã khắc phục được khi đối tượng biên cắt là Ellisp thì đã cắt được các đối tượng sau khi bạn đã sửa điểm giao cắt là thực. Hy vọng đoạn code tiếp tục được cải tiến thành các phiên bản mới!

Theo tôi nghĩ chia sẻ trên diễn đàn giúp kiến thức của mình cũng như mọi người càng được nâng cao, là nơi bạn được thể hiện mình, mọi người nhận ra khả năng của bạn ---> tăng mối quan hệ, dẫn tới thành công.

Một đề bài để mọi người thảo luận như một bài toán khiến chúng ta trăn trở giải quyết nhiều khi cũng thật là thú vị, giống như thời đi học khi thầy giáo ra đề toán mà chưa giải được là chúng ta cảm giác bứt rứt, khó ăn khó ngủ phải không?


<<

Filename: 57408_ch3.lsp
Tác giả: ngokiet
Bài viết gốc: 451074
Tên lệnh: sspline
Lisp so sánh 2 Polygons xem chúng bằng nhau hoặc đồng dạng hay không

Mình có viết thử 1 chút.

(defun c:sspline(/ en1 en2 infopl sspl)
  (defun infopl(en / d a b p tm)
    (mapcar '(lambda(x)
	       (Cond ((eq (car x) 10) (setq p (append p (list (cdr x)))))
		     ((eq (car x) 42) (setq b (append b (list (cdr x)))))))
	    en)
    (setq d (mapcar 'distance p (append (cdr p) (list (car p))))
	  a (mapcar 'angle (cons (last p) p) p)
	  a (mapcar '- a (cons (last a) a))
	...
>>

Mình có viết thử 1 chút.

(defun c:sspline(/ en1 en2 infopl sspl)
  (defun infopl(en / d a b p tm)
    (mapcar '(lambda(x)
	       (Cond ((eq (car x) 10) (setq p (append p (list (cdr x)))))
		     ((eq (car x) 42) (setq b (append b (list (cdr x)))))))
	    en)
    (setq d (mapcar 'distance p (append (cdr p) (list (car p))))
	  a (mapcar 'angle (cons (last p) p) p)
	  a (mapcar '- a (cons (last a) a))
	  a (mapcar '(lambda(x) (if (< x 0) (+ x pi pi) x)) a))
    (list (cdr (assoc 70 en)) d a b))
  (defun sspl(s1 s2 / n ss1 ss2 rex s3 k)
    (defun rex(x) (append (cdr x) (list (car x))))
    (defun ss1(s1 s2 eqn) (vl-every '(lambda(a b) (equal a b eqn)) s1 s2))
    (defun ss2(s1 s2 / sc)
      (setq sc (/ (caar s1) (caar s2)))
      (if (and (vl-every '(lambda(a b) (equal sc (/ a b) 1e-12)) (car s1) (car s2)) ; So saanh canh
	       (ss1 (cadr s1) (cadr s2) 1e-8) ; So sanh goc
	       (ss1 (caddr s1) (caddr s2) 1e-8)); So sanh bul
	sc))
    (if (and
	  (eq (car s1) (car s2))
	  (eq (setq n (length (cadr s1))) (length (cadr s2))))
      (progn
	(if (eq (car s1) 0) (setq n 1))
	(setq s1 (cdr s1) s2 (cdr s2)
	      s3 (mapcar 'reverse (list (car s1) (mapcar '(lambda(x) (- (+ pi pi) x)) (cadr s1)) (mapcar '- (caddr s1))))
	      s3 (list (car s3) (rex (cadr s3)) (caddr s3)))
	(while (and (not (or (setq k (ss2 s1 s2))
			     (setq k (ss2 s3 s2))))
		    (/= (setq n (1- n)) 0))
	  (setq s1 (mapcar 'rex s1)
		s3 (mapcar 'rex s3)))
	k)))
  (if (and (setq en1 (car (nentsel "Select pline 1:")))
	   (eq (cdr(assoc 0 (setq en1 (entget en1)))) "LWPOLYLINE")
	   (setq en2 (car (nentsel "Select pline 2:")))
	   (eq (cdr(assoc 0 (setq en2 (entget en2)))) "LWPOLYLINE"))
    (if (setq en1 (sspl (infopl en1) (infopl en2)))
      (alert (strcat "2 Polyline dong dang ti le canh " (rtos en1)))
      (alert (strcat "2 Polyline khong dong dang " )))))

- Chỉ xét đồng dạng. chưa xét đối xứng.

- Viết theo kiểu xét các cạnh và góc bằng nhau.

- Có so sánh luôn polyline cả line và arc.

Có sai 1 chút nhưng chưa rảnh đề sửa là nếu open PL thì lỡ so sánh luôn bulge cuối không có cạnh. Và chưa so sánh luôn phần đối xúng.


<<

Filename: 451074_sspline.lsp
Tác giả: quansla
Bài viết gốc: 444142
Tên lệnh: zz
Lấy chiều dài của đối tượng trong BLOCK động

Cảm ơn mọi người đã quan tâm, mình đi xã cả ngày giờ mới online được mới đầu mình cũng đã nghĩ đến việc chắc phải gắn các chiều dài vào Pramateter để đo rồi dùng Lisp để lọc Parameter theo Visiabli, rồi lấy giá trị hiện tại

 

Cơ mà cách này:

 thủ công; và cách gán Prameter sẽ tương đối khó nếu đối tượng cung tròn (nói chung vẫn tính được, nhưng...

>>

Cảm ơn mọi người đã quan tâm, mình đi xã cả ngày giờ mới online được mới đầu mình cũng đã nghĩ đến việc chắc phải gắn các chiều dài vào Pramateter để đo rồi dùng Lisp để lọc Parameter theo Visiabli, rồi lấy giá trị hiện tại

 

Cơ mà cách này:

 thủ công; và cách gán Prameter sẽ tương đối khó nếu đối tượng cung tròn (nói chung vẫn tính được, nhưng cần gán công thức chuyên dụng ứng với từng trường hợp); Khá rối loạn khi vào môi trường BE (block editor)

 

 

* không biết có cách nào khác không nhỉ

 

 

 

@Duong Nhat Duy Với code của bạn khi tính đường đối tượng đường cong có thể lỗi, có thể thay phần tính chiều dài bằng: 

(setq len (+ len (vlax-curve-getdistatparam each_obj (vlax-curve-getendparam each_obj))))

 

 

@Duong Nhat Duy Ví dụ với code Entnext 

(defun c:zz()
  (if(and (setq ss (ssget '(( 0 . "INSERT"))))
	  (setq dt (ssname ss 0))
	  (setq blk (vlax-ename->vla-object dt) i 0))
    (progn

      (setq tenblk (if (vlax-property-available-p blk 'effectivename)
		     (vla-get-effectivename blk)
		     (vla-get-name blk)
		     )
	    )
      (setq dt_bk (cdr (assoc -2 (tblsearch "Block" tenblk))))
      (while (/= "SEQEND" (cdr(assoc 0 (entget dt_bk))))	
	(princ (strcat "\nDoi tuong trong block thu " (rtos (setq i (1+ i)) 2 0) " la doi tuong: " (cdr(assoc 0 (entget dt_bk)))))
	(setq dt_bk (entnext dt_bk))
	)
      )
    )
  (princ)
  )

@duy782006 có vẻ cách của anh Duy là dùng Gán đối tượng cần lấy chiều dài cho Parameter sau đó dùng thủ thuật lấy giá trị của parameter; Như vậy trùng với cách ban đầu, cách này không tiện khi nhiều đối tượng -> nhiều parameter (thậm chí các parameter này cũng không có gán hành động luôn, chỉ cho vào để về sau get giá trị)

 

 

 

@Doan Nguyen Van Cách của bác theo em là hay nhất nhưng em chưa hiểu lời giải lắm, có vẻ như là nó tạo ra một tập hợp "ảo" gồm các phần từ đã explore từ Block đầu đúng không, sau đó dùng lệnh lọc qua để tìm chiều dài

 

Cách làm này tương đương ngoài thực tế làm Cad

B1/ chọn Block

B2/ "X" nổ đối tượng

B3/ Xét riêng tập sau khi nổ xong: duyệt qua từng thằng tính chiều dài thép 

B4/ Ghi lại giá trị tổng chiều dài, xóa đi toàn bộ tập đã tạo ra sau khi nổ ở B2

(P/S Linh hồn của Code này có lẽ là ở đoạn này: (vlax-invoke (vlax-ename->vla-object ent) 'explode)             )

 

Cảm ơn bác, mong bác giải thích kỹ hơn nếu không đúng


<<

Filename: 444142_zz.lsp
Tác giả: ketxu
Bài viết gốc: 451222
Tên lệnh: 1
TẠO LISP CAD
(defun c:1()(setvar 'clayer "1"))

Lisp trên đổi layer hiện hành sang layer "1", với điều kiện Layer đó đã có trên bản vẽ. Bạn tự copy thêm và edit để được các layer 2,3,4... theo ý muốn


Filename: 451222_1.lsp
Tác giả: huunhantvxdts
Bài viết gốc: 451261
Tên lệnh: ttx
Xin sửa lisp xuất toạ độ text sang excel
2 giờ trước, TASHI đã nói:

mình có 1 lisp nó xuất được...

>>
2 giờ trước, TASHI đã nói:

mình có 1 lisp nó xuất được toạ độ của chữ text nhưng nó ra toạ độ có sau dấu phẩy có 2 số, mình xin các pro sửa giúp mình toạ độ lấy sau dấy phẩy 3 số

58881_text_cad_sang_excel_ttx.lsp

sửa lại cho bạn

(defun c:ttx  (/ ss ss1 y xlApp xlCells row col i iPt)
  (vl-load-com)
  (if (setq ss (ssget '((0 . "*TEXT"))))
    (progn
      (setq xlApp   (vlax-get-or-create-object "Excel.Application")
            xlCells (vlax-get-property
                      (vlax-get-property
                        (vlax-get-property
                          (vlax-invoke-method
                            (vlax-get-property xlApp "Workbooks")
                            "Add") "Sheets") "Item" 1) "Cells") row 0 col 1)
      (vla-put-visible xlApp :vlax-true)
      
      (setq ss (mapcar '(lambda (x) (list (vlax-get (vlax-ename->vla-object x) 'InsertionPoint)
					  (vlax-ename->vla-object x)))		  
		       (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))))	   
      (while ss
	(setq  ss (vl-sort ss '(lambda (x y) (< (cadr (car x)) (cadr (car y)))))
	       ss1 (vl-remove-if-not '(lambda (x) (equal (cadr (caar ss)) (cadr (car x)) 0.3)) ss)
	       ss1 (vl-sort ss1 '(lambda (x y) (< (caar x) (caar y))))
	       ss (vl-remove-if '(lambda (x) (member x ss1)) ss)
	)
	(foreach z ss1
          (setq iPt (car z)
		y (list (vla-get-TextString (last z))  (rtos (car iPt) 2 3)  (rtos (cadr iPt) 2 3) (rtos (caddr iPt) 2 3))
	  ) 
          (if (> row 65536) (setq col 5))
          (setq i -1 row (1+ row))
          (mapcar '(lambda (x) (vlax-put-property xlCells "Item" row  (+ col (setq i (1+ i))) x)) y)
	)
      )
    )
  )
  (mapcar 'vlax-release-object (list xlApp xlCells))
  (princ)
)

 


<<

Filename: 451261_ttx.lsp

Trang 315/330

315