Jump to content
InfoFile
Tác giả: trumlenmang
Bài viết gốc: 285050
Tên lệnh: mrlayout
Giúp hoàn thiện lisp đổi tên layout.
Em mới tìm một đoạn code lisp, em muốn chỉnh sửa để theo ý nhưng không được kết quả, các bác giúp em với. Em bị vấp ở đoạn code bên dưới nên lisp không chạy ra kết quả là đổi tên layout bằng text được chọn ở vùng quét:
(setq ENT1 (ssget "_C" PE1 PE2))
(command "layout" "r" "" ENT1)

(DEFUN C:MRLayout (/ PE1 PE2 ENT1 OCM c LLOUT)
(SETQ OCM (GETVAR "CMDECHO"))(SETVAR "CMDECHO" 0)
(Prompt "Select...
>>
Em mới tìm một đoạn code lisp, em muốn chỉnh sửa để theo ý nhưng không được kết quả, các bác giúp em với. Em bị vấp ở đoạn code bên dưới nên lisp không chạy ra kết quả là đổi tên layout bằng text được chọn ở vùng quét:
(setq ENT1 (ssget "_C" PE1 PE2))
(command "layout" "r" "" ENT1)

(DEFUN C:MRLayout (/ PE1 PE2 ENT1 OCM c LLOUT)
(SETQ OCM (GETVAR "CMDECHO"))(SETVAR "CMDECHO" 0)
(Prompt "Select Objects text: ")
(setq PE1 (GETPOINT "\nGoc tren ben trai :") PE2 (GETCORNER PE1 "\nGoc duoi ben phai :"))
(SETQ c (getint "\nThe number of layout to issued :"))
(SETQ LLOUT (LENGTH (LAYOUTLIST)))
(WHILE (< c LLOUT)
(COMMAND "LAYOUT" "SET" (NTH c (LAYOUTLIST)))
(setq ENT1 (ssget "_C" PE1 PE2))
(command "layout" "r" "" ENT1)
(COMMAND "_.ZOOM" "E" "_.ZOOM" "0.95X" )
(SETQ c(1+ c)))
(IF (= c LLOUT)(COMMAND "LAYOUT" "SET" (NTH 0 (LAYOUTLIST))))
(SETVAR "CMDECHO" OCM)(PRINC))

<<

Filename: 285050_mrlayout.lsp
Tác giả: gia_bach
Bài viết gốc: 285109
Tên lệnh: mrlayout
Giúp hoàn thiện lisp đổi tên layout.

Đại loại nó là thế này (???):

(defun c:mrlayout (/ i laylst pe1 pe2 ss txt)
  (setq pe1 (getpoint "\ngoc tren ben trai :")
	pe2 (getcorner pe1 "\ngoc duoi ben phai :")
	i 0 layLst (layoutlist) )
  (while (< i (length layLst))
    (command "layout" "set" (nth i layLst))
    (if (setq ss (ssget "_c" pe1 pe2 (list(cons 0 "text"))))
      (progn
	(setq txt (cdr (assoc 1 (entget (ssname ss 0)))))
	(if (snvalid txt)
	  (command "layout" "r" ""...
>>

Đại loại nó là thế này (???):

(defun c:mrlayout (/ i laylst pe1 pe2 ss txt)
  (setq pe1 (getpoint "\ngoc tren ben trai :")
	pe2 (getcorner pe1 "\ngoc duoi ben phai :")
	i 0 layLst (layoutlist) )
  (while (< i (length layLst))
    (command "layout" "set" (nth i layLst))
    (if (setq ss (ssget "_c" pe1 pe2 (list(cons 0 "text"))))
      (progn
	(setq txt (cdr (assoc 1 (entget (ssname ss 0)))))
	(if (snvalid txt)
	  (command "layout" "r" "" txt)  )) )
    (setq i(1+ i)))
  (princ))

<<

Filename: 285109_mrlayout.lsp
Tác giả: Tep_Pi
Bài viết gốc: 284653
Tên lệnh: ob2wo wof wo2pl
[Yêu cầu] Nhờ viết lisp tạo nhanh wipeout

Ái dà! Nó còn 1 dòng lỗi nữa mà bạn không thông báo.
; error: bad function: #<SUBR @098d7b68 -lambda->
Thôi thì, đành lấy cái này vậy. Cũng chính là lisp đó, tôi down về rồi sửa gì để hết lỗi thì bây giờ quên mất. Bạn dùng nó nhé!

;;; OB2WO (gile) -Gilles Chanteau- 10/03/07
;;; UPDATE BY KETXU (04/04/2012)
;;; Creates a "Wipeout" from an object (circle,...
>>

Ái dà! Nó còn 1 dòng lỗi nữa mà bạn không thông báo.
; error: bad function: #<SUBR @098d7b68 -lambda->
Thôi thì, đành lấy cái này vậy. Cũng chính là lisp đó, tôi down về rồi sửa gì để hết lỗi thì bây giờ quên mất. Bạn dùng nó nhé!

;;; OB2WO (gile) -Gilles Chanteau- 10/03/07
;;; UPDATE BY KETXU (04/04/2012)
;;; Creates a "Wipeout" from an object (circle, ellipse, or polyline with arcs)
;;; Works whatever the current ucs and object OCS
;http://xaydungit.vn/diendan/showthread.php?7784-Wipe-PLine-v%C3%A0-b%E1%BA%ADt-t%E1%BA%AFt-nhanh-Wipeout&p=14880779#post14880779
;----- Chuyen ss thanh cac Wipeout.
(defun c:ob2wo (/ ent lst nor ss)
  (vl-load-com)
  (if  (setq ss (ssget (list (cons 0 "CIRCLE,ELLIPSE,LWPOLYLINE"))))    
    (progn
      (vla-StartundoMark
    (vla-get-ActiveDocument (vlax-get-acad-object))
      )
        (initget "Yes No")      
        (setq ans (getkword "\nDelete source object?  <No>: "))      
      (foreach ent (ST:Ss->ListEnt ss)
        (setq lst (ent2ptlst ent))
        (setq nor (cdr (assoc 210 (entget ent))))    
        (makeWipeout lst nor)
        (if (or (not ans) (wcmatch (strcase ans) "YES"))(entdel ent))
      )
      (vla-EndundoMark
    (vla-get-ActiveDocument (vlax-get-acad-object))
      )
    )
  )
)
;----- Bat/Tat qua lai giua Wipeout va Pline
;; WOF (gile)
;; Toggles wipeout frames
(defun c:wof (/ elst)
  (cond
    ((and
        (setq elst (dictsearch (namedobjdict) "ACAD_WIPEOUT_VARS"))
        (ssget "x" '((0 . "WIPEOUT,INSERT")))
    )
    (entmod    (subst    (cons 70 (boole 6 (cdr (assoc 70 elst)) 1))    (assoc 70 elst)    elst))
    (vlax-for obj (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object)))
        (vla-update obj)
    )
  )
    (T (princ "\nHave no wipeout object !"))
    )
  (princ)
)
;----- Chuyen cac Wipeout thanh Pline
;; WO2PL (gile)
;; Re-creates a wipeout boundary (lwpolyline)
(defun c:wo2pl (/ ss n wo elst pts norm ans)
  (if (setq ss (ssget '((0 . "WIPEOUT"))))
  (progn
    (initget "Yes No")      
    (setq ans (getkword "\nDelete source object?  <No>: "))    
    (foreach wo    (ST:Ss->ListEnt ss)    
      (setq
        elst (entget wo)
        norm (vunit (v^v (cdr (assoc 11 elst)) (cdr (assoc 12 elst))))
        pts 	(wipeout2plst wo)
      )
      (entmake
    (append
      (list    '(0 . "LWPOLYLINE")
        '(100 . "AcDbEntity")
        '(100 . "AcDbPolyline")
        (cons 90 (length pts))
        (cons 38 (caddr (trans (car pts) 0 norm)))
        '(70 . 1)
        (cons 210 norm)
      )
      (mapcar '(lambda (pt)
         	(setq pt (trans pt 0 norm))
         	(list 10 (car pt) (cadr pt))
       	)
          pts
      )
    )
      )
      (if (or (not ans) (wcmatch (strcase ans) "YES"))(entdel wo))
(princ)      
  )))  
)
;;==================SUB ROUTINES==================;;
;; returns the wipeout point list (WCS)
(defun wipeout2plst (wo / elst u v mat)
  (setq    elst (entget wo)
    u    (cdr (assoc 11 elst))
    v    (cdr (assoc 12 elst))
    mat  (list u (mapcar '- v) '(0. 0. 1.))
  )
  (mapcar
    '(lambda (p)
   	(mapcar '+
       	(mxv (trp mat) p)
       	(mapcar '(lambda (x y) (/ (+ x y) 2.)) u v)
       	(cdr (assoc 10 elst))
   	)
 	)
    (cdr
      (mapcar 'cdr
          (vl-remove-if-not '(lambda (x) (= (car x) 14)) elst)
      )
    )
  )
)
;; Transpose a matrix Doug Wilson
(defun trp (m)
  (apply 'mapcar (cons 'list m))
)
;; Apply a transformation matrix to a vector by Vladimir Nesterovsky
(defun mxv (m v)
  (mapcar '(lambda (r) (apply '+ (mapcar '* r v))) m)
)
;; V^V
;; Returns the cross product of 2 vectors
(defun v^v (v1 v2)
  (list    (- (* (cadr v1) (caddr v2)) (* (caddr v1) (cadr v2)))
    (- (* (caddr v1) (car v2)) (* (car v1) (caddr v2)))
    (- (* (car v1) (cadr v2)) (* (cadr v1) (car v2)))
  )
)
;; VUNIT
;; Returns the single unit vector
(defun vunit (v)
  ((lambda (l)
 	(if (/= 0 l)
   	(mapcar (function (lambda (x) (/ x l))) v)
 	)
   )
    (distance '(0 0 0) v)
  )
)
 
 
;;; ENT2PTLST
;;; Returns the vertices list of the polygon figuring the curve object
;;; Coordinates defined in OCS
 
(defun ent2ptlst (ent / obj dist n lst p_lst prec)
  (vl-load-com)
  (if (= (type ent) 'ENAME)
    (setq obj (vlax-ename->vla-object ent))
  )
  (cond
    ((member (cdr (assoc 0 (entget ent))) '("CIRCLE" "ELLIPSE"))
 	(setq dist    (/ (vlax-curve-getDistAtParam
         	obj
         	(vlax-curve-getEndParam obj)
       	)
       	50
        )
   	n    0
 	)
 	(repeat 50
   	(setq
 	lst
      (cons
        (trans
          (vlax-curve-getPointAtDist obj (* dist (setq n (1+ n))))
          0
          (vlax-get obj 'Normal)
        )
        lst
      )
   	)
 	)
    )
    (T
 	(setq p_lst (vl-remove-if-not
       	'(lambda (x)
              (or (= (car x) 10)
              (= (car x) 42)
              )
            )
       	(entget ent)
     	)
 	)
 	(while p_lst
   	(setq
 	lst
      (cons
        (append (cdr (assoc 10 p_lst))
            (list (cdr (assoc 38 (entget ent))))
        )
        lst
      )
   	)
   	(if (/= 0 (cdadr p_lst))
 	(progn
   	(setq prec (1+ (fix (* 25 (sqrt (abs (cdadr p_lst))))))
     	dist (/ (- (if    (cdaddr p_lst)
                  (vlax-curve-getDistAtPoint
                obj
                (trans (cdaddr p_lst) ent 0)
                  )
                  (vlax-curve-getDistAtParam
                obj
                (vlax-curve-getEndParam obj)
                  )
                )
                (vlax-curve-getDistAtPoint
                  obj
                  (trans (cdar p_lst) ent 0)
                )
         	)
         	prec
              )
     	n    0
   	)
   	(repeat (1- prec)
     	(setq
       	lst (cons
         	(trans
           	(vlax-curve-getPointAtDist
         	obj
         	(+ (vlax-curve-getDistAtPoint
                  obj
                  (trans (cdar p_lst) ent 0)
                )
                (* dist (setq n (1+ n)))
         	)
           	)
           	0
           	ent
         	)
         	lst
       	)
     	)
   	)
 	)
   	)
   	(setq p_lst (cddr p_lst))
 	)
    )
  )
  lst
)
 
 
;;; MakeWipeout creates a "wipeout" from a points list and the normal vector of the object
 
(defun MakeWipeout (pt_lst nor / dxf10 max_dist cen dxf_14)
  (if (not (member "acwipeout.arx" (arx)))
    (arxload "acwipeout.arx")
  )
  (setq    dxf10 (list (apply 'min (mapcar 'car pt_lst))
            (apply 'min (mapcar 'cadr pt_lst))
            (caddar pt_lst)
          )
  )
  (setq
    max_dist
 	(float
   	(apply 'max
          (mapcar '- (apply 'mapcar (cons 'max pt_lst)) dxf10)
   	)
 	)
  )
  (setq cen (mapcar '+ dxf10 (list (/ max_dist 2) (/ max_dist 2) 0.0)))
  (setq
    dxf14 (mapcar
        '(lambda (p)
       	(mapcar '/
           	(mapcar '- p cen)
           	(list max_dist (- max_dist) 1.0)
       	)
     	)
        pt_lst
      )
  )
  (setq dxf14 (reverse (cons (car dxf14) (reverse dxf14))))
  (entmake (append (list '(0 . "WIPEOUT")
         	'(100 . "AcDbEntity")
         	'(100 . "AcDbWipeout")
         	'(90 . 0)
         	(cons 10 (trans dxf10 nor 0))
         	(cons 11 (trans (list max_dist 0.0 0.0) nor 0))
         	(cons 12 (trans (list 0.0 max_dist 0.0) nor 0))
         	'(13 1.0 1.0 0.0)
         	'(70 . 7)
         	'(280 . 1)
         	'(71 . 2)
         	(cons 91 (length dxf14))
       	)
       	(mapcar '(lambda (p) (cons 14 p)) dxf14)
   	)
  )
)
 
(defun ST:Ss->ListEnt (ss / n e l)
  (setq n (sslength ss))
  (while (setq e (ssname ss (setq n (1- n))))
    (setq l (cons e l))
  )  
) 

thank bác.e đã thử wipeout vật thể có chứa arc và ok.

à, nhân tiện cho em hỏi có bác nào có lisp tự động vẽ viền bo ngoài của 1 vật thể ko, ví dụ e có 1 block có hình dạng phức tạp nhưng chỉ muốn tạo viền bo ngoài của vật thể đó để sau đó dùng wipeot cho block đó nổi lên trên các đối tượng khác


<<

Filename: 284653_ob2wo_wof_wo2pl.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 285357
Tên lệnh: ha
Thắc mắc về chỉnh sửa đường mline

Lisp Modify các Mline trên bản vẽ theo Mlstyle Current.

Cách sử dụng:

1). Tạo Mlstyle theo ý muốn, sau đó Set Current.

2). Dùng Lisp.

; Doan Van Ha - CadViet.com - 26/3/2014
; Chuc nang: Modify cac Mline hien huu theo Mlstyle Current.
; Huong dan su dung:
; 1). Tao Mlstyle theo y muon va Set Current.
; 2). Load Lisp, sau do dung lenh HA de Modify.
(defun C:HA(/ msp ss i ent...
>>

Lisp Modify các Mline trên bản vẽ theo Mlstyle Current.

Cách sử dụng:

1). Tạo Mlstyle theo ý muốn, sau đó Set Current.

2). Dùng Lisp.

; Doan Van Ha - CadViet.com - 26/3/2014
; Chuc nang: Modify cac Mline hien huu theo Mlstyle Current.
; Huong dan su dung:
; 1). Tao Mlstyle theo y muon va Set Current.
; 2). Load Lisp, sau do dung lenh HA de Modify.
(defun C:HA(/ msp ss i ent lst)
 (vl-load-com)
 (setq msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
 (setq ss (ssget '((0 . "Mline"))))
 (repeat (setq i (sslength ss))
  (setq ent (ssname ss (setq i (1- i))))
  (setq lst (apply 'append (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 11)) (entget ent)))))
  (vla-AddMline msp (vlax-safearray-fill (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length lst)))) lst))
  (entdel ent))
 (princ)) 
 


<<

Filename: 285357_ha.lsp
Tác giả: quansla
Bài viết gốc: 285376
Tên lệnh: thunghiem
biến hình tròn thành hình đa giác (help help)
việc này có thể làm được với lisp ở mức chấp nhận được, nói chấp nhận được là vì có thể tạo ra một Polyline đa giác đều n cạnh thay thế hình tròn tại vị trí cũ, nhưng mà hướng quay của Polyline thì chưa biết, nên chỉ tạm chấp nhận thôi, bạn thấy yêu cầu về huớng quay có quan trọng không/
Nếu không thì xài tạm.

(defun c:thunghiem(/ N i Radi ent p10)
(vl-load-com)
(setvar...
>>
việc này có thể làm được với lisp ở mức chấp nhận được, nói chấp nhận được là vì có thể tạo ra một Polyline đa giác đều n cạnh thay thế hình tròn tại vị trí cũ, nhưng mà hướng quay của Polyline thì chưa biết, nên chỉ tạm chấp nhận thôi, bạn thấy yêu cầu về huớng quay có quan trọng không/
Nếu không thì xài tạm.

(defun c:thunghiem(/ N i Radi ent p10)
(vl-load-com)
(setvar "cmdecho" 0)
  (or #N (setq #N 100))
  (setq N (cond ((getint (strcat "\nCho so canh <" (rtos #N 2 0) ">"))) (#N))
#N N)
  (foreach i (acet-ss-to-list(ssget '(( 0 . "CIRCLE"))))
    (setq Radi (cdr(assoc 40 (setq ent (entget i)))) p10 (cdr(assoc 10 ent)))
    (entdel i)
    (vl-cmdf "POLYGON" N p10 "C" Radi))
(setvar "cmdecho" 1)
  (princ)
  )

<<

Filename: 285376_thunghiem.lsp
Tác giả: vantuan18nd
Bài viết gốc: 285625
Tên lệnh: mul sum
[NHỜ CHỈNH SỬA] lisp tính tổng SUM
;;;-----------------------------------------
(defun CheckObj(e MyType) (equal (cdr (assoc 0 (entget e))) MyType))
;;;-----------------------------------------
(defun FilObj(ss1 MyType / ss2 i e)
(setq ss2 (ssadd) i 0)
(repeat (sslength ss1)
(setq e (ssname ss1 i) i (1+ i))
(if (CheckObj e MyType) (ssadd e ss2) )
)
(eval ss2)
)
;;;-----------------------------------------
(defun SelData( / OK)
(setq OK nil)
(while (not OK)
(prompt "\tChon cac text can...
>>
;;;-----------------------------------------
(defun CheckObj(e MyType) (equal (cdr (assoc 0 (entget e))) MyType))
;;;-----------------------------------------
(defun FilObj(ss1 MyType / ss2 i e)
(setq ss2 (ssadd) i 0)
(repeat (sslength ss1)
(setq e (ssname ss1 i) i (1+ i))
(if (CheckObj e MyType) (ssadd e ss2) )
)
(eval ss2)
)
;;;-----------------------------------------
(defun SelData( / OK)
(setq OK nil)
(while (not OK)
(prompt "\tChon cac text can tinh:")
(setq ss (FilObj (ssget) "TEXT"))
(if (> (sslength ss) 0) (setq OK T) (princ "\nDoi tuong chon khong phai text"))
)
)
;;;-----------------------------------------
(defun WriteRes(kq / OK e data)
(setq OK nil)
(while (not OK)
(setq e (car (entsel "\tChon text ghi ket qua:")))
(if (CheckObj e "TEXT") (setq OK T) (princ "\nDoi tuong chon khong phai text"))
)
(entmod (subst (cons 1 (rtos kq)) (assoc 1 (setq data (entget e))) data))
(princ)
)
;;;-----------------------------------------
(defun C:MUL( / i m e ss)
(SelData) (setq i 0 m 1.0)
(repeat (sslength ss) (setq e (ssname ss i) i (1+ i) m (* m (atof (cdr (assoc 1 (entget e)))))))
(WriteRes m)
)
;;;-----------------------------------------
(defun C:SUM( / i s e ss)
(SelData) (setq i 0 s 0.0)
(repeat (sslength ss) (setq e (ssname ss i) i (1+ i) s (+ s (atof (cdr (assoc 1 (entget e)))))))
(WriteRes s)
)
;;;-----------------------------------------

1/ Mô tả lisp trên

+ Tính tổng các số dạng text số

+ Kết quả : Pick chọn text có sẵn để ghi kết quả

2/ Giúp mình sửa lại như sau :

+ Kết quả trả về sẽ hiện ở vùng bên trên vùng Command (giống kết quả của lệnh "di")

Thanks !


<<

Filename: 285625_mul_sum.lsp
Tác giả: quansla
Bài viết gốc: 285744
Tên lệnh: cadviet
Not in at the moment does bactrim ds contain sulfa Inspired by the recent murder of Aboriginal teenager Tina Fontaine, the article details life in a province where just 13%

Filename: 285744_cadviet.lsp
Tác giả: ketxu
Bài viết gốc: 285864
Tên lệnh: hp
Nhờ các bac viết lisp hatch nhiều polyline cùng 1 lúc

@Tot77 : Mình nhớ là Hatch có chế độ chọn Object, sao lại cần đến lisp nhỉ :)

 

(defun c:hp()(command ".-Hatch" "s" (ssget (list (cons 0 "*POLYLINE"))) "" ""))
 

Filename: 285864_hp.lsp
Tác giả: ketxu
Bài viết gốc: 285958
Tên lệnh: hp
Nhờ các bac viết lisp hatch nhiều polyline cùng 1 lúc

Xét lại thì tất cả các hình đều có lý của nó ^^ Ket vẫn dạy học sinh là k được Hatch Select Object các đối tượng mà tự thân nó k kín, giờ vẫn giữ quan điểm đó ^^ (trừ TH đặc biệt), k biết đến bao giờ thì thay đổi.

Vụ dính vào nhau thì hatch riêng chắc sẽ ổn thôi 

(defun c:hp()
(setq ss (ssget (list (cons 0 "*POLYLINE"))) i -1)
(while (setq e (ssname ss (setq i...
>>

Xét lại thì tất cả các hình đều có lý của nó ^^ Ket vẫn dạy học sinh là k được Hatch Select Object các đối tượng mà tự thân nó k kín, giờ vẫn giữ quan điểm đó ^^ (trừ TH đặc biệt), k biết đến bao giờ thì thay đổi.

Vụ dính vào nhau thì hatch riêng chắc sẽ ổn thôi 

(defun c:hp()
(setq ss (ssget (list (cons 0 "*POLYLINE"))) i -1)
(while (setq e (ssname ss (setq i (1+ i)))) (command ".-Hatch" "s" e "" ""))
)

Còn vụ thế nào là kín thì tuỳ OP quy định, ket hem ý kiến


<<

Filename: 285958_hp.lsp
Tác giả: namnhim
Bài viết gốc: 278097
Tên lệnh: dimarc
đo chiều dài đường cong tại hai điểm bất kỳ

Anh có thể cho xuất ra text sẵn có và đổi thành màu đỏ được ko ạ?

bạn có thể dùng cái này để đo và xuất luôn ra Dim có Layer và kích thước màu đỏ cũng được

(defun C:DIMARC ( / pt1 pt2 cen a1 a2 D1 D2 p r oldOs)
 (setq oldOs (getvar "OSMODE"))
 (prompt "Pick 2 points on an arc - ")
...
>>

Anh có thể cho xuất ra text sẵn có và đổi thành màu đỏ được ko ạ?

bạn có thể dùng cái này để đo và xuất luôn ra Dim có Layer và kích thước màu đỏ cũng được

(defun C:DIMARC ( / pt1 pt2 cen a1 a2 D1 D2 p r oldOs)
 (setq oldOs (getvar "OSMODE"))
 (prompt "Pick 2 points on an arc - ")
 (setvar "OSMODE" 512)
   (COMMAND "-LAYER" "m" "Dim" "color" 1 "" "")(PRINC)
 (while (not cen)
  (setq   pt1 (getpoint "1st pt: ")
   cen (osnap pt1 "_CEN")
  )
  (if (not cen) (alert "Doesn't lie on an arc, retry")
      (setq pt2 (getpoint cen " 2nd pt: ")))
 );while
 (setvar "OSMODE" 0)
 (setq a1 (angle cen pt1) a2 (angle cen pt2) ad (abs (- a2 a1))
   r (distance pt1 cen)
   D1 (* r ad)
   D2 (* r (- (* 2 pi) ad)) )
 (prompt (strcat "\nArc length: " (rtos D1) ",   complementar arc: " (rtos D2))) 
 (command "_DIMANGULAR" "" cen pt1 pt2 "_T" (rtos D1) pause)
 (setvar "OSMODE" oldOs)
 (prin1))
(princ "\nDIMARC command loaded.")
(princ)

<<

Filename: 278097_dimarc.lsp
Tác giả: ketxu
Bài viết gốc: 142250
Tên lệnh: sd
Viết lisp theo yêu cầu [phần 2]


Bạn dùng tạm, mình để chọn dim đầu tiên trong tập chọn làm dim để lấy Scale, bạn có thể kích chọn dim chỉ định hoặc quét lẫn cả vào nếu vùng đó chỉ có 1 dimstyle. Đến giờ về, mình hơi vội, viết k được hay, có gì bạn cứ phản hồi nhé:

Filename: 142250_sd.lsp
Tác giả: namnhim
Bài viết gốc: 286606
Tên lệnh: dt1
[ Yêu cầu ] Nhờ chỉnh lisp tính diện tích

bạn thử dùng cái này có được không:

(DEFUN C:DT1(/ A)
  (SETQ A (GETPOINT "CHON DIEM : "))
  (COMMAND "BOUNDARY" A "")
  (COMMAND "AREA" "O" (SSGET "L"))
  (COMMAND "ERASE" (SSGET "L") "")
 (command "-style" "text" "Times New Roman" 2.5 "1" "0" "n" "n") ;;;;Muon sua Text to hay nho 2.5 ...
  (command "-layer" "m" "Text""c" "White" "" "")
(setq e_lst (entget (tblobjname "style" (getvar 'textstyle))))
(entmod (subst (cons 50 0.261799) (setq...
>>

bạn thử dùng cái này có được không:

(DEFUN C:DT1(/ A)
  (SETQ A (GETPOINT "CHON DIEM : "))
  (COMMAND "BOUNDARY" A "")
  (COMMAND "AREA" "O" (SSGET "L"))
  (COMMAND "ERASE" (SSGET "L") "")
 (command "-style" "text" "Times New Roman" 2.5 "1" "0" "n" "n") ;;;;Muon sua Text to hay nho 2.5 ...
  (command "-layer" "m" "Text""c" "White" "" "")
(setq e_lst (entget (tblobjname "style" (getvar 'textstyle))))
(entmod (subst (cons 50 0.261799) (setq old (assoc 50 e_lst)) e_lst))
  (command "text" "j" "tl" A "" (strcat "DT: " (rtos (/ (* (GETVAR "AREA") 10) 10) 2 2) " m²"))
(entmod (subst old (assoc 50 e_lst) e_lst))
  (PRINC "\nDIEN TICH LA : ")(PRINC  (/ (* (GETVAR "AREA") 10) 10))(PRINC" m²")(prompt "\nDA TINH XONG DIEN TICH!")(princ))

<<

Filename: 286606_dt1.lsp
Tác giả: hochoaivandot
Bài viết gốc: 286793
Tên lệnh: ttt
[ Yêu cầu ] Nhờ chỉnh lisp xác định lý trình - cách tim

;; Write CSV - Lee Mac
;; Writes a matrix list of cell values to a CSV file.
;; lst - list of lists, sublist is row of cell values
;; csv - filename of CSV file to write
;; Returns T if successful, else nil

(defun LM:writecsv ( lst csv / des sep )
(if (setq des (open csv "w"))
(progn
(setq sep (cond ((vl-registry-read "HKEY_CURRENT_USER\\Control Panel\\International" "sList")) (",")))
(foreach row lst (write-line (LM:lst->csv row sep)...

>>

;; Write CSV - Lee Mac
;; Writes a matrix list of cell values to a CSV file.
;; lst - list of lists, sublist is row of cell values
;; csv - filename of CSV file to write
;; Returns T if successful, else nil

(defun LM:writecsv ( lst csv / des sep )
(if (setq des (open csv "w"))
(progn
(setq sep (cond ((vl-registry-read "HKEY_CURRENT_USER\\Control Panel\\International" "sList")) (",")))
(foreach row lst (write-line (LM:lst->csv row sep) des))
(close des)
t
)
)
)

;; List -> CSV - Lee Mac
;; Concatenates a row of cell values to be written to a CSV file.
;; lst - list containing row of CSV cell values
;; sep - CSV separator token

(defun LM:lst->csv ( lst sep )
(if (cdr lst)
(strcat (LM:csv-addquotes (car lst) sep) sep (LM:lst->csv (cdr lst) sep))
(LM:csv-addquotes (car lst) sep)
)
)

(defun LM:csv-addquotes ( str sep / pos )
(cond
( (wcmatch str (strcat "**"))
(setq pos 0)
(while (setq pos (vl-string-position 34 str pos))
(setq str (vl-string-subst "\"\"" "\"" str pos)
pos (+ pos 2)
)
)
(strcat "\"" str "\"")
)
( str )
)
)
(defun C:ttt(/ e obj pt pt1 dis lt lst)
(vl-load-com)
(setq e (car (entsel "Chon PL")))
(setq obj (vlax-ename->vla-object e))
(setq lst (list (list "Lytrinh" "Cach tim" "Toa do X" "Toa do Y")))
(while (setq pt (getpoint "\nPick diem"))
(setq pt1 (vlax-curve-getClosestPointTo obj pt))
(setq dis (distance pt pt1))
(setq lt (vlax-curve-getDistAtPoint obj pt1))
(princ (strcat "Ly trinh = " (rtos lt 2 2) "\nKhoach cach den tim = " (rtos dis 2 2)))
(setq lst (cons (list (rtos lt 2 2) (rtos dis 2 2) (rtos (car pt1) 2 3) (rtos (cadr pt1) 2 3)) lst))
)
(if (and
(setq fn (getfiled "Create Output File" "" "csv" 1))
(LM:WriteCSV (reverse lst) fn)
)
(startapp "explorer" fn)
)

)

 

 

Trong lúc chờ đợi bác Phamthanhbinh có 1 lisp chuẩn hơn. Tôi làm sơ bộ cho bạn như thế này. Có thể chữa cháy trước mắt cho yêu cầu của bạn. Hì hì


<<

Filename: 286793_ttt.lsp
Tác giả: Tot77
Bài viết gốc: 287285
Tên lệnh: test
Lisp nối Line thành Pline ?

Nhân đề nghị của anh 2 lúa cad nông dân bên trên tôi làm thêm 1 bước nữa, chỉ cần đánh lệnh test nó sẽ tự động nối line,arc.

Nhưng tôi chưa có file line arc số lượng lớn để test, bạn nào có file lớn đưa lên để test thử. File lisp như sau:

 

 

(defun c:test(/ kc L1 L2 tieptuc tm1 tm2 tm ng obj)
  (defun noithem(d v kc tr / tm tm1)
    (if (setq tm (car...
>>

Nhân đề nghị của anh 2 lúa cad nông dân bên trên tôi làm thêm 1 bước nữa, chỉ cần đánh lệnh test nó sẽ tự động nối line,arc.

Nhưng tôi chưa có file line arc số lượng lớn để test, bạn nào có file lớn đưa lên để test thử. File lisp như sau:

 

 

(defun c:test(/ kc L1 L2 tieptuc tm1 tm2 tm ng obj)
  (defun noithem(d v kc tr / tm tm1)
    (if (setq tm (car (vl-remove nil
(mapcar '(lambda(x) (if (and (/= v (cadar x))
    (or (<= (distance d (car x)) kc) (<= (distance d (last x)) kc))) x nil)) L1))))
    (if (or (and tr (<= (distance d (car tm)) kc)) 
            (and (not tr) (<= (distance d (last tm)) kc)))
    (setq ng t tm1 (reverse tm))
    (setq ng nil tm1 tm)))
  )
  
  (defun ssfrom (sl / ss0) (setq ss0 (ssadd)) (foreach v sl (ssadd v ss0)) ss0)
  ;;;
  (setq kc (getreal "\nNhap khoang ho cho phep de noi:")
L1 (mapcar '(lambda(x) (list (vlax-curve-getStartPoint (setq obj (vlax-ename->vla-object x))) x
(vlax-curve-getEndPoint obj))) (acet-ss-to-list (ssget "X" '((0 . "LINE,ARC")))))
L2 (list (car L1))
L1 (cdr L1))
  (setvar "cmdecho" 0)
  (while L1
    (setq tieptuc t)
    (while tieptuc      
      (if (setq tm1 (noithem (caar L2) (cadar L2) kc t))
        (setq L2 (cons tm1 L2) L1 (vl-remove (if ng (reverse tm1) tm1) L1)))
      (if (setq tm2 (noithem (last (last L2)) (cadr (last L2)) kc nil))
        (setq L2 (append L2 (list tm2)) L1 (vl-remove (if ng (reverse tm2) tm2) L1)))
      (if (and (not tm1)(not tm2))
(setq tieptuc nil
     tm (COMMAND ".PEDIT" "M" (ssfrom (mapcar 'cadr L2)) ""  "Y" "J" kc "")
     L2 (list (car L1))
     L1 (cdr L1)))
    )
  )
  (setvar "cmdecho" 1)
)
 

<<

Filename: 287285_test.lsp
Tác giả: Tot77
Bài viết gốc: 287308
Tên lệnh: test
[ Yêu cầu ] Nhờ viết lisp vẽ đường thẳng vuông góc với Pline

Của bạn đây.

 

(defun c:test(/ cd pl obj dd dait cl sl n os ki )
  (defun ad(v p1 p2 / a1)
    (abs (- (vlax-curve-getDistAtPoint (setq a1 (vlax-ename->vla-object v)) (vlax-curve-getClosestPointTo a1 p2))
  (vlax-curve-getDistAtPoint a1 (vlax-curve-getClosestPointTo a1 p1)))))
  
  (defun getp(v dis)
     (vlax-curve-getPointAtDist (vlax-ename->vla-object v) dis))
  
  (defun thgoc (ent pt / param obj) 
 ...
>>

Của bạn đây.

 

(defun c:test(/ cd pl obj dd dait cl sl n os ki )
  (defun ad(v p1 p2 / a1)
    (abs (- (vlax-curve-getDistAtPoint (setq a1 (vlax-ename->vla-object v)) (vlax-curve-getClosestPointTo a1 p2))
  (vlax-curve-getDistAtPoint a1 (vlax-curve-getClosestPointTo a1 p1)))))
  
  (defun getp(v dis)
     (vlax-curve-getPointAtDist (vlax-ename->vla-object v) dis))
  
  (defun thgoc (ent pt / param obj) 
    (if (setq param (vlax-curve-getParamAtPoint (setq obj (vlax-ename->vla-object ent)) pt))
      (- (angle '(0 0 0) (vlax-curve-getFirstDeriv obj param))  (/ pi 2))
      nil))
  
  (defun daitc(v / obj)    
      (vlax-curve-getDistAtParam (setq obj (vlax-ename->vla-object v)) (vlax-curve-getEndParam obj)))
  
  ;;;
  
  (setq pl (car (entsel "\nChon Polyline:"))
li (car (entsel "\nChon duong thang vuong goc voi Polyline:"))
dail (daitc li)
dd (getpoint "\nDiem cuoi cua Polyline:")
cd (getreal "\nNhap buoc de rai:")
obj (vlax-ename->vla-object pl) 
dg (vlax-curve-getClosestPointTo obj (acet-dxf 10 (entget li)))
sl (getint "\nSo luong coc rai")
ct (vlax-curve-getDistAtPoint obj dg)
n 0
os (getvar "OSMODE"))
  (if (< (distance dd (vlax-curve-getStartPoint obj)) (distance dd (vlax-curve-getEndPoint obj)))
    (setq ki nil) (setq ki t))
  (setvar "OSMODE" 0)
  (repeat sl         
    (command "line"
    (setq dg1 (if ki (getp pl (+ ct (* (setq n (1+ n)) cd)))
     (getp pl (- ct (* (setq n (1+ n)) cd)))))   
    (polar dg1 (thgoc pl dg1) dail) ""))
  (setvar "OSMODE" os)
  (princ)
)

<<

Filename: 287308_test.lsp
Tác giả: TRUNGNGAMY
Bài viết gốc: 208316
Tên lệnh: tdt
Kinh nghiệm sử dụng AutoCAD
Mình nghĩ chỉ đưa lên vậy thôi. Nếu muốn thành lệnh thì phải thêm cái hàm chọn đối tượng là pl nó sẽ trả về một listpoint sau đó đưa vào hàm trên thì tính đc.

Lệnh là TDT.
cái hàm get-vertex-lwpline chưa sd đc với TH spline nên các bạn chỉ dùng cho TH pl toàn line mà thôi.

Filename: 208316_tdt.lsp
Tác giả: Tue_NV
Bài viết gốc: 287611
Tên lệnh: tf
[yêu cầu] Nhờ viết lsp thay đổi khoảng cách giữa các chữ trong text

Còn Lisp này hỏi nhập độ rộng mới -> chọn Text  -> sẽ thay đổi độ rộng cho Text

(defun c:tf(/ ss tw)
(defun Tue-ent-mod (dxf ename newValue / entget-ename)
  ;;;;;Ex: (Tue-ent-mod 1 (ssname (TUE-ss-entsel '((0 . "TEXT")) "\npick chon doi tuong TEXT / An phim bat ki de thoat :")  0)"TUE")
  ;;;;;;;;-->> Thay Text thanh chuoi "TUE"
  ;;;;;;;;dxf = 62 ma mau object; dxf = 6 ma Linetype cuar object
 ...
>>

Còn Lisp này hỏi nhập độ rộng mới -> chọn Text  -> sẽ thay đổi độ rộng cho Text

(defun c:tf(/ ss tw)
(defun Tue-ent-mod (dxf ename newValue / entget-ename)
  ;;;;;Ex: (Tue-ent-mod 1 (ssname (TUE-ss-entsel '((0 . "TEXT")) "\npick chon doi tuong TEXT / An phim bat ki de thoat :")  0)"TUE")
  ;;;;;;;;-->> Thay Text thanh chuoi "TUE"
  ;;;;;;;;dxf = 62 ma mau object; dxf = 6 ma Linetype cuar object
  (setq entget-ename (entget ename))
  (if (and (or (= dxf 62) (= dxf 6)) (null (assoc dxf entget-ename)))
          (setq entget-ename (append entget-ename (list (cons dxf newValue))))
  )
  (setq entget-ename (subst (cons dxf newValue) (assoc dxf entget-ename) entget-ename))
  (entmod entget-ename)
  ename
)
(defun Tue-ss-list (L-ss-vlaobj / n L Lst ssg vlaobj)
 
  (mapcar 'set '(ssg vlaobj) L-ss-vlaobj)
  (setq L (sslength ssg))
  (Repeat L
        (setq ename (ssname ssg (setq L (1- L))))
          (setq Lst (cons (if vlaobj (vlax-ename->vla-object ename) ename) Lst))
  )
)
(if (setq ss (ssget '((0 . "TEXT"))))
  (progn
    (setq tw (getreal "\n Nhap do rong chu :"))
    (foreach x (Tue-ss-list (list ss))
      (Tue-ent-mod 41 x tw)
    )
  )
)
)

<<

Filename: 287611_tf.lsp
Tác giả: Tot77
Bài viết gốc: 287608
Tên lệnh: test
[yêu cầu] Nhờ viết lsp thay đổi khoảng cách giữa các chữ trong text

Bạn dùng lisp này, nhập độ rộng hiện tại , chọn text , nó sẽ bắt các text có độ rộng đó, sau đó bạn muốn làm gì thì vào properties.

 

(defun c:test(/ ro)
  (defun ssfrom (sl / ss0) (setq ss0 (ssadd)) (foreach v sl (ssadd v ss0)) ss0)
  (setq ro (getreal "\nChon Text co do rong:"))
  (sssetfirst nil (ssfrom (vl-remove nil (mapcar '(lambda(x) (if (= ro (acet-dxf 41 (entget x))) x...
>>

Bạn dùng lisp này, nhập độ rộng hiện tại , chọn text , nó sẽ bắt các text có độ rộng đó, sau đó bạn muốn làm gì thì vào properties.

 

(defun c:test(/ ro)
  (defun ssfrom (sl / ss0) (setq ss0 (ssadd)) (foreach v sl (ssadd v ss0)) ss0)
  (setq ro (getreal "\nChon Text co do rong:"))
  (sssetfirst nil (ssfrom (vl-remove nil (mapcar '(lambda(x) (if (= ro (acet-dxf 41 (entget x))) x nil))
(acet-ss-to-list (ssget '((0 . "TEXT"))))))))
)

(defun c:test(/ ro)
  (defun ssfrom (sl / ss0) (setq ss0 (ssadd)) (foreach v sl (ssadd v ss0)) ss0)
  (setq ro (getreal "\nChon Text co do rong:"))
  (sssetfirst nil (ssfrom (vl-remove nil (mapcar '(lambda(x) (if (= ro (acet-dxf 41 (entget x))) x nil))
(acet-ss-to-list (ssget '((0 . "TEXT"))))))))
)

<<

Filename: 287608_test.lsp
Tác giả: Tot77
Bài viết gốc: 287620
Tên lệnh: test
Lisp xuất text khối lượng sang excell theo hàng và cột

Bạn chọn 4 text màu vàng rồi enter 1 cái, nó xuất ra file "dao dap.txt" ở thư mục cùng file cad.

Mỗi lần chọn 4 text rồi enter. Muốn dứt lệnh thì enter thêm cái nữa.

Tôi không biết đưa ra excel thế nào nên chỉ đưa ra txt thôi.

 

(defun c:test(/ file)
  (defun dxf(id v) (acet-dxf id (entget v)))
  (defun layText() (dxf 1 (nth (setq n (1+ n)) L)))
  (setq file (open...
>>

Bạn chọn 4 text màu vàng rồi enter 1 cái, nó xuất ra file "dao dap.txt" ở thư mục cùng file cad.

Mỗi lần chọn 4 text rồi enter. Muốn dứt lệnh thì enter thêm cái nữa.

Tôi không biết đưa ra excel thế nào nên chỉ đưa ra txt thôi.

 

(defun c:test(/ file)
  (defun dxf(id v) (acet-dxf id (entget v)))
  (defun layText() (dxf 1 (nth (setq n (1+ n)) L)))
  (setq file (open (strcat (getvar "dwgprefix") "Dao dap.txt") "a"))
  (write-line "S bun\tS dao\tS dap duong\tS dap bp kenh" file)
  
  (while (setq ss (ssget '((0 . "*TEXT") (1 . "~**"))))
     (setq L (vl-sort (acet-ss-to-list ss)
      '(lambda(x y) (> (cadr (dxf 11 x)) (cadr (dxf 11 y)))))
  n -1)
    (while (< n (1- (length L)))
      (write-line (strcat (layText) "\t"  (layText) "\t" (layText) "\t" (layText)) file))
  )
  (close file)
)

 

Không thể chọn một loạt 1 lần được vì thứ tự các text chưa chắc đã canh đúng.


<<

Filename: 287620_test.lsp
Tác giả: thiep
Bài viết gốc: 127817
Tên lệnh: nsmt
Hỏi: Cách nội suy tâm đường tròn 3D

Xin lỗi các bác vì cuối năm Thiep bận việc quá,
Dựa trên thuật toán của bác ThanhBinh và của DuongTrungHuy, Thiep cho ra lò 1 cái lisp bằng cách "xào nấu" và thêm một chút gia vị 2 lisp của 2 bác.
Lisp này không cần tính toán các thông số A, B, C, D như ThanhBinh, Lisp này cũng chuyển hệ trục tọa độ nhưng không dùng dòng lệnh (command "UCS" 3 d1 d2 d3) và lệnh Cal như DuongTrungHuy.
Lisp này...
>>

Xin lỗi các bác vì cuối năm Thiep bận việc quá,
Dựa trên thuật toán của bác ThanhBinh và của DuongTrungHuy, Thiep cho ra lò 1 cái lisp bằng cách "xào nấu" và thêm một chút gia vị 2 lisp của 2 bác.
Lisp này không cần tính toán các thông số A, B, C, D như ThanhBinh, Lisp này cũng chuyển hệ trục tọa độ nhưng không dùng dòng lệnh (command "UCS" 3 d1 d2 d3) và lệnh Cal như DuongTrungHuy.
Lisp này chạy nhanh hơn lisp của bác Thanhbinh một chút, nhanh hơn nhiều lisp của DuongTrungHuy, và xác định được vòng tròn chuẩn như lisp của DuongTrungHuy.

Chào Duyminh86, cái gọi là điểm dạng chữ thập (+) hoặc điểm dạng hình cầu như bạn nói thì điểm này do đối tượng gì tạo ra: - 2 line cắt nhau? dạng TEXT?, điểm là tâm của hình cầu?... bạn nói rõ thêm nhé.
Chúc các bạn vui trong những ngày cuối năm!
<<

Filename: 127817_nsmt.lsp

Trang 153/304

153