Bạn cần đánh số cột đèn đúng ko :leluoi:

Cái này tôi đã làm giúp một đồng chí ở cty, nhưng có cái khác là bạn phải ký hiệu dạng T3-L1/4/A hoặc T3-L1/4:A . Tôi ko...

>>

Bạn cần đánh số cột đèn đúng ko :leluoi:

Cái này tôi đã làm giúp một đồng chí ở cty, nhưng có cái khác là bạn phải ký hiệu dạng T3-L1/4/A hoặc T3-L1/4:A . Tôi ko fải dân chuyên ngành điện nên ko hiểu được cách ký hiệu nào đúng. Tôi đưa lên lisp phục vụ cả 2 cách để bạn lựa chọn :s_dead: )

Cách dùng: tạo một text đầu tiên, đánh lệnh "DSC", chọn text gốc, chọn giá trị bước nhảy, chọn điểm gốc copy -- chọn điểm copy tới ... đến khi muốn dừng thì thôi.

;;;===================================================================
;;;      Danh so cot den:
(defun c:dsc (/	     ang    x	   y	  ent	 tg	tg1tg2 num_r
      num_c  num_inc	   dis_r  dis_c	 num	top    idnum
      dx     dy	    bottom inc	  tgnum	 attr	attr_ent
      t_base b_base locat  value  deci	 stnum	loca1  loca2
      tt     count  inctg  inctg1 bpoint mx	my     nx
      ny     bx	    by
     )
 (setq idnum 0)
 (while (/= idnum 1)
   (setq ent (entsel "\nHay lua chon so ma ban muon copy : "))
   (if	ent
     (progn
(setq e (car ent))
(setq tg (entget e))
(if (= (cdr (assoc 0 tg)) "TEXT")
  (setq idnum 1)
)
     )
     (princ)
   )
 )

 (setq num_inc (getreal "\nHay nhap he so tang giam <1> : "))
 (if (= num_inc nil)
   (setq num_inc 1)
 )

 (setq bpoint (getpoint "\nChon diem goc de copy : "))
 (setq x (car bpoint))
 (setq y (car (cdr bpoint)))

 (if (and (= (cdr (assoc 72 tg)) 0) (= (cdr (assoc 73 tg)) 0))
   (progn
     (setq bx (car (cdr (assoc 10 tg))))
     (setq by (car (cdr (cdr (assoc 10 tg)))))
   )
   (progn
     (setq bx (car (cdr (assoc 11 tg))))
     (setq by (car (cdr (cdr (assoc 11 tg)))))
   )
 )

 (setq attr (cdr tg))
 (setq tg (cdr (assoc 1 tg)))
 (setq inc 0)
 (setq tg1 "")
 (setq t_base "")
 (setq b_base "")
 (setq idnum 0)
 (setq top 0)
 (setq bottom 0)
 (setq stnum "")
 (setq deci 0)
 (repeat (strlen tg)
   (if
     (or (and (> (ascii (setq tgnum (substr tg (- (strlen tg) inc) 1)))
	  47
       )			;(chr 32)
       (< (ascii (setq tgnum (substr tg (- (strlen tg) inc) 1)))
	  58
       )
  )

  (= (ascii (setq tgnum (substr tg (- (strlen tg) inc) 1)))
     32
  )

  (= (ascii (setq tgnum (substr tg (- (strlen tg) inc) 1)))
     46
  )
     )
      (progn
 (if (=	(ascii (setq tgnum (substr tg (- (strlen tg) inc) 1)))
	46
     )
   (setq deci inc)
 )
 (if (= inc 0)
   (progn
     (setq idnum 1)
     (if
       (= (ascii (setq tgnum (substr tg (- (strlen tg) inc) 1)))
	  46
       )
	(setq b_base (strcat "." b_base))
     )
   )
 )
 (if (= bottom 1)
   (progn (setq bottom 0) (setq idnum 1) (setq top 1))
 )
 (if (and (= idnum 0) (= top 1))
   (setq t_base (strcat tgnum t_base))
 )
 (if (= idnum 1)
   (progn
     (if (and (= tgnum "0") (> inc 0))
       (setq stnum (strcat stnum "0"))
       (setq stnum "")
     )
     (setq tg1 (strcat tgnum tg1))
   )
 )
      )
      (if (= inc 0)
 (progn
   (setq b_base (strcat tgnum b_base))
   (setq bottom 1)
 )
 (if (= bottom 1)
   (setq b_base (strcat tgnum b_base))
   (progn
     (setq top 1)
     (setq t_base (strcat tgnum t_base))
     (if (= idnum 1)
       (setq idnum 0)
     )
   )
 )
      )
   )
   (setq inc (+ inc 1))
 )

 (if (= tg1 "")
   (exit)
 )
 (setq num (atof tg1))
 (setq count 1)

 (while (setq bpoint (getpoint "\nChon diem copy tiep theo : "))
   (setq num (+ num num_inc))
   (if	(>= (strlen b_base) 1)
     (cond
((or (=	"A"
	(strcase (substr b_base (strlen b_base) 1))
     )
     (=	"B"
	(strcase (substr b_base (strlen b_base) 1))
     )
 )
 (setq b_base
	(strcat
	  (substr b_base 1 (1- (strlen b_base)))
	  (chr (1+ (ascii (substr b_base (strlen b_base) 1))))
	)
 )
)
((= "C" (strcase (substr b_base (strlen b_base) 1)))
 (setq
   b_base (strcat (substr b_base 1 (1- (strlen b_base))) "A")
 )
)
     )

   )
   (setq value (strcat t_base (strcat stnum (rtos num 2 deci)) b_base))
   (setq nx (car bpoint))
   (setq ny (car (cdr bpoint)))
   (setq dx (- nx x))
   (setq dy (- ny y))
   (setq mx (car (getvar "ucsxdir")))
   (setq my (car (cdr (getvar "ucsxdir"))))
   (setq loca1 (+ bx (* mx dx)))
   (setq loca2 (+ by (* my dx)))
   (setq mx (car (getvar "ucsydir")))
   (setq my (car (cdr (getvar "ucsydir"))))
   (setq loca1 (+ loca1 (* mx dy)))
   (setq loca2 (+ loca2 (* my dy)))
   (setq attr_ent (subst (cons 1 value) (assoc 1 attr) attr))
   (if	(and (= (cdr (assoc 72 attr_ent)) 0)
     (= (cdr (assoc 73 attr_ent)) 0)
)
     (setq attr_ent (subst (list 10 loca1 loca2 0)
		    (assoc 10 attr_ent)
		    attr_ent
	     )
     )
     (setq attr_ent (subst (list 11 loca1 loca2 0)
		    (assoc 11 attr_ent)
		    attr_ent
	     )
     )
   )
   (entmake attr_ent)
   (setq count (+ count 1))
 )					;end while
 (princ)
)

 

:angry:) Cảm ơn Snowmen rất nhiều, kô bit làm j để cảm ơn bạn đây.cái này giúp mình tiết kiện đc rất nhiều thời gian đấy, 1 lần nữa cảm ơn bạn lắm lắm

<<

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

Cảm ơn bác Tuệ...

>>

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

Cảm ơn bác Tuệ đã quan tâm . nhưng bác cho em hỏi sao em load lisp lên lại không dùng được ạ  ( em dùng cad 2007 ) . em cảm ơn

bạn thêm dòng (vl-load-com) vào đầu lisp là sử dụng được nhé

Viết thêm code bổ sung chọn nhiều đường cắt màu đỏ 

1./ Chọn các đường cắt màu đỏ

2./ Chọn toàn bộ đường cần cắt. Quét hết (có thể trong đó bao gồm luôn cả đường cắt) thì lisp sẽ hoạt động

(vl-load-com)
(defun c:trr(/ es1 e2 i en j lst-res ss1 ss)
(defun Tue-geom-divpt (p1 p2 k)
    (polar p1 (angle p1 p2) (* (distance p1 p2) k))
)
(defun Tue-list-tach (lst count / i j Lst-tinh Reslis)
 ;;;;;Ex: (Tue-list-tach '(1 5 4 6 3 5) 2)--> ((1 5) (4 6) (3 5))
 ;;;;;;;;;(Tue-list-tach '(1 5 4 6 3 5) 3)--> ((1 5 4) (6 3 5))
 ;;;;;;;;;(Tue-list-tach '(1 5 4 6 3 5) 5)--> nil
   (setq i 0 j 0)
   (while (and (< i (/ (length lst) count)) (= (rem (length lst) count) 0))
    (Repeat count
      (setq Lst-tinh (append Lst-tinh (list (nth j lst)) ))
      (setq j (1+ j))  
     )
         (setq Reslis (append Reslis (list Lst-tinh))
           Lst-tinh nil)
     (setq i (1+ i))
    )
 Reslis
)
(defun Tue-geom-inters(e1 e2 flag / Lst_tong Lst);;;Tue-list-tach
 ;;; flag= 0 : acExtendNone Does not extend either object.
 ;;; flag= 1 : acExtendThisEntity Extends the base object.
 ;;; flag= 2 : acExtendOtherEntity Extends the object passed as an argument.
 ;;; flag= 3 : acExtendBoth  Extends both objects.
;;Ex: (Tue-geom-inters (ssname (TUE-SS-ENTSEL '((0 . "*LINE,ARC,CIRCLE,ELLIPSE")) "\npick chon doi tuong thu 1 :") 0)
;;;;;;;;;;;;;;;;;;;;;;;(ssname (TUE-SS-ENTSEL '((0 . "*LINE,ARC,CIRCLE,ELLIPSE")) "\npick chon doi tuong thu 2 :") 0) 0)
  (if (= (type e1) 'ENAME) (setq e1 (vlax-ename->vla-object e1)))
  (if (= (type e2) 'ENAME) (setq e2 (vlax-ename->vla-object e2)))
  (Tue-list-tach (vlax-invoke e1 'IntersectWith e2 flag) 3)
)
;;;main
 (princ "chon cac duong cat: ")
   (setq ss1 (ssget '((0 . "*LINE"))) j -1 i -1 lst-res '())
   (setq ss (ssget '((0 . "*LINE,ARC"))));;line cat
   (while (setq en (ssname ss (setq i (1+ i))))
       (while (setq es1 (ssname ss1 (setq j (1+ j))))
      (if (setq p1 (Tue-geom-inters es1 en 0))
        (setq lst-res (append lst-res (List (list es1 (car p1)))))
         )
       )
     (if (= (length lst-res) 2) (command "._trim" (caar lst-res) (caadr lst-res) ""
                     (Tue-geom-divpt (cadar lst-res) (cadadr lst-res) 0.5) "")
     )
     (setq j -1 lst-res '())
   )

  )

 

<<

Hề hề hề, Như vậy, theo yêu cầu củ bạn thì cái lisp mình viết cơ bản đả đạt được, chỉ khác một vài điểm như sau: 1/-...

>>

Hề hề hề, Như vậy, theo yêu cầu củ bạn thì cái lisp mình viết cơ bản đả đạt được, chỉ khác một vài điểm như sau: 1/- Lisp đã hoàn toàn tự động lấy các đối tượng trong vùng chọn của bạn. bạn có thể thêm vào báo nhiêu đường chăng nữa lisp vẫn chỉ chạy một lần là ra cái bảng thống kê cho bạn, với đầy đủ các đối tượng dạng đường (gồm line, lwpolyline, circle, polyline) còn các đường khác như arc ellipse, spline mình chưa viết nhưng co lẽ không quá khó khăn để làm với cấu trú tương tụ của lisp. 2/- Mình xuất riêng rẽ tọa độ x, y ,z, nay bạn muốn xuất cả cụm củng không thành vấn đề nhưng lưu ý bạn rằng không dùng cái dấu phẩy để ngăn cách các tọa độ x, y, z được vì như vậy khi xuất sang file csv nó sẽ hiểu là tách cột ra bạn ạ. Do vậy mình sẽ để một khoảng trắng ngăn cách giữa các tọa độ này, bạn có đồng ý không??? 3/- Mình sẽ bổ sung phần xử lý các đường spline, arc và ellipse để bạn dùng thử. Chịu khó chờ một chút nghen. Của bạn đây:

 (defun c:getpr (/ ssl fn fw els name lay col txt p p1 p2 pt x y z x1 x2 y1 y2 z1 z2 bk ) (setq ssl (acet-ss-to-list (ssget)) fn (getfiled "Chon file de save" "" "txt" 1) fw (open fn "w") ) (princ " Bang liet ke thuoc tinh co ban cua doi tuong \n " fw) (if (not d0) (setq d0 0.5)) (setq d1 (getreal "\n Nhap do dai cua moi phan doan Spline: ")) (if d1 (setq d0 d1) (setq d1 d0)) (foreach en ssl (setq els (entget en) name (cdr (assoc 0 els)) lay (cdr (assoc 8 els)) col (if (assoc 62 els) (rtos (cdr (assoc 62 els)) 2 0) (rtos (cdr (assoc 62 (tblsearch "layer" lay))) 2 0)) txt (strcat name "," lay "," col ) ) (cond ((= name "LINE") (setq p1 (cdr (assoc 10 els)) p2 (cdr (assoc 11 els)) x1 (rtos (car p1) 2 2) x2 (rtos (car p2) 2 2) y1 (rtos (cadr p1) 2 2) y2 (rtos (cadr p2) 2 2) z1 (rtos (caddr p1) 2 2) z2 (rtos (caddr p2) 2 2) txt (strcat txt "," x1 " " y1 " " z1 "," x2 " " y2 " " z2) ) ) ((= name "CIRCLE") (setq bk (rtos (cdr (assoc 40 els)) 2 2) pt (cdr (assoc 10 els)) x (rtos (car pt) 2 2) y (rtos (cadr pt) 2 2) z (rtos (caddr pt) 2 2) txt (strcat txt "," x " " y " " z "," bk ) ) ) ((= name "LWPOLYLINE") (foreach el els (if (= (car el) 10) (progn (setq z (rtos (cdr (assoc 38 els)) 2 2) x (rtos (cadr el) 2 2) y (rtos (caddr el) 2 2) txt (strcat txt "," x " " y " " z) ) ) ) ) ) ((= name "POLYLINE") (setq en (entnext en)) (while (/= (cdr (assoc 0 (entget en))) "SEQEND") (setq x (rtos (cadr (assoc 10 (entget en))) 2 2) y (rtos (caddr (assoc 10 (entget en))) 2 2) z (rtos (cadddr (assoc 10 (entget en))) 2 2) txt (strcat txt "," x " " y " " z) en (entget en) ) ) ) (( or (= name "SPLINE") (= name "ARC" ) (= name "ELLIPSE") ) (makepl en d1) (setq en1 (entlast) plst (acet-geom-vertex-list en1) ) (foreach p plst (setq txt (strcat txt "," (rtos (car p) 2 2) " " (rtos (cadr p) 2 2) " " (rtos (caddr p) 2 2) ) ) ) ) (T nil) ) (princ (strcat txt "\n") fw) ) (close fw) (princ) ) ;;;------------------------------------------------------------- (defun makepl ( e d1 / ps pe d d2 p2) ;;;Make pline along curve e. Length of 1 segment = d1 (vl-load-com) ;;;Load Visual LISP extensions before use vlax-xxxx functions (setq ps (vlax-curve-getStartPoint e) ;;;Start point pe (vlax-curve-getEndPoint e) ;;;End point d (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) ;;;Length of curve e d2 d1 ;;;Init variable distance ) (command "pline") ;;;Call pline command (command ps) ;;;Start point (while (<= d2 d) ;;;While not over end point pe (setq p2 (vlax-curve-getPointAtDist e d2)) ;;;Variable point at d2 = length along curve (command p2) ;;;Continue pline command from current point to p2 (setq d2 (+ d2 d1)) ;;;Increase distance d2 by d1 ) ;;;End while (command pe "") ;;;Pline to pe and finish command ) ;;;------------------------------------------------------------- 

Chúc bạn vui. Chú ý mình vẫn để hai giá trị chỉ thuộc tính laỷe và màu của đối tượng trong líp. Nếu bạn không thích thì có thể thoải mái xóa nó đi.

 

 

xem

Việc bạn đang yêu cầu lisp ở box này đã là k đúng nội quy rồi, mà bác Bình nhiệt tình quá nên đành chịu vậy ^^ CHúc bạn sớm thành công :)

 

hic. Khi mà em nói đến mấy cái lisp thì em cũng biết là không đúng nơi nên em đã viết một bài ở box khác để định chuyển qua đó nhưng bài đó lại bị xóa.

biết sai!!!!

có gì anh thông cảm, thanks anh nhiều.

<<

 

Lisp của bác đây:

;========LISP OFFSET==========
;====KANGKUNG 28/03/2013======
(defun C:LG12()
  (command...
>>

 

Lisp của bác đây:

;========LISP OFFSET==========
;====KANGKUNG 28/03/2013======
(defun C:LG12()
  (command "UNDO" "BE")
  (setq os(getvar "OSMODE"))
  (setvar "OSMODE" 0)
  (setq dt (car(entsel)) i (/ pi 2))
  (repeat 2
    (setq pt (polar (vlax-curve-getPointAtDist dt 0) (+ (angle (vlax-curve-getPointAtDist dt 0) (vlax-curve-getPointAtDist dt (+ 0 0.1))) i) 1))
    (of "3" pt "00_Mep duong")
    (of "6" pt "00_Mep he")
    (setq i (/ pi -2))
    )
  (setvar "OSMODE" os)
  (command "UNDO" "END")
  )
(defun C:LG13()
  (command "UNDO" "BE")
  (setq os(getvar "OSMODE"))
  (setvar "OSMODE" 0)
  (setq dt (car(entsel)) i (/ pi 2))
  (repeat 2
    (setq pt (polar (vlax-curve-getPointAtDist dt 0) (+ (angle (vlax-curve-getPointAtDist dt 0) (vlax-curve-getPointAtDist dt (+ 0 0.1))) i) 1))
    (of "3.5" pt "00_Mep duong")
    (of "6.5" pt "00_Mep he")
    (setq i (/ pi -2))
    )
  (setvar "OSMODE" os)
  (command "UNDO" "END")
  )
(defun of(di pt la)
  (command "offset" di dt pt "")
  (if (= (tblsearch "Layer" la) nil)
    (progn
      (command "LAYER" "N" la "")
      (vla-put-layer (vlax-ename->vla-object (entlast)) la))
    (vla-put-layer (vlax-ename->vla-object (entlast)) la)))
(princ "\n                Written By KangKung - 28/03/2013\n")

 

Thanks bạn KangKung rất nhiều!

Lisp rất ok.

Các bạn làm qh nên down Lisp này về làm sẽ tiết kiện đc rất nhiều thời gian.

<<

6 phút trước, hamy2018 đã nói:

Lisp này của bác khá hay. tuy nhiên...

>>

6 phút trước, hamy2018 đã nói:

Lisp này của bác khá hay. tuy nhiên nếu có thể làm được theo kiểu chọn nhiều đối tượng thì tốt quá ạ. còn đặt dim bên nào cũng được ạ, đặt dồng loạt ạ.

bác có thể cho em xin code của lisp trên ko ạ!

(defun c:dc (/ ent ent2 p1 p2)
  (if (setq ent (car (entsel "\nCh\U+1ECDn \U+0111\U+1ED1i t\U+01B0\U+1EE3ng \U+0111\U+1EA7u ti\U+00EAn!"))) (progn
	  (if (wcmatch (cdr (assoc 0 (entget ent))) "INSERT,CIRCLE")
    (progn 
  (while (setq ent2 (car (entsel "\nCh\U+1ECDn \U+0111\U+1ED1i t\U+01B0\U+1EE3ng ti\U+1EBFp theo!")))
    (if (wcmatch (cdr (assoc 0 (entget ent2))) "INSERT,CIRCLE") (progn
    (setq p1 (cdr (assoc 10 (entget ent)))
	  p2 (cdr (assoc 10 (entget ent2))) )
    (command "DIMLINEAR" "_non" p1 "_non" p2 pause)
    (setq ent ent2)
    ) (alert "\n\U+0110\U+1ED1i t\U+01B0\U+1EE3ng kh\U+00F4ng ph\U+1EA3i Block, Circle!")
      )
    )
  ) (alert "\n\U+0110\U+1ED1i t\U+01B0\U+1EE3ng kh\U+00F4ng ph\U+1EA3i Block, Circle!")
  ))))

Chọn nhiều đối tượng thì mình chịu, sort thế nào cho vừa ý đc 

<<

21 phút trước, monavamonava đã nói:

Một trong 2 phương pháp...

>>

21 phút trước, monavamonava đã nói:

Một trong 2 phương pháp đều ok cả. Làm cách nào hay vậy bác. Chỉ em cách tự động pick vào các mắt lưới với...

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

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

   (> (abs Defl) 4)
 )
)
(defun C:te (/ ss1 p1 p2 p3 ss t1 lst pt)
  (Prompt "\nQu\U+00E9t v\U+00F9ng ch\U+1EE9a c\U+00E1c \U+0111i\U+1EC3m giao")
  (setq ss (acet-ss-to-list (ssget (list (cons 0 "LINE,LWPOLYLINE")))))
  (if (and ss) (progn			
  (setq t1 0)
  (mapcar '(lambda (x) (if (> (vlax-curve-getendparam x) t1) (progn (setq ent x) (setq t1 (vlax-curve-getendparam x)))) ) ss)
  (setq ss (vl-remove ent ss))
  (setq ss (vl-sort ss '(lambda (x y) (< (vla-get-length (vlax-ename->vla-object x)) (vla-get-length (vlax-ename->vla-object y))))))
  (setq ss1 (list (car ss)) 
	ss (cdr ss))
  (setq p1 (vlax-curve-getpointatparam (car ss1) (vlax-curve-getstartparam (car ss1)))
	p2 (vlax-curve-getpointatparam (car ss1) (+ 1 (vlax-curve-getstartparam (car ss1)) ))
	p3 (list (/ (+ (car p1) (car p2)) 2) (/ (+ (cadr p1) (cadr p2)) 2) (/ (+ (caddr p1) (caddr p2)) 2)))
  (setq lst (getlstpoint ss))
  (foreach pt lst
    (if (@Inside Pt ent)(progn
	(foreach obj ss1
	(vla-Move (vla-Copy (vlax-ename->vla-object obj)) (vlax-3d-point p3) (vlax-3d-point pt))
	  )
      ))
    )
  ))
 (princ)
)
(defun getlstpoint (ss / ent1 lst_pt lst )
(setq lst_pt nil)
  (while (> (length ss) 1)
    (setq ent1 (car ss))
    (setq lst (apply 'append (mapcar '(lambda (x) (vla-inters ent1 x 0)) (cdr ss))))
    (setq lst_pt (append lst_pt lst))
    (setq ss (cdr ss))
    )
  lst_pt
)
(defun vla-inters (ent1 ent2 mode / lst1 lst2)
  (setq lst1 (vlax-invoke (vlax-ename->vla-object ent1) 'intersectwith (vlax-ename->vla-object ent2)
	       (cond
		 ((= mode 0) acextendnone)
		 ((= mode 1) acextendthisentity)
		 ((= mode 2) acextendotherentity)
		 ((= mode 3) acextendboth)
		 )))
  (repeat (/ (length lst1) 3)
    (setq lst2 (cons (list (car lst1) (cadr lst1) (caddr lst1)) lst2)
	  lst1 (cdddr lst1)
	  )
    )
  (reverse lst2)
  )

Áp dụng cho bài toán này oke, còn bài khác thì mình k chịu trách nhiệm nhé bạn ^^ 

<<

Bạn dùng lisp này đóng 2 đầu đoạn đường cho nhanh

(defun C:00 (/ ELAST LTS1 LTS2 OBJ1 OBJ2 OLMODE PNTC1 PNTC2 PNTD1 PNTD2)
  (defun 
>>

Bạn dùng lisp này đóng 2 đầu đoạn đường cho nhanh

(defun C:00 (/ ELAST LTS1 LTS2 OBJ1 OBJ2 OLMODE PNTC1 PNTC2 PNTD1 PNTD2)
  (defun *error* (msg)
    (if	Olmode
      (setvar 'osmode Olmode)
    )
    (if	(not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
      (princ (strcat "\nError: " msg))
    )
    (princ)
  )
  (setq Olmode (getvar "OSMODE"))
  (setvar "OSMODE" 0)

  (setq	Obj1
	 (car
	   (LM:SelectIf
	     "\nCh\U+1ECDn \U+0111\U+01B0\U+1EDDng th\U+1EE9 nh\U+1EA5t:  "
	     (lambda (x)
	       (member (cdr (assoc 0 (entget (car x))))
		       (list "LINE" "POLYLINE" "LWPOLYLINE" "ARC" "ELLIPSE" "SPLINE")
	       )
	     )
	     entsel
	     nil
	   )
	 )
  )
  (setq	Obj2
	 (car
	   (LM:SelectIf
	     "\nCh\U+1ECDn \U+0111\U+01B0\U+1EDDng th\U+1EE9 hai:  "
	     (lambda (x)
	       (member (cdr (assoc 0 (entget (car x))))
		       (list "LINE" "POLYLINE" "LWPOLYLINE" "ARC" "ELLIPSE" "SPLINE")
	       )
	     )
	     entsel
	     nil
	   )
	 )
  )
  (setq	kch
	 (LM:GetXWithDefault
	   getdist
	   "\nNh\U+1EADp kho\U+1EA3ng c\U+00E1ch l\U+1EDBn h\U+01A1n s\U+1EBD kh\U+00F4ng n\U+1ED1i"
	   '*kch*
	   5.0
	 )
  )
  (setq Elast (entlast))
  (if (and Obj1 Obj2 (/= Obj1 Obj2))
    (progn
      (setq PntD1 (vlax-curve-getStartPoint Obj1))
      (setq PntC1 (vlax-curve-getEndPoint Obj1))
      (setq PntD2 (vlax-curve-getStartPoint Obj2))
      (setq PntC2 (vlax-curve-getEndPoint Obj2))
      (if (< (distance PntD1 PntD2) (distance PntD1 PntC2))
	(progn
	  (if (< (distance PntD1 PntD2) kch)
	    (MakeLWPolyline (list PntD1 PntD2) nil nil nil nil nil nil)
	  )
	  (if (< (distance PntC1 PntC2) kch)
	    (MakeLWPolyline (list PntD1 PntD2) nil nil nil nil nil nil)
	  )
	)
	(progn
	  (if (< (distance PntD1 PntC2) kch)
	    (MakeLWPolyline (list PntD1 PntC2) nil nil nil nil nil nil)
	  )
	  (if (< (distance PntC1 PntD2) kch)
	    (MakeLWPolyline (list PntC1 PntD2) nil nil nil nil nil nil)
	  )
	)
      )
    )
  )
  (setq Lts1 (GetNewEnts Elast))
  (setq Lts2 (append Lts1 (list Obj1 Obj2)))
  (if (member "LINE"
	      (list (cdr (assoc 0 (entget Obj1))) (cdr (assoc 0 (entget Obj2))))
      )
    (command "_.pedit" "_m" (CV:List-to-ss Lts2) "" "Y" "_j" "" "")
    (command "_.pedit" "_m" (CV:List-to-ss Lts2) "" "_j" "" "")
  )
  (setvar "OSMODE" Olmode)
  (princ)
)
(defun GetNewEnts (ename / new)
  (while (setq ename (entnext ename))
    (if	(entget ename)
      (setq new (cons ename new))
    )
  )
  new
)

(defun MakeLWPolyline (listpoint closed Linetype LTScale Layer Color xdata / Lst)
  (setq	Lst (list (cons 0 "LWPOLYLINE")
		  (cons 100 "AcDbEntity")
		  (cons	8
			(if Layer
			  Layer
			  (getvar "Clayer")
			)
		  )
		  (cons	6
			(if Linetype
			  Linetype
			  "bylayer"
			)
		  )
		  (cons	48
			(if LTScale
			  LTScale
			  1
			)
		  )
		  (cons	62
			(if Color
			  Color
			  256
			)
		  )
		  (cons 100 "AcDbPolyline")
		  (cons 90 (length listpoint))
		  (cons	70
			(if closed
			  1
			  0
			)
		  )
	    )
  )
  (foreach PP listpoint (setq Lst (append Lst (list (cons 10 PP)))))
  (if xdata
    (setq Lst (append lst (list (cons -3 (list xdata)))))
  )
  (entmakex Lst)
)
(defun CV:List-to-ss (lst / ss)
  (setq ss (ssadd))
  (foreach item	lst
    (or	(= (type item) 'Ename)
	(setq item (vlax-vla-object->ename item))
    )
    (setq ss (ssadd item ss))
  )
  ss
)

(defun LM:SelectIf (msg pred func keyw / sel)
  (setq pred (eval pred))
  (while
    (progn
      (setvar 'ERRNO 0)
      (if keyw
	(apply 'initget keyw)
      )
      (setq sel (func msg))
      (cond
	((= 7 (getvar 'ERRNO))
	 (princ
	   "\nB\U+1EA1n ch\U+1ECDn sai r\U+1ED3i! H\U+00E3y ch\U+1ECDn l\U+1EA1i."
	 )
	)
	((eq 'STR (type sel))
	 nil
	)
	((vl-consp sel)
	 (if (and pred (not (pred sel)))
	   (princ "")
	 )
	)
      )
    )
  )
  sel
)
(defun LM:GetXWithDefault (_function _prompt _symbol _default / _toString)
  ;; © Lee Mac 2010

  (setq	_toString
	 (lambda (x)
	   (cond
	     ((eq getangle _function) (angtos x))
	     ((eq 'REAL (type x)) (rtos x))
	     ((eq 'INT (type x)) (itoa x))
	     (x)
	   )
	 )
  )

  (set _symbol
       (
	(lambda	(input)
	  (if (or (not input) (eq "" input))
	    (eval _symbol)
	    input
	  )
	)
	 (_function (strcat _prompt
			    "<"
			    (_toString (set _symbol
					    (cond ((eval _symbol))
						  (_default)
					    )
				       )
			    )
			    "> : "
		    )
	 )
       )
  )
)
 ;|«Visual LISP© Format Options»
(200 2 60 2 nil "end of " 80 9 0 0 0 T T T T)
;*** DO NOT add text below the comment! ***|;

18 phút trước, monavamonava đã nói:

Cho em hỏi thêm chút. Lisp...

>>

18 phút trước, monavamonava đã nói:

Cho em hỏi thêm chút. Lisp này có giới hạn phiên bản autocad hay j  nửa không nhỉ.

Em xài trên cad 2005 nó báo lỗi ; error: no function definition: ACET-SS-TO-LIST. Có thể khắc phục nó được không?

Do k có Expresstool, bạn dùng bản này 

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

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

   (> (abs Defl) 4)
 )
)
;;;;;;*************
(defun C:te (/ ss1 p1 p2 p3 ss t1 lst pt)
  (vl-load-com)
  (Prompt "\nQu\U+00E9t v\U+00F9ng ch\U+1EE9a c\U+00E1c \U+0111i\U+1EC3m giao")
  (setq ss (CV:ss-to-list (ssget (list (cons 0 "LINE,LWPOLYLINE"))) nil))
  (if (and ss) (progn			
  (setq t1 0)
  (mapcar '(lambda (x) (if (> (vlax-curve-getendparam x) t1) (progn (setq ent x) (setq t1 (vlax-curve-getendparam x)))) ) ss)
  (setq ss (vl-remove ent ss))
  (setq ss (vl-sort ss '(lambda (x y) (< (vla-get-length (vlax-ename->vla-object x)) (vla-get-length (vlax-ename->vla-object y))))))
  (setq ss1 (list (car ss)) 
	ss (cdr ss))
  (setq p1 (vlax-curve-getpointatparam (car ss1) (vlax-curve-getstartparam (car ss1)))
	p2 (vlax-curve-getpointatparam (car ss1) (+ 1 (vlax-curve-getstartparam (car ss1)) ))
	p3 (list (/ (+ (car p1) (car p2)) 2) (/ (+ (cadr p1) (cadr p2)) 2) (/ (+ (caddr p1) (caddr p2)) 2)))
  (setq lst (getlstpoint ss))
  (foreach pt lst
    (if (@Inside Pt ent)(progn
	(foreach obj ss1
	(vla-Move (vla-Copy (vlax-ename->vla-object obj)) (vlax-3d-point p3) (vlax-3d-point pt))
	  )
      ))
    )
  ))
 (princ)
)
(defun getlstpoint (ss / ent1 lst_pt lst )
(setq lst_pt nil)
  (while (> (length ss) 1)
    (setq ent1 (car ss))
    (setq lst (apply 'append (mapcar '(lambda (x) (vla-inters ent1 x 0)) (cdr ss))))
    (setq lst_pt (append lst_pt lst))
    (setq ss (cdr ss))
    )
  lst_pt
)
(defun vla-inters (ent1 ent2 mode / lst1 lst2)
  (setq lst1 (vlax-invoke (vlax-ename->vla-object ent1) 'intersectwith (vlax-ename->vla-object ent2)
	       (cond
		 ((= mode 0) acextendnone)
		 ((= mode 1) acextendthisentity)
		 ((= mode 2) acextendotherentity)
		 ((= mode 3) acextendboth)
		 )))
  (repeat (/ (length lst1) 3)
    (setq lst2 (cons (list (car lst1) (cadr lst1) (caddr lst1)) lst2)
	  lst1 (cdddr lst1)
	  )
    )
  (reverse lst2)
  )
(defun CV:ss-to-list (ss vla / n e l)
  (if ss (progn
 (setq n (sslength ss))
 (while (setq e (ssname ss (setq n (1- n))))
(setq l (cons (if vla (vlax-ename->vla-object e) e) l))
 )
 ) )
)

 

<<

Mình k biết nó thực hiện như thế nào, chỉ thấy những chỗ đáng ra đóng ngoặc thì nó lại thành mở ngoặc, sửa lại cho bạn cho đúng cú pháp thôi ^^

(defun C:CYTROID ()
(princ "\nDAY LA CHUONG TRINH VE DUONG CONG CYCLOID VA TROCHOID")
(setq echo (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setvar "osmode" 4287)
(setq  Osm  (getvar "osmode")
	Ort  (getvar "orthomode")
	org  (getpoint "\nNhap goc cua he truc toa do:...
>>

Mình k biết nó thực hiện như thế nào, chỉ thấy những chỗ đáng ra đóng ngoặc thì nó lại thành mở ngoặc, sửa lại cho bạn cho đúng cú pháp thôi ^^

(defun C:CYTROID ()
(princ "\nDAY LA CHUONG TRINH VE DUONG CONG CYCLOID VA TROCHOID")
(setq echo (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setvar "osmode" 4287)
(setq  Osm  (getvar "osmode")
	Ort  (getvar "orthomode")
	org  (getpoint "\nNhap goc cua he truc toa do: ")
)
(command "UCS" "N" org)
(setq an  (getdist "\nNhap goc quay cua he truc toa do quanh truc Z <0>: " )) 
(command "UCS" "Z" an)
(setq a  (getdist "\nNhap ban kinh duong tron lan: ")
	P1 (polar '(0 0) (/  pi  2)  a))
(initget 1)
(setq ang  (getint "\nNhap goc quay cua ban kinh duong tron lan: ")
	goc 0.0)
(setvar "orthomode" 0)
(command "undo" "be")
(command "Viewres" "" 5000)
(command "color" 1)
(setvar "osmode" 0)
(defun dtr (x) (* x (/ pi 180)))
(defun CYCLO ()
    (command "spline")
(repeat Ang 
(setq  X  (* a (- (/  (* pi goc) 180) (sin (dtr goc))))
		Y  (* a (- 1(cos (dtr goc))))
		goc (+ goc 1)
	Toado (list X Y)
)
(command Toado)
)    
(setq  X  (* a       (- (/  (* pi goc) 180) (sin (dtr goc)))))   
(setq  Y  (* a
       (- 1
  (cos (dtr goc))
)))    
(setq Toado (list X Y))
(command Toado)
(command "" "" "")
(Command "Circle" P1 a)
(command  "line" '(0 0) P1 "")
 );K?t thúc defun1
(defun TROCHO ()
(setq b    (getdist 
                               "\nNhap khoang cach diem bat dau tao duong trochoid toi tam duong tron lan: ")
           P2   (polar P1 (- (* 0.5 pi)) B)
)

    (command "spline")
   (repeat Ang
      (setq  X  (- (* a (/  (* pi goc) 180)
)
(* b
(sin (dtr goc)))))

        (setq  Y  (- a
(* b
(cos (dtr goc) )
)))     
(setq goc (+ goc 1))
(setq Toado (list X Y))
(command Toado)
)    
(setq  X  (- (* a
(/  (* pi goc) 180)
)
(* b
(sin (dtr goc))
)))    
(setq  Y  (- a
(* b
 (cos (dtr goc))
)))   
(setq Toado (list X Y))
(command Toado)
(command "" "" "")
(Command "Circle" P1 a)
(command  "line" P1 P2 "")
 );K?t thúc defun2
(initget 1 "Cycloid Trochoid eXit")
(Setq CT (getkword "\nNhap mot tuy chon : "))
(Cond
    ((= "Cycloid" CT) (CYCLO))
((= "Trochoid" CT) (TROCHO))
((= "eXit" CT)
     (princ "\nThoat chuong trinh")
)
)  
(command "Regen")
 (command "Zoom" "all")
(command "ucs" "")
(command "undo" "e")
(setvar "osmode" osm)
(setvar "orthomode" ort)
(setvar "cmdecho" echo)
(princ)
)

Mình đã tìm lisp này nhưng không thấy. Mình có tìm được tài liệu của BKDN hướng dẫn nhưng mình ko biết về viết lisp, copy vào thì ko dùng đc.

Nhờ các bạn trên cadviet viết giúp lisp này. hoặc xem lại hộ mình cái lisp này.

Mình cảm ơn!

(defun C:CYTROID ()
 (princ
         "\nDAY LA CHUONG TRINH VE DUONG CONG CYCLOID VA TROCHOID"
(  
(setq echo (getvar "cmdecho"))
(setvar "cmdecho"...
>>

Mình đã tìm lisp này nhưng không thấy. Mình có tìm được tài liệu của BKDN hướng dẫn nhưng mình ko biết về viết lisp, copy vào thì ko dùng đc.

Nhờ các bạn trên cadviet viết giúp lisp này. hoặc xem lại hộ mình cái lisp này.

Mình cảm ơn!

(defun C:CYTROID ()
 (princ
         "\nDAY LA CHUONG TRINH VE DUONG CONG CYCLOID VA TROCHOID"
(  
(setq echo (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setvar "osmode" 4287)
(setq  Osm  (getvar "osmode")
Ort  (getvar "orthomode")
(  
(setq org  (getpoint "\nNhap goc cua he truc toa do: ")
(
(command "UCS" "N" org)
(setq an  (getdist "\nNhap goc quay cua he truc toa do quanh truc Z <0>: " )
(  
(command "UCS" "Z" an)
(setq a  (getdist "\nNhap ban kinh duong tron lan: ")
(
(setq P1 (polar '(0 0) (/  pi  2)  a)
(
(initget 1)
(setq ang  (getint "\nNhap goc quay cua ban kinh duong tron lan: ")
(
(setq goc 0.0)
(setvar "orthomode" 0)
(command "undo" "be")
(command "Viewres" "" 5000)
(command "color" 1)
(setvar "osmode" 0)
(defun dtr (x) (* x (/ pi 180)))
(defun CYCLO ()
    (command "spline")
(repeat Ang
      (setq  X  (* a
(- (/  (* pi goc) 180)
    (sin (dtr goc))
(
(       
(       
(setq  Y  (* a
(- 1
   (cos (dtr goc))
(
(       
(       
(setq goc (+ goc 1))
(setq Toado (list X Y))
(command Toado)
(     
(setq  X  (* a
       (- (/  (* pi goc) 180)
  (sin (dtr goc))
(        
(     
(     
(setq  Y  (* a
       (- 1
  (cos (dtr goc))
(        
(     
(     
(setq Toado (list X Y))
(command Toado)
(command "" "" "")
(Command "Circle" P1 a)
(command  "line" '(0 0) P1 "")
 );K?t thúc defun1
(defun TROCHO ()
(setq b    (getdist 
                               "\nNhap khoang cach diem bat dau tao duong trochoid toi tam duong tron lan: ")
           P2   (polar P1 (- (* 0.5 pi)) B)
(      
    (command "spline")
   (repeat Ang
      (setq  X  (- (* a
(/  (* pi goc) 180)
(
(* b
(sin (dtr goc)
(
(
(
        (setq  Y  (- a
(* b
(cos (dtr goc) )
(
(       
(       
(setq goc (+ goc 1))
(setq Toado (list X Y))
(command Toado)
(     
(setq  X  (- (* a
(/  (* pi goc) 180)
(
(* b
(sin (dtr goc))
(
(
(     
(setq  Y  (- a
(* b
 (cos (dtr goc))
(
(    
(     
(setq Toado (list X Y))
(command Toado)
(command "" "" "")
(Command "Circle" P1 a)
(command  "line" P1 P2 "")
 );K?t thúc defun2
(initget 1 "Cycloid Trochoid eXit")
(Setq CT (getkword "\nNhap mot tuy chon : ")
(
(Cond
    ((= "Cycloid" CT) (CYCLO))
((= "Trochoid" CT) (TROCHO))
((= "eXit" CT)
     (princ "\nThoat chuong trinh")
(
(  
(command "Regen")
 (command "Zoom" "all")
(command "ucs" "")
(command "undo" "e")
(setvar "osmode" osm)
(setvar "orthomode" ort)
(setvar "cmdecho" echo)
(princ)
); Ket thuc chuong trinh

Bạn dùng Lisp này cho Text và Mtext:

(defun c:tt  (/ els pos ss str)
 (and (setq ss (ssget '((0 ....
>>

Bạn dùng Lisp này cho Text và Mtext:

(defun c:tt  (/ els pos ss str)
 (and (setq ss (ssget '((0 . "*TEXT"))))
      (foreach x  (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
       (setq els (entget x))
       (setq str (cdr (assoc 1 els)))
       (if (vl-string-search (chr 40) (strcase str))
        (while (setq pos (vl-string-search (chr 40) (strcase str)))
         (setq str (strcat (substr str 1 pos) (substr str (+ 2 pos)))))
        (setq str (strcat (chr 40) str)))
       (entmod (subst (cons 1 str) (assoc 1 els) els))
       (if (vl-string-search (chr 41) (strcase str))
        (while (setq pos (vl-string-search (chr 41) (strcase str)))
         (setq str (strcat (substr str 1 pos) (substr str (+ 2 pos)))))
        (setq str (strcat str (chr 41))))
       (entmod (subst (cons 1 str) (assoc 1 els) els))))
 (princ))

Cho mình hỏi lisp này dùng như thế nào vậy bạn?cảm ơn nhiều!

<<

Download lisp

Filename: 405278_tt%C2%A0.lsp

Tôi sử dụng lisp dưới đây để tính góc của tiếp tuyến với curve tại điểm giữa của curve, nhưng trong file cad đính kèm thì nó...

>>

Tôi sử dụng lisp dưới đây để tính góc của tiếp tuyến với curve tại điểm giữa của curve, nhưng trong file cad đính kèm thì nó bị lỗi (đường màu xanh). Tôi biết lỗi ở hàm (vlax-curve-getParamAtPoint obj cen) nhưng không hiểu vì sao mà lỗi, và cách khắc phục. Ai biết xin chỉ giùm.

http://www.cadviet.c...29_loi_vlax.dwg

(defun C:HA( / obj len cen goc)
(setq obj (vlax-ename->vla-object (car (entsel))))
(setq len (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj)))
(setq cen (vlax-curve-getPointAtDist obj (/ len 2)))
(setq goc (angle '(0 0 0) (vlax-curve-getFirstDeriv obj (vlax-curve-getParamAtPoint obj cen)))))

Lỗi này do sai số phát sinh khi gọi hàm vlax-curve-getPointAtDist.

Do hàm (vlax-curve-getParamAtPoint curve pt) yêu cầu điểm pt phải thuộc Curve.

Nhưng do sai số của hàm (vlax-curve-getPointAtDist curve (/ len 2)) nên điểm trả về có thể thuộc hoặc không thuộc Curve.

Tùy từng trường hợp cụ thể, nếu sai số này đủ lớn thì CAD báo lỗi.

 

Cách khắc phục :

1.) như Ketxu đề nghị : (vlax-curve-getClosestPointToProjection obj cen (list 0 0 1))

hoặc chỉ đơn giản là lấy điểm gần nhất trên curve : (vlax-curve-getClosestPointTo obj cen)

 

2.) Hoặc cách tránh lỗi sai số khi gọi hàm vlax-curve-getPointAtDist là ... không dùng nó nữa. :o

Cad cung cấp 1 hàm khác để lấy tham số param của Curve là : (vlax-curve-getParamAtDist obj dis)

(Dĩ nhiên dis phải nhỏ hơn hoặc bằng chiều dài của curve)

Do đó lisp trên có thể viết lại như sau :

(defun C:HA1( / obj len goc)
 (setq obj (vlax-ename->vla-object (car (entsel))))
 (setq len (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj)) )
 (setq goc (angle '(0 0 0) (vlax-curve-getFirstDeriv obj (vlax-curve-getParamAtDist obj (/ len 2))))))

<<

sử như này tôi test thử ok. Nếu bạn cahỵ ko được chứng tỏ lệnh cũ của bạn lỗi.

;;;
(defun c:rhg () (prompt "\n Rai ho ga:") (C:nRAIHOGA))
;;;;
(defun c:cgp () (prompt "\n Chuyen ga chinh thanh ga phu:") (C:NCP))
;;;;
(defun c:capnhat () (prompt "\n Cap nhat thong tin ho ga:") (C:HUPD))
;;;;
(defun c:DMB () (prompt "\n Dien thong tin mat bang ho ga:") (C:NDMB))
;;;;
(defun...
>>

sử như này tôi test thử ok. Nếu bạn cahỵ ko được chứng tỏ lệnh cũ của bạn lỗi.

;;;
(defun c:rhg () (prompt "\n Rai ho ga:") (C:nRAIHOGA))
;;;;
(defun c:cgp () (prompt "\n Chuyen ga chinh thanh ga phu:") (C:NCP))
;;;;
(defun c:capnhat () (prompt "\n Cap nhat thong tin ho ga:") (C:HUPD))
;;;;
(defun c:DMB () (prompt "\n Dien thong tin mat bang ho ga:") (C:NDMB))
;;;;
(defun c:DMB0 () (prompt "\n Dien thong tin mat bang ho ga - ko dien ga:") (C:HDMB))
;;;;
(defun c:tk () (prompt "\n Thiet ke do doc cho 1 doan cong:") (C:HDSG))
;;;
(defun c:tkday () (prompt "\n Thiet ke duong day cong:") (C:HRL))
;;;;
(defun c:caoga () (prompt "\n Dien cao do ga:") (C:HCOTE))
;;;;
(defun c:tke () (prompt "\n Thong ke ho ga - cong:") (C:HTHGKE))
;;;;
(defun c:bb () (prompt "\n Khai mau bang trac doc:") (C:HSETUP))
;;;;;

Đây là file tôi viết thử các lệnh theo tên cũ làm cho các lệnh theo tên cũ chạy được.

;;;
(defun c:rhg () (prompt "\n Rai ho ga:") (C:nRAIHOGA))
;;;;
(defun c:cgp () (prompt "\n Chuyen ga chinh thanh ga phu:") (C:NCP))
;;;;
(defun c:capnhat () (prompt "\n Cap nhat thong tin ho ga:") (C:HUPD))
;;;;
(defun c:DMB () (prompt "\n Dien thong tin mat bang ho ga:") (C:NDMB))
;;;;
(defun c:DMB0 () (prompt "\n Dien thong tin mat bang ho ga - ko dien ga:") (C:HDMB))
;;;;
(defun c:tk () (prompt "\n Thiet ke do doc cho 1 doan cong:") (C:HDSG))
;;;
(defun c:tkday () (prompt "\n Thiet ke duong day cong:") (C:HRL))
;;;;
(defun c:caoga () (prompt "\n Dien cao do ga:") (C:HCOTE))
;;;;
(defun c:tke () (prompt "\n Thong ke ho ga - cong:") (C:HTHGKE))
;;;;
(defun c:bb () (prompt "\n Khai mau bang trac doc:") (C:HSETUP))
;;;;;

;;;
(defun c:nRAIHOGA ()
(alert "nRAIHOGA")
)
;;;;
(defun c:NCP ()
(alert "nNCP")
)
;;;;
(defun c:HUPD ()
(alert "nHUPD")
)
;;;;
(defun c:NDMB ()
(alert "NDMB")
)
;;;;
(defun c:HDMB ()
(alert "HDMB")
)
;;;;
(defun c:HDSG ()
(alert "HDSG")
)
;;;
(defun c:HRL ()
(alert "HRL")
)
;;;;
(defun c:HCOTE ()
(alert "HCOTE")
)
;;;;
(defun c:HTHGKE ()
(alert "HTHGKE")
)
;;;;
(defun c:HSETUP ()
(alert "HSETUP")
)
;;;;;

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

Chào các anh, em gặp rắc rối...

>>

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

Chào các anh, em gặp rắc rối như sau em muốn lọc tên chủ hộ với địa chỉ ra làm hai layer khác nhau, bình thường thì địa chỉ có tên bắt đầu bằng số nên em có thể dùng lisp lọc layer để tách, nhưng có nhưng địa chỉ tên lại bắt đầu bằng chữ nên không sử dụng lisp được, mong các anh viết giúp em lisp lọc địa chỉ ra ạ em xin cảm ơn đây là bản cad và lisp em sử dụng

 

lisp_loc_layer.lsp

TEXXT DU LIEU11.dwg

(defun c:doan(/ ss ent1 ent2 cmd )	     
  (or (setq ss (acet-ss-to-list (ssget '((0 . "TEXT") )))) (exit))
  (setq ss (vl-sort ss '(lambda (x y) (cond ((=  (car (cdr (Assoc 11 (entget x))))    (car (cdr (Assoc 11 (entget y)))))
					     (> (cadr (cdr (Assoc 11 (entget x)))) (cadr (cdr (Assoc 11 (entget y))))))
					    ((< (car (cdr (Assoc 11 (entget x)))) (car (cdr (Assoc 11 (entget y))))))) )))
  (command "UNDO" "be")
    (while ss
      (setq ent1 (car ss)
	    ent2 (cadr ss)
	    ss (cdr ss))
      (if (and (equal (caddr (assoc 11 (entget ent1))) (caddr (assoc 11 (entget ent2))) 0.7)
	       (equal (car (cdr (assoc 11 (entget ent1)))) (car (cdr (assoc 11 (entget ent2)))) 0.1)
	       ) (progn
		   (vla-put-layer (vlax-ename->vla-object ent1) "layer1")
		   (vla-put-layer (vlax-ename->vla-object ent2) "layer2")
		   (setq ss (cdr ss)))))
  (command "UNDO" "E")
  )

Đổi tên layer1 và layer2 thành tên 2 layer bạn muốn vào

<<

1 phút trước, Black_Cat_ đã nói:

em sửa mãi mà không chạy...

>>

1 phút trước, Black_Cat_ đã nói:

em sửa mãi mà không chạy được

(defun c:te(/ ss ent1 ent2 cmd )	     
  (or (setq ss (acet-ss-to-list (ssget '((0 . "TEXT") )))) (exit))
  (setq ss (vl-sort ss '(lambda (x y) (cond ((Equal  (car (cdr (Assoc 11 (entget x))))    (car (cdr (Assoc 11 (entget y)))) 0.1 )
					     (> (cadr (cdr (Assoc 11 (entget x)))) (cadr (cdr (Assoc 11 (entget y))))))
					    ((< (car (cdr (Assoc 11 (entget x)))) (car (cdr (Assoc 11 (entget y))))))) )))
  (command "UNDO" "be")
    (while ss
      (setq ent1 (car ss)
	    ent2 (cadr ss)
	    ss (cdr ss))
      (if (and ent2
	       (equal (- (caddr (assoc 11 (entget ent1))) (caddr (assoc 11 (entget ent2))) ) 1.8 0.1)
	       (equal (car (cdr (assoc 11 (entget ent1)))) (car (cdr (assoc 11 (entget ent2)))) 0.1)
	       ) (progn
		   (vla-put-layer (vlax-ename->vla-object ent1) "layer1")
		   (vla-put-layer (vlax-ename->vla-object ent2) "layer1")
		   (setq ss (cdr ss)))))
  (command "UNDO" "E")
  )

Đây bạn

<<

 

Đây bạn!

;Doan Van Ha - CADViet.com - Ngay 01-03-2012
;Muc dich: Ghi text chieu dai hoac dien tich...
>>

 

Đây bạn!

;Doan Van Ha - CADViet.com - Ngay 01-03-2012
;Muc dich: Ghi text chieu dai hoac dien tich vao giua doi tuong.
;----- Lay chieu dai
(defun C:HA1()
(command "undo" "be")
(vl-load-com)
(setq ent (car (entsel "\nChon Text chuan: ")))
(princ "\nChon cac duong thang de lay chieu dai...")
(setq ss (ssget '((0 . "LINE"))))
(setq objlst (mapcar 'vlax-ename->vla-object (setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))))
(setq i 0)
(repeat (length objlst)
  (setq obj (nth i objlst)
        	i (1+ i)
        	cd (vla-get-Length obj)
        	pg (vlax-curve-getPointAtDist obj (* cd 0.5)))
  (entmake (list (cons 0 "TEXT") (cons 10 pg) (assoc 7 (entget ent)) (assoc 40 (entget ent)) (cons 1 (rtos cd 2 0)))))
(command "undo" "end")
(princ))
;----- Lay dien tich
(defun C:HA2()
(command "undo" "be")
(vl-load-com)
(setq ent (car (entsel "\nChon Text chuan: ")))
(princ "\nChon cac hinh chu nhat de lay dien tich...")
(setq ss (ssget '((-4 . "<AND") (0 . "LWPOLYLINE") (-4 . "<OR") (90 . 4) (90 . 5) (-4 . "OR>") (-4 . "AND>"))))
(setq objlst (mapcar 'vlax-ename->vla-object (setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))))
(setq i 0)
(repeat (length objlst)
  (setq obj (nth i objlst)
        	i (1+ i)
        	dt (vla-get-Area obj)
        	pg (vlax-get (car (vlax-invoke (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) 'addregion (list obj))) 'Centroid))
  (entdel (entlast))
  (entmake (list (cons 0 "TEXT") (cons 10 pg) (assoc 7 (entget ent)) (assoc 40 (entget ent)) (cons 1 (rtos dt 2 0)))))
(command "undo" "end")
(princ))

a hà có thể sửa giúp e giá trị trên làm tròn tới m dc ko.vd 2345 ==> 2.4

mong a giúp đỡ

<<

Bạn thử cái này xem:

(defun c:msw (/ ob)

(initget 1 "16 20 24 30 MSWC(16) MSWC(20) MSWC(24)...

>>

Bạn thử cái này xem:

(defun c:msw (/ ob)

(initget 1 "16 20 24 30 MSWC(16) MSWC(20) MSWC(24) MSWC(30)")

(setq ob (getkword "\nChon loai : "))

(cond ((wcmatch ob "*16*") (screw_plug_16))

((wcmatch ob "*20*") (screw_plug_20))

((wcmatch ob "*24*") (screw_plug_24))

((wcmatch ob "*30*") (screw_plug_30)))

(princ))

Mình đã thử và thành công. Rất hợp ý mình, thanks bạn rất nhiều :)

<<

Download lisp

Filename: 408806_msw.lsp

28 phút trước, mr.thanh2610 đã nói:

Mình không hiểu code lắm...

>>

28 phút trước, mr.thanh2610 đã nói:

Mình không hiểu code lắm nên hỏi anh em để chỉnh đơn vị bên lisp là độ trùng với đơn vị bên bản vẽ ấy mà, chứ mỗi lần chỉnh góc là phải quy đổi

Sửa lại cho bạn nhập góc theo độ nhé:

(defun c:SF(/ p dt ans ten sc dt angrad)
(setvar "cmdecho" 0)
(initget "B B1 B2 BK G GD GD1 GL GL1 GL2 D D1 C K N N1 TO GO GO1")
(setq ans (getkword "\n Chon kieu hatch < B/B1/B2/BK/G/GD/GD1/GL/GL1/GL2/D/D1/C/K/N/N1/TO/GO/GO1 > : "))
(or (and ang (or (= (type ang) 'int) (= (type ang) 'real))) (setq ang 0.00))
(setq ang (cond ((getreal (strcat "\nNhap goc theo do <" (rtos ang 2 2) ">: "))) (ang)))
(setq angrad (*(/ ang 180) pi))
(if (= ans "B") 
(progn 
(setq ten "AR-CONC" sc 20.0
ten2 "ANSI32" sc2 200.0) 
)
)
(if (= ans "B1") 
(progn
(setq ten "AR-CONC" sc 20.0)
)
)
(if (= ans "B2") 
(progn
(setq ten "GRAVEL" sc 100.0)
)
)
(if (= ans "BK") 
(progn
(setq ten "SOLID" sc 200.0)
)
)
(if (= ans "G") 
(progn
(setq ten "ANSI31" sc 400.0)
)
)
(if (= ans "GD") 
(progn
(setq ten "AR-B816" sc 10.0)
)
)
(if (= ans "GD1") 
(progn
(setq ten "FLGSTONE" sc 500.0)
)
)
(if (= ans "GL") 
(progn
(setq ten "NET" sc 1500.0)
)
)
(if (= ans "GL1") 
(progn
(setq ten "ANGLE" sc 700.0)
)
)
(if (= ans "GL2") 
(progn
(setq ten "AR-HBONE" sc 20.0)
)
)
(if (= ans "D") 
(progn
(setq ten "HOUND" sc 500.0)
)
)
(if (= ans "D1") 
(progn
(setq ten "EARTH" sc 500.0)
)
)
(if (= ans "C") 
(progn
(setq ten "AR-SAND" sc 20.0)
)
)
(if (= ans "K") 
(progn
(setq ten "AR-RROOF" sc 500.0)
)
)
(if (= ans "N") 
(progn
(setq ten "AR-RSHKE" sc 30.0)
)
)
(if (= ans "N1") 
(progn
(setq ten "SPANTILE" sc 400.0)
)
)
(if (= ans "TO") 
(progn
(setq ten "ANSI32" sc 200.0)
)
)
(if (= ans "GO") 
(progn
(setq ten "WOOD8" sc 700.0)
)
)
(if (= ans "GO1") 
(progn
(setq ten "WOOD2" sc 500.0)
)
)
 (setvar "hpname" ten)
 (setvar "hpscale" sc)
 (setvar "hpang" angrad)

(initdia)
(command "hatch")
(while (< 0 (getvar "CMDACTIVE"))
(command pause)
) 
(princ)
)

 

<<

2 giờ trước, mr.thanh2610 đã nói:

Cảm ơn bạn nhiều...

>>

2 giờ trước, mr.thanh2610 đã nói:

Cảm ơn bạn nhiều nhé....

(defun c:SF(/ en1 list1 i)
  (setq en1  (entlast)
	list1 '(("B"   ("ANSI32"   200  0.0) ("AR-CONC" 20 0.0))
		("B1"  ("AR-CONC"   20  0.0))
		("B2"  ("GRAVEL"   100  0.0))
		("BK"  ("SOLID"    200  0.0))
		("G"   ("ANSI31"   400  0.0))
		("GD"  ("AR-B816"   10  0.0))
		("GD1" ("FLGSTONE" 500  0.0))
		("GL"  ("NET"     1500  0.0))
		("GL1" ("ANGLE"    400  0.0))
		("GL2" ("AR-HBONE"  20  0.0))
		("D"   ("HOUND"    500 45.0))
		("D1"  ("EARTH"    500 45.0))
		("C"   ("AR-SAND"   20  0.0))
		("K"   ("AR-RROOF" 500 45.0))
		("N"   ("AR-RSHKE"  30  0.0))
		("N1"  ("SPANTILE" 400  0.0))
		("TO"  ("ANSI32"   200 45.0))
		("GO"  ("WOOD8"    700  0.0))
		("GO1" ("WOOD2" 500 0.0))
		
		))
	
  (setvar "cmdecho" 0)
  (initget (apply 'strcat (mapcar '(lambda(x) (strcat (car x) " ")) list1)))
  (if (setq i (vl-position
		(getkword (strcat "\n Chon kieu hatch < "
				  (vl-string-right-trim "/" (apply 'strcat (mapcar '(lambda(x) (strcat (car x) "/")) list1)))
				  " > : "))
		(mapcar 'car list1)))
    (progn
      (mapcar 'setvar '(hpname hpscale hpang)
	      (list (caar (setq i (cdr (nth i list1))))
		    (cadar i)
		    (*(/ (caddar i) 180) pi)))
      (initdia)
      (command "hatch")
      (while (< 0 (getvar "CMDACTIVE"))
	(command pause))
      (if (/= en1 (setq en1 (entlast)))
	(while (setq i (cdr i))
	  (entmakex
	    (mapcar '(lambda(x)
		       (cond ((eq (car x) 2) (cons 2 (caar i)))
			     ((eq (car x) 41) (cons 41 (cadar i)))
			     ((eq (car x) 52) (cons 52 (*(/(caddar i)180)pi)))
			     (T x)))
		    (entget en1)))
	  (setq i (cdr i))))))
  (princ))

Mình sửa lại cho bạn theo phiên bản gốc nè. Bạn có thể bổ sung hay thêm bớt các kiểu tùy ý và dễ sửa hơn.

(có thể chồng nhiều loại hatch như kiểu bêton)

 

Nếu bạn sửa (command "hatch") Thành  (command "-hatch")

Thì nó mặc định là pick điểm. Còn nhấn S sẽ là select.

 

 

 

<<

Thử lisp này xem

(defun c:test2(/ s1 s2)
  (Princ "/nChon text nguon:")
  (setq s1 (acet-ss-to-list (ssget '((0 . "TEXT")))))
  (Princ "/nChon text dich: ")
  (setq s2 (acet-ss-to-list (ssget '((0 . "TEXT")))))
  (or (and s1 s2) (exit))
  (mapcar '(lambda(a b)
	     (vla-put-textstring (cdr b) (cdr a)))
	  (vl-sort
	    (mapcar '(lambda(x / en)
		       (cons (cdr (assoc 10 (setq en (entget x))))
			    ...
>>

Thử lisp này xem

(defun c:test2(/ s1 s2)
  (Princ "/nChon text nguon:")
  (setq s1 (acet-ss-to-list (ssget '((0 . "TEXT")))))
  (Princ "/nChon text dich: ")
  (setq s2 (acet-ss-to-list (ssget '((0 . "TEXT")))))
  (or (and s1 s2) (exit))
  (mapcar '(lambda(a b)
	     (vla-put-textstring (cdr b) (cdr a)))
	  (vl-sort
	    (mapcar '(lambda(x / en)
		       (cons (cdr (assoc 10 (setq en (entget x))))
			     (cdr (assoc 1 en)))) s1)
	    '(lambda (x y) (if (equal (cadar x) (cadar y) 1.)
			     (> (caar x) (caar y))
			     (< (cadar x) (cadar y)))))
	  (vl-sort
	    (mapcar '(lambda(x)
		       (cons (cdr (assoc 11 (entget x)))
			     (vlax-ename->vla-object x))) s2)
	    '(lambda (x y) (if (equal (cadar x) (cadar y) 1.)
			     (> (caar x) (caar y))
			     (> (cadar x) (cadar y)))))))