Jump to content
InfoFile
Tác giả: quansla
Bài viết gốc: 443200
Tên lệnh: phundiem
lisp Phun tọa độ các điểm từ file txt vào CAD

Lười và ăn sẵn quá

(vl-load-com)
(defun c:phundiem(/ f fn l p r vText2 LM:str->lst)

(defun LM:str->lst ( str del / len lst pos )
    (setq len (1+ (strlen del)))
    (while (setq pos (vl-string-search del str))
        (setq lst (cons (substr str 1 pos) lst)
              str (substr str (+ pos len))
        )
    )
    (reverse (cons str lst))
)
  (defun vText2(str p layer k mau) 
   ...
>>

Lười và ăn sẵn quá

(vl-load-com)
(defun c:phundiem(/ f fn l p r vText2 LM:str->lst)

(defun LM:str->lst ( str del / len lst pos )
    (setq len (1+ (strlen del)))
    (while (setq pos (vl-string-search del str))
        (setq lst (cons (substr str 1 pos) lst)
              str (substr str (+ pos len))
        )
    )
    (reverse (cons str lst))
)
  (defun vText2(str p layer k mau) 
    (entmakex
      (list
	'(0 . "TEXT")
	'(100 . "AcDbEntity")
	'(100 . "AcDbText")
	(cons 1 str);string
	(cons 7 (getvar "textstyle"));style
	(cons 8 layer);layer
	(cons 62 mau);color
	(cons 10 p);insertion point
	(cons 11 p);alignment point
	(cons 40 k);text height - change by suit
	(cons 41 1.0);text width
	(cons 50 0.0);1.5708 - vertical, 0.0 - horizontal
	(cons 51 0.0);oblique angle
	'(71 . 0);alignment
	'(72 . 0);alignment
	'(73 . 0);alignment
	)
      )
    ;(princ)
    )
  
  ;(setq f (getfiled "\nChon file " "" "txt" 2))
  (setq f "C:\\Users\\Admin\\Desktop\\33.txt")
  (setq fn (open f "r"))
  (while (setq l (read-line fn))
    (setq r (vl-remove-if '(lambda(x) (= x "")) (LM:str->lst l " "))
	  p (mapcar 'atof (list (nth 2 r) (nth 3 r) (nth 4 r))))

    (vText2 (car r) p "ten_diem" 0.5 1)
    (vText2 (cadr r) p "Ghi_chu" 0.25 3)
    (entmakex
      (list
	'( 0  . "POINT")
	(cons 10 p)
	(cons 62 4)
	(cons 8 "Point")))
    )
  (close fn)
  (princ)
  )

Nên thu phí đi thôi


<<

Filename: 443200_phundiem.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 228547
Tên lệnh: loctext
Lọc các Text có cùng chiều cao?

Lisp thì ok rồi Anh ơi.. nhưng còn 1 vấn đề nữa là sau khi lọc text xong,khi kết thúc lệnh thì các text vừa lọc làm sao hiện được...

>>

Lisp thì ok rồi Anh ơi.. nhưng còn 1 vấn đề nữa là sau khi lọc text xong,khi kết thúc lệnh thì các text vừa lọc làm sao hiện được cái dấu màu xanh dưới chân text (giống như kiểu dùng chuột chọn một đối tượng trên bản vẽ ah), để em có thể thao tác trên các đối tượng vừa lọc... chứ Enter xong nó mất tiêu luôn... Anh xem lại giúp em...  :)

Hề hề hề,

Nếu bạn muốn vậy, hãy bổ sung dòng code sau vào trước dấu ngoặc kết thúc lisp:

(sssetfirst nil ss)

Cụ tỷ như dưới đây:

(defun c:loctext ( / )

(setq tm (car (entsel "\n Chon text mau: ")))

(setq ss (ssget (list (cons 0 "*text") (assoc 40 (entget tm)) )))

(sssetfirst nil ss)

)


<<

Filename: 228547_loctext.lsp
Tác giả: whatcholingon
Bài viết gốc: 169785
Tên lệnh: rb
Lisp chèn text vào Pl

Quick code :

(defun c:rb()
(defun ST:Geom-Center (ent / p1 p2)
(vla-getboundingbox (vlax-ename->vla-object ent) 'p1 'p2)
(setq p1...
>>

Quick code :

(defun c:rb()
(defun ST:Geom-Center (ent / p1 p2)
(vla-getboundingbox (vlax-ename->vla-object ent) 'p1 'p2)
(setq p1 (vlax-safearray->list p1)
p2 (vlax-safearray->list p2)  
pt (mapcar '* (mapcar '+ p1 p2) '(0.5 0.5 0.5))
)
)
(or ang (setq ang 180))
(setq ang (cond ((getreal (strcat "\nGoc quay < " (rtos ang 2 2) " >:")))(ang)))
(foreach e (acet-ss-to-list (ssget))
(command ".rotate" e "" "_non" (ST:Geom-Center e) ang )
))

Chú ý code tác dụng với mọi đối tượng, nếu bạn chỉ muốn quét Text thì sửa (ssget) thành (ssget (list (cons 0 "*TEXT")))

 

Bạn coi lại xem mình dùng lsp thì báo thế này:

Select objects: ; error: no function definition: ACET-SS-TO-LIST

Thanks!


<<

Filename: 169785_rb.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 421227
Tên lệnh: pmax pmin
Tìm đối tượng Point có Position Z nhỏ nhất hoặc lớn nhất

Âm mưu của tôi là cố tình chỉ chọn 1 gái đẹp, bởi bạn không nói rõ là sẽ chọn luôn cả đám vào chung kết hoa hậu để làm bồ nhí. Đợi. Lần sau y/c cho rõ vào. 

	(defun C:PMAX( / lst ss)
 (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex  (ssget '((0 . "POINT")))))))
 (setq lst (vl-sort lst '(lambda (e1 e2)  (> (cadddr (assoc 10 (entget e1))) (cadddr (assoc 10 (entget e2)))))))
 (setq lst...
>>

Âm mưu của tôi là cố tình chỉ chọn 1 gái đẹp, bởi bạn không nói rõ là sẽ chọn luôn cả đám vào chung kết hoa hậu để làm bồ nhí. Đợi. Lần sau y/c cho rõ vào. 

	(defun C:PMAX( / lst ss)
 (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex  (ssget '((0 . "POINT")))))))
 (setq lst (vl-sort lst '(lambda (e1 e2)  (> (cadddr (assoc 10 (entget e1))) (cadddr (assoc 10 (entget e2)))))))
 (setq lst (vl-remove-if-not '(lambda(x) (equal (cadddr (assoc 10 (entget (car lst)))) (cadddr (assoc 10 (entget x))) 1E-3)) lst))
 (setq ss (ssadd))
 (foreach s lst (ssadd s ss))
 (sssetfirst nil ss))
(defun C:PMIN( / lst ss)
 (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex  (ssget '((0 . "POINT")))))))
 (setq lst (vl-sort lst '(lambda (e1 e2)  (< (cadddr (assoc 10 (entget e1))) (cadddr (assoc 10 (entget e2)))))))
 (setq lst (vl-remove-if-not '(lambda(x) (equal (cadddr (assoc 10 (entget (car lst)))) (cadddr (assoc 10 (entget x))) 1E-3)) lst))
 (setq ss (ssadd))
 (foreach s lst (ssadd s ss))
 (sssetfirst nil ss))
	


<<

Filename: 421227_pmax_pmin.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 421223
Tên lệnh: pmax pmin
Tìm đối tượng Point có Position Z nhỏ nhất hoặc lớn nhất

Quick code:

	(defun C:PMAX( / lst) ; Max
 (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex  (ssget '((0 . "POINT")))))))
 (sssetfirst nil (ssadd (car (vl-sort lst '(lambda (e1 e2)  (> (cadddr (assoc 10 (entget e1))) (cadddr (assoc 10 (entget e2))))))))))
(defun C:PMIN( / lst) ; Min
 (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex  (ssget '((0 . "POINT")))))))
 (sssetfirst nil (ssadd (car (vl-sort lst '(lambda (e1 e2)  (<...
>>

Quick code:

	(defun C:PMAX( / lst) ; Max
 (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex  (ssget '((0 . "POINT")))))))
 (sssetfirst nil (ssadd (car (vl-sort lst '(lambda (e1 e2)  (> (cadddr (assoc 10 (entget e1))) (cadddr (assoc 10 (entget e2))))))))))
(defun C:PMIN( / lst) ; Min
 (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex  (ssget '((0 . "POINT")))))))
 (sssetfirst nil (ssadd (car (vl-sort lst '(lambda (e1 e2)  (< (cadddr (assoc 10 (entget e1))) (cadddr (assoc 10 (entget e2))))))))))
	


<<

Filename: 421223_pmax_pmin.lsp
Tác giả: tnmtpc
Bài viết gốc: 101863
Tên lệnh: exta
lisp Phun tọa độ các điểm từ file txt vào CAD
Bạn thử Lisp : Xuất tọa độ và các Tag (STT, mã code) của Block Attribute ra file Text (Bao gồm : Số thứ tự, text mã Code, toạ độ X-Y-Z)

>>
Bạn thử Lisp : Xuất tọa độ và các Tag (STT, mã code) của Block Attribute ra file Text (Bao gồm : Số thứ tự, text mã Code, toạ độ X-Y-Z)

Truờng hợp cao độ Z của Block bị đưa về "0" thì lấy giá trị của Tag Cao độ (EL.EV).

(defun c:exTA(/ Caodo Des ent i obj pos ss str Stt tmp z zero)
 (vl-load-com)
 (princ "\nChon doi tuong can xuat thuoc tinh :" )
 (if (and
(setq ss (ssget (list (cons 0 "INSERT")(cons 66 1)(cons 2 "D_chitiet"))))
(setq tmp (getfiled "Ten file xuat toa do" (getvar "dwgprefix") "txt" 1))  )
   (progn
     (setq tmp (open tmp "a") i -1)
     (write-line "STT,DESCP,X,Y,Z" tmp)
     (while (setq ent (ssname ss (setq i (1+ i))))
(setq obj (vlax-ename->vla-object ent)
      pos (mapcar 'rtos (vlax-get obj 'InsertionPoint)))
(foreach att (vlax-invoke obj 'GetAttributes)
  (cond
    ( (= (vla-get-TagString att) "EL.EV")
      (setq Caodo (vla-get-TextString att)) )
    ( (= (vla-get-TagString att) "DESCP")
      (setq Des (vla-get-TextString att)) )
    ( (= (vla-get-TagString att) "POINT")
      (setq Stt (vla-get-TextString att)) ))  )
(if (and
      (= 0 (atof (setq z(caddr pos))))
      (/= 0 (atof Caodo)))
  (setq z Caodo))
(write-line (strcat Stt (chr 44) Des (chr 44)
		    (car pos) (chr 44) (cadr pos) (chr 44) z  )
  	    tmp))
     (close tmp)) )
 (princ))

Mình đã chọn đối tượng là các khối thuộc tính nhưng không thấy gì cả


<<

Filename: 101863_exta.lsp
Tác giả: Danh Cong
Bài viết gốc: 443327
Tên lệnh: congdim
Thay đổi giá trị của dim
3 giờ trước, Hoangnhanst đã nói:

Có pro nào giúp...

>>
3 giờ trước, Hoangnhanst đã nói:

Có pro nào giúp với 

Viết cho bạn:



(defun c:CongDim ( / ENT-DXF ENT-NAME LAM_TRON_SO LIST-OBJECT NEWVALUE NUMBER OLDVALUE)
      ; Write by : DanhCong Cadviet
      (setq lam_tron_so (getvar "luprec"))
      (setq Number (getreal "\nNhap gia tri cong them :
                  \nSo chu so sau dau phay thiet lap trong Unit !"))
    (Prompt "\nChon duong kich thuoc de thay gia tri :"
        )
    (if (setq List-Object (ssget '((0 . "DIMENSION"))))
        (progn
            (repeat (sslength List-Object)
                (setq Ent-name (ssname List-Object 0))
                (setq Ent-dxf (entget Ent-name))

                (setq Oldvalue (if (eq "" (cdr (assoc 1 Ent-dxf))) (cdr (assoc 42 Ent-dxf)) (atof (cdr (assoc 1 Ent-dxf)))))
                (setq Newvalue (+ Oldvalue Number))

                (setq Ent-dxf (subst (cons 1 (rtos Newvalue 2 lam_tron_so)) (assoc 1 Ent-dxf) Ent-dxf))
                (entmod Ent-dxf)
                (vla-put-Textcolor (vlax-ename->vla-object Ent-name) 1)
                (ssdel Ent-name List-Object)
              )))
     (princ))


<<

Filename: 443327_congdim.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 443363
Tên lệnh: tt
Thay đổi giá trị của dim

Không đúng ý chắc là do khâu trình bày. Không biết lisp dưới đây đã đúng ý chưa?

Cách dùng:

- Pick điểm cần đo đến đoạn thẳng (LINE hoặc PLINE) .

- Pick đoạn thẳng (Pick điểm bất kỳ trên đoạn thẳng) => Kết quả đo luôn là k/c vuông góc từ điểm đến đoạn thẳng...

* Đối với PLINE nhiều phân đoạn: khi pick vào phân đoạn nào thì sẽ DIM đến...

>>

Không đúng ý chắc là do khâu trình bày. Không biết lisp dưới đây đã đúng ý chưa?

Cách dùng:

- Pick điểm cần đo đến đoạn thẳng (LINE hoặc PLINE) .

- Pick đoạn thẳng (Pick điểm bất kỳ trên đoạn thẳng) => Kết quả đo luôn là k/c vuông góc từ điểm đến đoạn thẳng...

* Đối với PLINE nhiều phân đoạn: khi pick vào phân đoạn nào thì sẽ DIM đến phân đoạn đó.

** Trong lisp có con số 13 là số mà bạn có thể chỉnh sửa.

(defun c:tt  (/ asp dim doc ent par per poi sel val)
  (setq asp (vlax-get (setq doc (vla-get-activedocument (vlax-get-acad-object)))
                      (cond ((> (vla-get-activespace doc) 0) 'ModelSpace)
                            ('PaperSpace)))
        val 13)
  (while (and (setq poi (getpoint "\nPick diem: "))
              (setq sel (entsel "\nChon doan thang: "))
              (setq ent (car sel))
              (wcmatch (cdr (assoc 0 (entget ent))) "LINE,*POLYLINE")
              (setq par (vlax-curve-getParamAtPoint ent (vlax-curve-getClosestPointTo ent (cadr sel) t)))
              (setq per (inters poi
                                (polar poi
                                       (+ (* 0.5 pi) (angle '(0 0 0) (vlax-curve-getFirstDeriv ent par)))
                                       1.0)
                                (vlax-curve-getPointAtParam ent (fix par))
                                (vlax-curve-getPointAtParam ent (1+ (fix par)))
                                nil))
              (setq dim (vlax-invoke asp 'AddDimAligned poi per poi)))
    (vla-put-TextOverride dim (rtos (- (distance poi per) val) 2 (getvar 'LUPREC))))
  (princ))

 


<<

Filename: 443363_tt.lsp
Tác giả: mr.thanh2610
Bài viết gốc: 443417
Tên lệnh: oa
Lisp rải đối tượng theo đường dẫn của Lee Mac

Thân chào tất cả anh em, em có sưu tầm 1 lisp rất hay của cụ Lee Mac. Nhưng quá trình sử dụng mình thấy Lisp không có chế độ truy bắt điểm (không biết có thể thêm được không, nếu có thì quá tốt), nhờ anh em nào có thể thêm giúp được không ạ, xin chân thành cảm ơn (Em không biết gì về Lisp nên có gì sai sót anh em bỏ qua nhé ).

Liên kết đến Lisp đó đây ạ: 

>>

Thân chào tất cả anh em, em có sưu tầm 1 lisp rất hay của cụ Lee Mac. Nhưng quá trình sử dụng mình thấy Lisp không có chế độ truy bắt điểm (không biết có thể thêm được không, nếu có thì quá tốt), nhờ anh em nào có thể thêm giúp được không ạ, xin chân thành cảm ơn (Em không biết gì về Lisp nên có gì sai sót anh em bỏ qua nhé ).

Liên kết đến Lisp đó đây ạ: http://www.lee-mac.com/objectalign.html

;;--------------------------=={ Object Align }==------------------------;;
;;                                                                      ;;
;;  This program will enable the user to dynamically align a selection  ;;
;;  of objects to a selected curve, with intuitive placement controls.  ;;
;;                                                                      ;;
;;  Upon starting the program with the command syntax 'OA', the user is ;;
;;  prompted to make a selection of objects to be aligned. Following a  ;;
;;  valid selection, the user is prompted to specify a base point to    ;;
;;  use during alignment; at this prompt, the program will use the      ;;
;;  center of the bounding box of the selection of objects by default.  ;;
;;                                                                      ;;
;;  The user is then prompted to select a curve object (this may be a   ;;
;;  Line, Polyline, Arc, Circle, Ellipse, XLine, Spline etc.) to which  ;;
;;  the objects are to be aligned. The selected curve may be a primary  ;;
;;  object, or nested with a Block or XRef to any level. After          ;;
;;  selection, the program offers several controls to aid with object   ;;
;;  placement displayed at the command line:                            ;;
;;                                                                      ;;
;;   for ffset |  for otation | ultiple | <xit>:  ;;
;;                                                                      ;;
;;  The offset of the objects from the curve may be controlled          ;;
;;  incrementally by a tenth of the object height using the '+' / '-'   ;;
;;  keys, or a specific offset may be entered upon pressing the 'O' or  ;;
;;  'o' key.                                                            ;;
;;                                                                      ;;
;;  The set of objects may be rotated anti-clockwise or clockwise by    ;;
;;  45 degrees relative to the curve by pressing the '<' or '>' keys    ;;
;;  respectively; alternatively, the user may enter a specific rotation ;;
;;  by pressing the 'R' or 'r' key.                                     ;;
;;                                                                      ;;
;;  The user may toggle 'Multiple mode' by pressing the 'M' or 'm' key; ;;
;;  when enabled, the user may continuously align multiple copies of    ;;
;;  the selected objects to the selected curve.                         ;;
;;                                                                      ;;
;;  Finally, the user may place the objects and exit the program by     ;;
;;  either clicking the left or right mouse buttons, pressing Enter or  ;;
;;  Space, or by pressing the 'E' or 'e' keys.                          ;;
;;                                                                      ;;
;;  The program should perform successfully in all UCS & Views, and in  ;;
;;  all versions of AutoCAD that have Visual LISP functions available   ;;
;;  (AutoCAD 2000 onwards running on a Windows OS).                     ;;
;;                                                                      ;;
;;----------------------------------------------------------------------;;
;;  Author:  Lee Mac, Copyright © 2010  -  www.lee-mac.com              ;;
;;----------------------------------------------------------------------;;
;;  Version 1.0    -    2010-05-01                                      ;;
;;                                                                      ;;
;;  - First release.                                                    ;;
;;----------------------------------------------------------------------;;
;;  Version 1.1    -    2011-05-07                                      ;;
;;----------------------------------------------------------------------;;
;;  Version 1.2    -    2012-12-11                                      ;;
;;----------------------------------------------------------------------;;
;;  Version 1.3    -    2012-12-14                                      ;;
;;----------------------------------------------------------------------;;
;;  Version 1.4    -    2018-05-06                                      ;;
;;                                                                      ;;
;;  - Program modified to enable compatibility with all UCS & Views.    ;;
;;----------------------------------------------------------------------;;
;;  Version 1.5    -    2019-08-09                                      ;;
;;                                                                      ;;
;;  - Added 'Multiple' mode to allow the user to align multiple copies  ;;
;;    of the selected objects.                                          ;;
;;----------------------------------------------------------------------;;

(defun c:oa

    (
        /
        *error*
        bb1 bb2 blk bnm bpt
        def dis
        ent
        fac
        gr1 gr2
        idx inc
        llp lst
        mat msg
        obj ocs oss
        pi2 pt1 pt2 pt3 pt4
        sel
        tma tmp trm
        urp uxa
        vec 
    )

    (defun *error* ( msg )
        (if (and (= 'list (type trm)) (= 'ename (type ent)) (entget ent))
            (entdel ent)
        )
        (if (and (= 'vla-object (type blk)) (not (vlax-erased-p blk)))
            (vl-catch-all-apply 'vla-delete (list blk))
        )
        (if (and (= 'vla-object (type def)) (not (vlax-erased-p def)))
            (vl-catch-all-apply 'vla-delete (list def))
        )
        (foreach obj lst
            (if (not (vlax-erased-p obj))
                (vl-catch-all-apply 'vla-delete (list obj))
            )
        )
        (oa:endundo (oa:acdoc))
        (if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )
    
    (oa:startundo (oa:acdoc))
    (if (null oa|rot) (setq oa|rot 0.0))
    (if (null oa|off) (setq oa|off 0.0))
    
    (cond
        (   (or (oa:layerlocked (getvar 'clayer))
                (oa:layerlocked "0")
            )
            (princ "\nThe current layer or layer \"0\" is locked - please unlock these layers before using this program.")
        )
        (   (null (setq oss (oa:ssget "\nSelect objects to align: " '("_:L" ((0 . "~VIEWPORT"))))))
            (princ "\n*Cancel*")
        )
        (   (progn
                (setq bpt (getpoint "\nSpecify basepoint <center>: "))
                (while
                    (progn
                        (setvar 'errno 0)
                        (setq sel (nentselp "\nSelect curve to align objects <exit>: "))
                        (cond
                            (   (= 7 (getvar 'errno))
                                (princ "\nMissed, try again.")
                            )
                            (   (= 'ename (type (car sel)))
                                (if
                                    (not
                                        (or (= "VERTEX" (cdr (assoc 0 (entget (car sel)))))
                                            (not (vl-catch-all-error-p (vl-catch-all-apply 'vlax-curve-getendparam (list (car sel)))))
                                        )
                                    )
                                    (princ "\nInvalid object selected.")
                                )
                            )
                        )
                    )
                )
                (while (/= 5 (car (setq pt1 (grread t 13 1)))))
                (null sel)
            )
        )
        (   (not
                (or
                    (and
                        (setq trm (caddr sel))
                        (setq ent (oa:copynested (car sel) trm))
                    )
                    (and
                        (= "VERTEX" (cdr (assoc 0 (entget (car sel)))))
                        (setq ent (cdr (assoc 330 (entget (car sel)))))
                    )
                    (setq ent (car sel))
                )
            )
            (princ "\nUnable to recreate nested entity.")
        )
        (   (progn
                (setq ocs (trans '(0 0 1) 1 0 t)
                      uxa (angle '(0.0 0.0) (trans (getvar 'ucsxdir) 0 ocs t))
                      mat (mxm
                              (list
                                  (list (cos uxa)     (sin uxa) 0.0)
                                  (list (- (sin uxa)) (cos uxa) 0.0)
                                 '(0.0 0.0 1.0)
                              )
                              (mapcar '(lambda ( a ) (trans a ocs 0 t))
                                 '(
                                      (1.0 0.0 0.0)
                                      (0.0 1.0 0.0)
                                      (0.0 0.0 1.0)
                                  )
                              )
                          )
                      vec (mapcar '- (mxv mat (trans '(0.0 0.0 0.0) ocs 0)))
                      tma (vlax-tmatrix (append (mapcar 'append mat (mapcar 'list vec)) '((0.0 0.0 0.0 1.0))))
                )
                (repeat (setq idx (sslength oss))
                    (setq idx (1- idx)
                          obj (vla-copy (vlax-ename->vla-object (ssname oss idx)))
                          lst (cons obj lst)
                    )
                    (vla-transformby obj tma)
                    (if (and (vlax-method-applicable-p obj 'getboundingbox)
                             (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp))))
                        )
                        (setq bb1 (cons (vlax-safearray->list llp) bb1)
                              bb2 (cons (vlax-safearray->list urp) bb2)
                        )
                    )
                    (vla-put-visible obj :vlax-false)
                )
                (not (and bb1 bb2))
            )
            (*error* nil)
            (princ "\nUnable to calculate bounding box for the selection.")
        )
        (   t
            (setq bb1 (apply 'mapcar (cons 'min bb1))
                  bb2 (apply 'mapcar (cons 'max bb2))
                  bpt (cond ( bpt (mapcar '+ (mxv mat (trans bpt 1 0)) vec)) ((mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) bb1 bb2)))
                  fac (/ (- (cadr bb2) (cadr bb1)) 2.0)
                  pi2 (/ pi -2.0)
                  inc 0
            )
            (while (tblsearch "block" (setq bnm (strcat "$tmp" (itoa (setq inc (1+ inc)))))))
            (foreach obj lst (vla-put-visible obj :vlax-true))
            (vla-copyobjects (oa:acdoc)
                (vlax-make-variant
                    (vlax-safearray-fill
                        (vlax-make-safearray vlax-vbobject (cons 0 (1- (length lst))))
                        lst
                    )
                )
                (setq def (vla-add (vla-get-blocks (oa:acdoc)) (vlax-3D-point bpt) bnm))
            )
            (foreach obj lst (vla-delete obj))
            (setq lst nil
                  blk
                (vla-insertblock
                    (vlax-get-property (oa:acdoc) (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
                    (vlax-3D-point (trans (cadr pt1) 1 0))
                    bnm 1.0 1.0 1.0 0.0
                )
            )
            (vla-put-layer  blk "0")
            (vla-put-normal blk (vlax-3D-point ocs))
            (setq msg (princ "\n for ffset |  for otation | ultiple | <xit>: "))

            (while
                (progn
                    (setq gr1 (grread t 15 0)
                          gr2 (cadr gr1)
                          gr1 (car  gr1)
                    )
                    (cond
                        (   (member gr1 '(3 5))
                            (setq pt2 (trans gr2 1 0)
                                  pt1 (vlax-curve-getclosestpointtoprojection ent pt2 ocs)
                                  pt3 (oa:2d (trans pt1 0 ocs))
                                  pt4 (oa:2d (trans pt2 0 ocs))
                            )
                            (if (not (equal pt3 pt4 1e-8))
                                (progn
                                    (setq dis (/ (* fac oa|off) (distance pt3 pt4)))
                                    (vla-put-insertionpoint blk
                                        (vlax-3D-point
                                            (trans
                                                (append
                                                    (mapcar '(lambda ( a b ) (+ a (* (- b a) dis))) pt3 pt4)
                                                    (list (caddr (trans pt1 0 ocs)))
                                                )
                                                ocs 0
                                            )
                                        )
                                    )
                                    (vla-put-rotation blk (+ (angle (trans pt1 0 ocs) (trans gr2 1 ocs)) oa|rot pi2))
                                )
                            )
                            (cond
                                (   (= 5 gr1))
                                (   oa|mtp (vla-explode blk) t)
                            )
                        )
                        (   (= 2 gr1)
                            (cond
                                (   (member gr2 '(043 061))
                                    (setq oa|off (+ oa|off 0.1))
                                )
                                (   (member gr2 '(045 095))
                                    (setq oa|off (- oa|off 0.1))
                                )
                                (   (member gr2 '(044 060))
                                    (setq oa|rot (+ oa|rot (/ pi 4.0)))
                                )
                                (   (member gr2 '(046 062))
                                    (setq oa|rot (- oa|rot (/ pi 4.0)))
                                )
                                (   (member gr2 '(013 032 069 101))
                                    nil
                                )
                                (   (member gr2 '(082 114))
                                    (if (setq tmp (getangle (strcat "\nSpecify Rotation <" (angtos oa|rot) ">: ")))
                                        (setq oa|rot tmp)
                                    )
                                    (princ msg)
                                )
                                (   (member gr2 '(079 111))
                                    (if (setq tmp (getdist (strcat "\nSpecify Offset <" (rtos (* fac oa|off)) ">: ")))
                                        (setq oa|off (/ tmp fac))
                                    )
                                    (princ msg)
                                )
                                (   (member gr2 '(077 109))
                                    (if (setq oa|mtp (not oa|mtp))
                                        (princ "\n<Multiple mode on>")
                                        (princ "\n<Multiple mode off>")
                                    )
                                    (princ msg)
                                )
                                (   t   )
                            )
                        )
                        (   (member gr1 '(011 025))
                            nil
                        )
                        (   t   )
                    )
                )
            )
            (if trm (entdel ent))
            (vla-explode blk)
            (vla-delete  blk)
            (vla-delete  def)
            (oa:endundo (oa:acdoc))
        )
    )
    (princ)
)

;;----------------------------------------------------------------------;;

(defun oa:2d ( x ) (list (car x) (cadr x)))

;;----------------------------------------------------------------------;;

(defun oa:layerlocked ( lay / def )
    (and
        (setq def (tblsearch "layer" lay))
        (= 4 (logand 4 (cdr (assoc 70 def))))
    )
)

;;----------------------------------------------------------------------;;

(defun oa:copynested ( ent mat / enx tmp )
    (if (= 1 (cdr (assoc 66 (setq enx (entget ent)))))
        (progn
            (oa:entmakex enx)
            (setq ent (entnext ent)
                  enx (entget  ent)
            )
            (while (/= "SEQEND" (cdr (assoc 0 enx)))
                (oa:entmakex enx)
                (setq ent (entnext ent)
                      enx (entget  ent)
                )
            )
            (setq tmp (cdr (assoc 330 (entget (oa:entmakex enx)))))
        )
        (setq tmp (oa:entmakex enx))
    )
    (if tmp (vla-transformby (vlax-ename->vla-object tmp) (vlax-tmatrix mat)))
    tmp
)

;;----------------------------------------------------------------------;;

(defun oa:entmakex ( enx )
    (entmakex
        (append
            (vl-remove-if
                (function
                    (lambda ( x )
                        (or (member (car x) '(005 006 008 039 048 062 102 370))
                            (= 'ename (type (cdr x)))
                        )
                    )
                )
                enx
            )
           '(
                (006 . "CONTINUOUS")
                (008 . "0")
                (039 . 0.0)
                (048 . 1.0)
                (062 . 7)
                (370 . 0)
            )
        )
    )
)

;;----------------------------------------------------------------------;;

(defun oa:ssget ( msg arg / sel )
    (princ msg)
    (setvar 'nomutt 1)
    (setq sel (vl-catch-all-apply 'ssget arg))
    (setvar 'nomutt 0)
    (if (not (vl-catch-all-error-p sel)) sel)
)

;;----------------------------------------------------------------------;;

(defun oa:startundo ( doc )
    (oa:endundo doc)
    (vla-startundomark doc)
)

;;----------------------------------------------------------------------;;

(defun oa:endundo ( doc )
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (vla-endundomark doc)
    )
)

;;----------------------------------------------------------------------;;

(defun oa:acdoc nil
    (eval (list 'defun 'oa:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (oa:acdoc)
)

;;----------------------------------------------------------------------;;

;; Matrix Transpose  -  Doug Wilson
;; Args: m - nxn matrix

(defun trp ( m )
    (apply 'mapcar (cons 'list m))
)

;; Matrix x Matrix  -  Vladimir Nesterovsky
;; Args: m,n - nxn matrices

(defun mxm ( m n )
    ((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
)

;; Matrix x Vector  -  Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n

(defun mxv ( m v )
    (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)
    
;;----------------------------------------------------------------------;;

(vl-load-com)
(princ
    (strcat
        "\n:: ObjectAlign.lsp | Version 1.5 | \\U+00A9 Lee Mac "
        (menucmd "m=$(edtime,0,yyyy)")
        " www.lee-mac.com ::"
        "\n:: Type \"oa\" to Invoke ::"
    )
)
(princ)

;;----------------------------------------------------------------------;;
;;                             End of File                              ;;
;;----------------------------------------------------------------------;;

 

ObjectAlignV1-5.lsp


<<

Filename: 443417_oa.lsp
Tác giả: hiepttr
Bài viết gốc: 220633
Tên lệnh: abc
lisp tính ngược giá trị của mắt lưới san nền ?

Em sửa được trong trường hợp có 3 text được chọn thì lisp chạy đúng rồi. Nhưng trong trường hợp 2 text được chọn thì chạy sai, em không...

>>

Em sửa được trong trường hợp có 3 text được chọn thì lisp chạy đúng rồi. Nhưng trong trường hợp 2 text được chọn thì chạy sai, em không hiểu được. hic. Các anh sửa giúp em trường hợp có 2 text được chọn nhé !

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=66427&hl=&fromsearch=1
(defun c:abc(/ e->v ct tm)(vl-load-com)
(setq e->v vlax-ename->vla-object ct (lambda(en)(atof(vla-get-textstring (e->v en))))
tm
((lambda(tl q s n / ss)(- (/ (* (+ 1 n) q) s) tl))
 (apply '+ (mapcar 'ct (acet-ss-to-list (setq ss (ssget (list (cons 0 "*TEXT")))))))
 (ct (car (entsel "\nText khoi luong san nen :")))
 (ct (car (entsel "\nText dien tich :")))
 (sslength ss)
)
)
(vla-put-textstring (e->v (car(entsel "\nText ket qua :"))) tm)
(princ)
)

Mình nghỉ rằng lisp chạy đúng --- còn bạn thì chạy sai.... hic...

Vì khi bạn chia được mảnh đất là tứ giác thì tính khối lượng theo chiều cao đào đắp trung bình sẽ cho kết quả chấp nhận được

Nhưng khi mảnh đất bạn chia ra có hình tam giác thì tính khối lượng theo chiều cao đào đắp trung bình sẽ cho kết quả sai bét


<<

Filename: 220633_abc.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 196227
Tên lệnh: ch
Chỉnh sửa nhanh Scale Hatch, đổi nhanh nhiều góc cho hàng loạt hatch

Chỉnh scale hay chỉnh góc bạn :) ?

 

P/s :

(defun c:ch(/ a c)
(vl-load-com)
(if (and
 (ssget (list (cons 0 "HATCH")))
...
>>

Chỉnh scale hay chỉnh góc bạn :) ?

 

P/s :

(defun c:ch(/ a c)
(vl-load-com)
(if (and
 (ssget (list (cons 0 "HATCH")))
 (setq a (getangle "\nGoc cong them :"))
 (setq c (getreal "\nScale moi :"))
)
(vlax-for object (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object)))
 (if (wcmatch (vla-get-ObjectName object) "AcDbHatch")
  (or
(vla-put-PatternAngle object (+ (vla-get-PatternAngle object) a))
(vla-put-PatternScale object c)
  )
 )
)
)
)

Ket ơi! Chú ý thêm cái (cdr (assoc 70)) nếu bằng 1 nữa!


<<

Filename: 196227_ch.lsp
Tác giả: Nguyen Hoanh
Bài viết gốc: 387804
Tên lệnh: taolayout
Tách Các Bản Vẽ Bên Layout Thành Từng Bản Vẽ Riêng Biệt

Cách của bạn là đúng rồi.

 

Lisp dưới đây hỗ trợ thêm cho bạn các tạo layout nhanh

(defun c:taolayout ( / tiento index newname)
  (setq
    tiento (getstring "\nVao tien to: ")    
    index  1
  )
 
  (repeat (getint "\nSo layout: ")
    (setq
      newname (strcat tiento
              (if (< 10 index)
            (strcat...

>>

Cách của bạn là đúng rồi.

 

Lisp dưới đây hỗ trợ thêm cho bạn các tạo layout nhanh

(defun c:taolayout ( / tiento index newname)
  (setq
    tiento (getstring "\nVao tien to: ")    
    index  1
  )
 
  (repeat (getint "\nSo layout: ")
    (setq
      newname (strcat tiento
              (if (< 10 index)
            (strcat "0" (itoa index))
            (itoa index)
              )
          )
      index   (1+ index)
    )
    (setvar "TILEMODE" 0)
    (command ".LAYOUT" "c" "" newname)    
  )
  (princ)
)


<<

Filename: 387804_taolayout.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 443541
Tên lệnh: te
Tạo lisp thay thế và đánh số thứ tự tăng/giảm của mtext trong multi leader
Vào lúc 1/1/2020 tại 07:22, Nguyên Khải đã nói:
>>
Vào lúc 1/1/2020 tại 07:22, Nguyên Khải đã nói:

 

"k" là trường hợp cụ thể ở bản vẽ của mình, để hay hơn bạn viết code cho trường hợp tổng quát cho kí tự bất kì nhập từ bàn phím mà người dùng muốn thay thế (không phân biệt chữ hoa hay thường)

(Defun c:te (/ x xt xh ss key ent num k n)
(while (or (not x) (= x ""))	(setq x (getstring (strcat "\nNhap ky tu the hien so:"))))
  (setq xt (strcase x T) xh (strcase x nil)) 
  (setq ss (acet-ss-to-list (ssget (list (cons 0 "MULTILEADER") (cons 304 (strcat "*" xt "*,*" xh "*")) ))))
(setq key (keyword (list "Select-Order" "Left-right" "Top-bottom") "Select-Order" "Kieu sap xep?"))
  (if (= key "Left-right")(setq ss (vl-sort ss '(lambda (x y) (< (cadr (assoc 10 (entget x))) (cadr (assoc 10 (entget y))))))))
  (if (= key "Top-bottom")(setq ss (vl-sort ss '(lambda (x y) (> (caddr (assoc 10 (entget x))) (caddr (assoc 10 (entget y))))))))
  
(setq n (getint "\nNhap so bat dau:"))
  (setq k (getint "\nNhap so ky tu muon hien thi:"))
  (if (and ss n k) (progn
(foreach ent ss
  (setq num (itoa n))
  (if (< (strlen num) k) (setq num (repeat (- k (strlen num)) (setq num (strcat "0" num)))) )
(if (vl-string-search xt (dxf 304 ent))
  (vla-put-textstring (vlax-ename->vla-object ent) (vl-string-subst num xt (dxf 304 ent)))
  (vla-put-textstring (vlax-ename->vla-object ent) (vl-string-subst num xh (dxf 304 ent))))
  (setq n (1+ n))
  )
) (alert "Khong du du lieu, ket thuc!")) 
  )
(defun keyword (key default promp / str1 str2 str3 str4)
  (setq str1 (apply 'strcat (mapcar (function (lambda (x) (strcat x " "))) key)))
  (setq str2 (apply 'strcat (mapcar (function (lambda (x) (strcat x "/"))) key)))
  (setq str1 (substr str1 1 (1- (strlen str1))))
  (setq str2 (substr str2 1 (1- (strlen str2))))
  (initget str1)
  (setq str3 (strcat "\n" promp "  <" default "> "))
  (if (not (setq str4 (getkword str3)))
    default
    str4
    )
  )
(defun Dxf (Id Obj)
    (cdr (assoc Id (entget Obj)))
  )

Trường hợp này đánh số theo mình thấy khó khả thi, bởi sau khi đánh 1 lần, nhỡ đâu đánh sai thì lisp không chọn lại được nữa, có lẽ bạn nên thay ký tự số vào đầu hoặc cuối để dễ sửa chữa sau này. 


<<

Filename: 443541_te.lsp
Tác giả: haiduong2105
Bài viết gốc: 49043
Tên lệnh: fixblock
Viết Lisp theo yêu cầu
Gửi bạn LISP tui sưu tầm : có thể chuyển các đối tượng trong BLOCK về Layer 0 và color+linetype về BYLOCK.

các thuộc tính : Text Style, Dim Style ... thì "pó...

>>
Gửi bạn LISP tui sưu tầm : có thể chuyển các đối tượng trong BLOCK về Layer 0 và color+linetype về BYLOCK.

các thuộc tính : Text Style, Dim Style ... thì "pó tay".

 

tên lệnh : FIXBLOCK

(defun d_FixBlock (/             eBlockSel ; Block selection
                  lInsertData ; Entity data
                  sBlockName ; Block name
                  lBlockData ; Entity data
                  eSubEntity ; Sub-entity name
                  lSubData ; Sub-entity data
                  iCount ; Counter
                 )

 ;; Redefine error handler

 (setq
   d_#error *error*
   *error*  d_FB_Error
 ) ;_ end setq

 ;; Set up environment

 (setq #SYSVARS (#SaveSysVars (list "cmdecho")))

 (setvar "cmdecho" 0)
 (command "._undo" "_group")

 ;; Get block from user and make sure it's an INSERT type

 (if (setq eBlockSel (entsel "\nSelect block to change :"))
   (progn
     (if (setq lInsertData (entget (car eBlockSel)))
       (if (= (cdr (assoc 0 lInsertData)) "INSERT")
         (setq sBlockName (cdr (assoc 2 lInsertData)))
         (progn
           (alert "Entity selected is not a block!")
           (exit)
         ) ;_ end progn
       ) ;_ end if
       (progn
         (alert "Invalid Block Selection!")
         (exit)
       ) ;_ end progn
     ) ;_ end if

     ;; Get block info from the block table

     (setq
       lBlockData (tblsearch "BLOCK" sBlockName)
       eSubEntity (cdr (assoc -2 lBlockData))
     ) ;_ end setq

     ;; Make sure block is not an Xref

     (if (not (assoc 1 lBlockData))
       (progn
         (princ "\nProcessing block: ")
         (princ sBlockName)

         (princ "\nUpdating blocks sub-entities. . .")

         ;; Parse through all of the blocks sub-entities

         (while eSubEntity

           (princ " .")
           (setq lSubData (entget eSubEntity))

           ;; Update layer property

           (if (assoc 8 lSubData)
             (progn
               (setq lSubData
                      (subst
                        (cons 8 "0")
                        (assoc 8 lSubData)
                        lSubData
                      ) ;_ end subst
               ) ;_ end setq
               (entmod lSubData)
             ) ;_ end progn
           ) ;_ end if

           ;; Update the linetype property

           (if (assoc 6 lSubData)
             (progn
               (setq lSubData
                      (subst
                        (cons 6 "BYBLOCK")
                        (assoc 6 lSubData)
                        lSubData
                      ) ;_ end subst
               ) ;_ end setq
               (entmod lSubData)
             ) ;_ end progn
             (entmod (append lSubData (list (cons 6 "BYBLOCK"))))
           ) ;_ end if

           ;; Update the color property

           (if (assoc 62 lSubData)
             (progn
               (setq lSubData
                      (subst
                        (cons 62 0)
                        (assoc 62 lSubData)
                        lSubData
                      ) ;_ end subst
               ) ;_ end setq
               (entmod lSubData)
             ) ;_ end progn
             (entmod (append lSubData (list (cons 62 0))))
           ) ;_ end if

           (setq eSubEntity (entnext eSubEntity))
   ; get next sub entity

         ) ; end while

         ;; Update attributes

         (idc_FB_UpdAttribs)

       ) ; end progn
       (alert "XREF selected. Not updated!")
     ) ; end if
   ) ; end progn
   (alert "Nothing selected.")
 ) ; end if

;;; Pop error stack and reset environment

 (idc_RestoreSysVars)

 (princ "\nDone!")

 (setq *error* d_#error)

 (princ)

)   ; end defun

   ;*******************************************************************************

   ; Function to update block attributes
   ;*******************************************************************************

(defun idc_FB_UpdAttribs ()

 ;; Update any attribute definitions

 (setq iCount 0)

 (princ "\nUpdating attributes. . .")
 (if (setq ssInserts (ssget "x"
                            (list (cons 0 "INSERT")
                                  (cons 66 1)
                                  (cons 2 sBlockName)
                            ) ;_ end list
                     ) ;_ end ssget
     ) ;_ end setq
   (repeat (sslength ssInserts)

     (setq eBlockName (ssname ssInserts iCount))

     (if (setq eSubEntity (entnext eBlockName))
       (setq
         lSubData (entget eSubEntity)
         eSubType (cdr (assoc 0 lSubData))
       ) ;_ end setq
     ) ;_ end if

     (while (or (= eSubType "ATTRIB") (= eSubType "SEQEND"))

       ;; Update layer property

       (if (assoc 8 lSubData)
         (progn
           (setq lSubData
                  (subst
                    (cons 8 "0")
                    (assoc 8 lSubData)
                    lSubData
                  ) ;_ end subst
           ) ;_ end setq
           (entmod lSubData)
         ) ;_ end progn
       ) ;_ end if

       ;; Update the linetype property

       (if (assoc 6 lSubData)
         (progn
           (setq lSubData
                  (subst
                    (cons 6 "BYBLOCK")
                    (assoc 6 lSubData)
                    lSubData
                  ) ;_ end subst
           ) ;_ end setq
           (entmod lSubData)
         ) ;_ end progn
         (entmod (append lSubData (list (cons 6 "BYBLOCK"))))
       ) ;_ end if

       ;; Update the color property

       (if (assoc 62 lSubData)
         (progn
           (setq lSubData
                  (subst
                    (cons 62 0)
                    (assoc 62 lSubData)
                    lSubData
                  ) ;_ end subst
           ) ;_ end setq
           (entmod lSubData)
         ) ;_ end progn
         (entmod (append lSubData (list (cons 62 0))))
       ) ;_ end if

       (if (setq eSubEntity (entnext eSubEntity))
         (setq
           lSubData (entget eSubEntity)
           eSubType (cdr (assoc 0 lSubData))
         ) ;_ end setq
         (setq eSubType nil)
       ) ;_ end if

     ) ; end while

     (setq iCount (1+ iCount))

   ) ; end repeat

 ) ; end if
 (command "regen")
)   ; end defun

   ;*******************************************************************************

   ; Function to save a list of system variables
   ;*******************************************************************************

(defun #SaveSysVars (lVarList / sSystemVar)
 (mapcar
   '(lambda (sSystemVar)
      (setq lSystemVars
             (append lSystemVars
                     (list (list sSystemVar (getvar sSystemVar)))
             ) ;_ end append
      ) ;_ end setq
    ) ;_ end lambda
   lVarList
 ) ;_ end mapcar

 lSystemVars

) ;_ end defun
   ;*******************************************************************************

   ; Function to restore a list of system variables
   ;*******************************************************************************

(defun idc_RestoreSysVars ()
 (mapcar
   '(lambda (sSystemVar)
      (setvar (car sSystemVar) (cadr sSystemVar))
    ) ;_ end lambda
   #SYSVARS
 ) ;_ end mapcar
) ;_ end defun
   ;*******************************************************************************

   ; Error Handler
   ;*******************************************************************************

(defun d_FB_Error (msg)

 (princ "\nError occurred in the Fix Block routine...")
 (princ "\nError: ")
 (princ msg)

 (setq *error* d_#error)
 (if *error*
   (*error* msg)
 ) ;_ end if

 (command)

 (if (/= msg "quit / exit abort")
   (progn
     (command "._undo" "_end")
     (command "._u")
   ) ;_ end progn
 ) ;_ end if

 (idc_RestoreSysVars)

 (princ)

) ;_ end defun
   ;*******************************************************************************

(defun C:FIXBLOCK () (d_FixBlock))
(princ)

 

 

Chào các Bác em là lính mới thấy cái fixblock này hay nhưng có cái là không chọn được nhiều Block cùng 1 lúc, các bác viết hoàn thiện để chọn được nhiều block với


<<

Filename: 49043_fixblock.lsp
Tác giả: Phiphi-
Bài viết gốc: 49241
Tên lệnh: p2t
Viết Lisp theo yêu cầu

Chưa có ai giúp chắc vì còn Tết.

Lisp num.lsp này cho phép đánh cả Chử + Số +Chử (TD: X1a, X2a, X3a...)

Nếu thêm được vào option để cho phép đánh theo cấp số nhân thì hay hơn (TD: +5m, +10m, +15m...)

Lệnh NUM

;; =============================================================	;;
;;                                              ...
>>

Chưa có ai giúp chắc vì còn Tết.

Lisp num.lsp này cho phép đánh cả Chử + Số +Chử (TD: X1a, X2a, X3a...)

Nếu thêm được vào option để cho phép đánh theo cấp số nhân thì hay hơn (TD: +5m, +10m, +15m...)

Lệnh NUM

;; =============================================================	;;
;;                                                               	;;
;;  NUM.LSP - This program for fast dynamic numbering. To number a 	;;
;;             suffix and a prefix can be added.     			;;
;;                                                               	;;
;; ==================================================================== ;;
;;                                                               	;;
;;  Command(s) to call: NUM                                    		;;
;;                                                               	;;
;;  Specify the text size, a suffix, a prefix and starting number   	;;
;;  (for erase the old suffix or prefix you should press Spacebar).	;;
;;  Insert a numbers or press Esc to quit. The program remembers old	;;
;;  properties and it is possible to confirm it pressing of Spacebar	;;
;;  key.								;;
;;                                                               	;;
;; ====================================================================	;;
;;                                                               	;;
;;  THIS PROGRAM AND PARTS OF IT MAY REPRODUCED BY ANY METHOD ON ANY   	;;
;;  MEDIUM FOR ANY REASON. YOU CAN USE OR MODIFY THIS PROGRAM OR  	;;
;;  PARTS OF IT ABSOLUTELY FREE.                 			;;
;;                                                               	;;
;;  THIS PROGRAM PROVIDES THIS PROGRAM 'AS IS' WITH ALL FAULTS AND  	;;
;;  SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF MERCHANTABILITY     	;;
;;  OR FITNESS FOR A PARTICULAR USE.             			;;
;;                                                               	;;
;; ====================================================================	;;
;;                                                               	;;
;;  V1.3, 12 May, 2005, Riga, Latvia                                  	;;
;;  © Aleksandr Smirnov (ASMI)                          	   	;;
;;  For AutoCAD 2000 - 2008 (isn't tested in a next versions)		;;
;;                                                               	;;
;;                                      http://www.asmitools.com   	;;
;;								 	;;
;; ====================================================================	;;


(defun c:num (/ oldPref oldSuf oldStart curStr newNum 
               actDoc actSp oldEcho oldSize *error*) 

 (defun *error* (msg) 
   (setvar "CMDECHO" oldEcho) 
   (princ) 
   ); end *error* 

 (vl-load-com) 
 (if(not num:Size)(setq num:Size(getvar "DIMTXT"))) 
 (if(not num:Pref)(setq num:Pref "")) 
 (if(not num:Suf)(setq num:Suf "")) 
 (if(not num:Num)(setq num:Num 1)) 
 (setq oldPref num:Pref 
       oldSuf num:Suf 
       oldStart num:Num 
       oldSize num:Size 
       actDoc(vla-get-ActiveDocument 
               (vlax-get-acad-object)) 
       oldEcho(getvar "CMDECHO") 
  ); end setq 
 (setvar "CMDECHO" 0) 
 (if(=(vla-get-ActiveSpace actDoc)1) 
        (setq actSp(vla-get-ModelSpace actDoc)) 
        (setq actSp(vla-get-PaperSpace actDoc)) 
   ); end if
 (setq num:Size 
   (getreal 
     (strcat "\nText size <"(rtos num:Size)">: "))) 
 (if(null num:Size)(setq num:Size oldSize)) 
 (setq num:Pref 
   (getstring T 
     (strcat "\nPrefix: <"num:Pref">: "))) 
 (if(= "" num:Pref)(setq num:Pref oldPref)) 
 (if(= " " num:Pref)(setq num:Pref "")) 
 (setq num:Suf 
   (getstring T 
     (strcat "\nSuffix: <"num:Suf">: "))) 
 (if(= "" num:Suf)(setq num:Suf oldSuf)) 
 (if(= " " num:Suf)(setq num:Suf "")) 
 (setq num:Num 
   (getint 
     (strcat "\nStarting number <"(itoa num:Num)">: "))) 
 (if(null num:Num)(setq num:Num oldStart))
 (princ "\n<<< Insert numbers or press Esc to quit >>> ")
     (while T 
       (setq curStr(strcat num:Pref(itoa num:Num)num:Suf) 
             newNum(vla-AddText actSp 
             curStr (vlax-3d-point '(0.0 0.0 0.0)) num:Size)) 
       (vla-put-Alignment newNum acAlignmentMiddleCenter) 
       (command "_.copybase"(trans '(0.0 0.0 0.0)0 1)(entlast)"") 
       (command "_.erase" (entlast) "") 
       (command "_.pasteclip" pause) 
       (setq num:Num(1+ num:Num)) 
      ); end while 
 (princ) 
); end of c:num

(princ "\n*** Dynamic numbering tool. Type NUM to run.*** ")

... nhưng phải select từng point, không được như P2T.lsp

LISP P2T.lsp của CADViet chỉ đánh Số thứ tự từ Trái qua Phải và Trên xuống Duới. Nhờ các Bác bổ sung thêm các options để:

+ Cho phép đánh cả Chử + Số +Chử (TD: X1a, X2a, X3a...)

+ Theo hướng user chọn

+ Dọc theo Line/Pline đi qua các points.

Thanks you.

(defun c:P2T (/ sst lstent pp p soht strht)
(defun ss2ent (ss / sodt index lstent)
(princ "\nCADViet.com © 2007")
(setq
sodt (cond
(ss (sslength ss))
(t 0)
)
index 0
)
(repeat sodt
(setq ent (ssname ss index)
index (1+ index)
lstent (cons ent lstent)
)
)
(reverse lstent)
)
(defun getp (ent)
(cdr (assoc 10 (entget ent)))
)
(defun sosanh (ent1 ent2 / p1 p2 x1 y1 x2 y2)
(setq
p1 (getp ent1)
x1 (car p1)
y1 (cadr p1)
p2 (getp ent2)
x2 (car p2)
y2 (cadr p2)
)
(or (< x1 x2)
(and (= x1 x2) (< y1 y2))
)
)

;;------------- Main -------------------------------
(princ "\nPoint to Text © 2007 CADViet.com")
(setq
sst (ssget '((0 . "POINT")))
caochu (getdist "\nVao chieu cao text: ")
soht (1- (getint "\nVao so bat dau danh: "))
lstent (vl-sort (ss2ent sst) 'sosanh)
)
(foreach pp lstent
(setq
soht (1+ soht)
strht (itoa soht)
p (getp pp)
)
(entmake
(list
(cons 0 "TEXT")
(cons 10 P)
(cons 40 caochu)
(cons 1 strht)
)
)
)
(princ)
)
(princ "\nSu dung lenh P2T bat dau")
(princ "\nfree lisp from www.cadviet.com")
(princ)


<<

Filename: 49241_p2t.lsp
Tác giả: NguyenNgocSon
Bài viết gốc: 158375
Tên lệnh: cs
Lisp cộng - trừ - nhân - chia 2 hàng số cho ra hàng thứ 3

Ngoài các tính năng đã viết ở trên

Tue_NV Cập nhật Lại Lisp :

(defun c:cs(/ ss...
>>

Ngoài các tính năng đã viết ở trên

Tue_NV Cập nhật Lại Lisp :

(defun c:cs(/ ss sx ss3 lis1 lis2 lis3 en1 en2 n i ii ptkq nn mm li li1 stp ctnc ctnch shang oldlu)
;Copy right by Tue_NV
(setq ctnc (cond (ctnc) ("+")))  
(initget "+ - * /")
(setq ctnc (cond ((getkword (strcat "\nChon phep tinh:  <" ctnc ">"))) (ctnc)))
(cond ((= ctnc "+") (setq ctnch + shang 0.0))
     ((= ctnc "-") (setq ctnch - shang 0.0))
     ((= ctnc "*") (setq ctnch * shang 1.0))
     ((= ctnc "/") (setq ctnch / shang 1.0))
)

Đoạn mã trên có phải nhớ phép tính sau mỗi lần tính ?

Nếu như vậy sao mình thực hiện lisp không nhớ phép tính nhỉ?

Cám ơn Tue_NV!


<<

Filename: 158375_cs.lsp
Tác giả: vantran
Bài viết gốc: 109857
Tên lệnh: isb
thay thế các đường tròn bằng block
Của bạn đây. Đúng ý bạn rồi nhé. Chọn đường chòn trước rồi chọn block muốn chèn.

;; free lisp from cadviet.com
(defun BatDauVe() (setq...
>>
Của bạn đây. Đúng ý bạn rồi nhé. Chọn đường chòn trước rồi chọn block muốn chèn.

;; free lisp from cadviet.com
(defun BatDauVe() (setq OldOs (getvar "osmode")) (setvar "osmode" 0))
(defun KetThucVe() (setvar "osmode" OldOs) (princ))
(defun c:isb (/ cir i OldOs tam)
(BatDauVe)
(setq i 0)
(princ "\nchon cuong chon muon insert")
(setq ss (ssget '((0 . "*CIRCLE"))))
(setq ten (cdr (assoc 2 (entget (car (entsel "chon block muon chen")))))
)
     (while (< i (sslength ss))
  (setq cir (ssname ss i))
  (setq tam (cdr (assoc 10 (entget cir))))
 (command "-INSERT" ten tam "" "" "")
 (setq i (1+ i))
);_ end while
(KetThucVe)
);_ end defun

một lần nữa xin cảm ơn các bạn. vì mình là dân khảo sát nên việc sử dụng cad cũng là những lệnh cơ bản thôi nên còn hạn chế lắm. hy vọng sẽ học hỏi thêm được nhiều


<<

Filename: 109857_isb.lsp
Tác giả: gia_bach
Bài viết gốc: 443586
Tên lệnh: eraseblock
Xóa đối tượng nằm trên layout khác
2 giờ trước, nikizi đã nói:

 

 

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

 

 

@Doan Van Ha Em đã tham khảo link anh gửi nhưng em còn thắc mắc, mong anh giải đáp.

Hiện em đã có lisp copy đối tượng từ layout hiện hành sang tất cả các layout.

Code lisp:

  • ctl.lsp
    lisp help
  •  

(defun c:CTL (/ *error* ss)
(princ "\rCOPYTOLAYOUTS ")
(vl-load-com)
 
(defun *error* (msg)
(if acDoc (vla-endundomark acDoc))
(cond ((not msg)) ; Normal exit
((member msg '("Function cancelled" "quit / exit abort"))) ; <esc> or (quit)
((princ (strcat "\n** Error: " msg " ** ")))) ; Fatal error, display it
(princ))
 
(prompt "\nSelect objects to copy to layouts: ")
(if (setq ss (ssget "_:L"))
((lambda (acDoc / oItemList oCurLayout)
(vla-startundomark acDoc)
(vlax-for oItem (setq ss (vla-get-activeselectionset acDoc))
(setq oItemList (cons oItem oItemList)))
(vlax-for oLayout (vla-get-layouts acDoc)
(if (and (/= (cond
(oCurLayout)
((setq oCurLayout (vla-get-activeLayout acDoc))))
oLayout)
(/= "Model" (vla-get-name oLayout)))
(vlax-invoke
acDoc
"copyobjects"
oItemList
(vla-get-block oLayout))))
(vla-delete ss)
(*error* nil))
(vla-get-activedocument (vlax-get-acad-object)))
(prompt "\n** Nothing selected ** "))
(princ))

Em muốn tìm lisp để xóa đối tượng ở cùng một vị trí (tọa độ) trong tất cả các lay out (Ví dụ: Block khung tên, ghi chú,...) nhưng em tham khảo trên mạng không có lisp như vậy.

Nếu thay đổi chức năng copy trong lisp như trên thành delete thì có được không ạ?

Anh có thể hướng dẫn chi tiết thêm được không ? Em cám ơn anh.

Tham khảo lisp xóa tất cả block có điểm chèn tại (0 , 0 0) trong tất cả layout.

(defun c:eraseBlock (/ pt )
  (setq pt (list 0 0 0))
  (vlax-for lay (vla-get-layouts (vla-get-activedocument (vlax-get-acad-object)))
    (vlax-for obj (vla-get-block lay)
      (if (= (vla-get-Objectname obj) "AcDbBlockReference"   )
	(if (< (distance pt (vlax-safearray->list (variant-value(vla-get-InsertionPoint obj)))) 0.00001)
	     (vla-erase obj)
	  )
	)
      )
    )
(princ))

 


<<

Filename: 443586_eraseblock.lsp
Tác giả: nikizi
Bài viết gốc: 443579
Tên lệnh: ctl
Xóa đối tượng nằm trên layout khác
Vào lúc 21/8/2013 tại 10:32, Polyline đã nói:

Mình có thể tạo một...

>>
Vào lúc 21/8/2013 tại 10:32, Polyline đã nói:

Mình có thể tạo một tập đối tượng bằng hàm (ssget chứa các đối tượng trên tất cả các Layout.

Tuy nhiên lệnh Erase chỉ cho phép xóa đối tượng trên Layout hiện hành. Hàm (entdel cũng vậy.

 

Như vậy, làm thế nào để xóa tất cả các đối tượng trong một tập chọn bao gồm nhiều đối tượng nằm trên nhiều layout khác nhau?

 

Vào lúc 21/8/2013 tại 11:22, Doan Van Ha đã nói:

 

@Doan Van Ha Em đã tham khảo link anh gửi nhưng em còn thắc mắc, mong anh giải đáp.

Hiện em đã có lisp copy đối tượng từ layout hiện hành sang tất cả các layout.

Code lisp:

(defun c:CTL (/ *error* ss)
(princ "\rCOPYTOLAYOUTS ")
(vl-load-com)
 
(defun *error* (msg)
(if acDoc (vla-endundomark acDoc))
(cond ((not msg)) ; Normal exit
((member msg '("Function cancelled" "quit / exit abort"))) ; <esc> or (quit)
((princ (strcat "\n** Error: " msg " ** ")))) ; Fatal error, display it
(princ))
 
(prompt "\nSelect objects to copy to layouts: ")
(if (setq ss (ssget "_:L"))
((lambda (acDoc / oItemList oCurLayout)
(vla-startundomark acDoc)
(vlax-for oItem (setq ss (vla-get-activeselectionset acDoc))
(setq oItemList (cons oItem oItemList)))
(vlax-for oLayout (vla-get-layouts acDoc)
(if (and (/= (cond
(oCurLayout)
((setq oCurLayout (vla-get-activeLayout acDoc))))
oLayout)
(/= "Model" (vla-get-name oLayout)))
(vlax-invoke
acDoc
"copyobjects"
oItemList
(vla-get-block oLayout))))
(vla-delete ss)
(*error* nil))
(vla-get-activedocument (vlax-get-acad-object)))
(prompt "\n** Nothing selected ** "))
(princ))

Em muốn tìm lisp để xóa đối tượng ở cùng một vị trí (tọa độ) trong tất cả các lay out (Ví dụ: Block khung tên, ghi chú,...) nhưng em tham khảo trên mạng không có lisp như vậy.

Nếu thay đổi chức năng copy trong lisp như trên thành delete thì có được không ạ?

Anh có thể hướng dẫn chi tiết thêm được không ? Em cám ơn anh.


<<

Filename: 443579_ctl.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 443639
Tên lệnh: cg
Xin giúp đỡ hoàn thiện Lisp

Ý tưởng khá hay, quick code cho bạn:

CG- enter: COPY

CG-Enter - Enter: Paste.

(defun c:cg (/ ss str pt lst_str )
  (if 
>>

Ý tưởng khá hay, quick code cho bạn:

CG- enter: COPY

CG-Enter - Enter: Paste.

(defun c:cg (/ ss str pt lst_str )
  (if (and (setq ss (ssget))
	   (setq str (getstring T "Nhap ten tap chon:"))
	   (setq pt (getpoint "Pick basepoint:"))
	   ) (progn
	  (setq lst_chon (append lst_chon (list (list str ss pt))))
	  )(progn
(if lst_chon (progn
	   (setq lst_str (list))
	   (foreach str lst_chon
	     (setq lst_str (append lst_str (list (car str)))))
(if 	 (setq tapchon (LM:listbox "Ch\U+1ECDn ten tap chon" lst_str 0)) (progn
									   
	(setq ss (cadr (assoc (car tapchon) lst_chon))
	      pt (caddr (assoc (car tapchon) lst_chon)))
	(Command "COPY" ss "" "_non" pt pause)))
	   ))
))
  )
(defun LM:listbox (msg lst bit / dch des tmp rtn)
  (cond
     ((not
         (and
            (setq tmp (vl-filename-mktemp nil nil ".dcl"))
            (setq des (open tmp "w"))
            (write-line
               (strcat "listbox:dialog{label=\""
                       msg
                       "\";spacer;:list_box{key=\"list\";multiple_select="
                       (if (= 1 (logand 1 bit))
                          "true"
                          "false"
                       )
                       ";width=50;height=15;}spacer;ok_cancel;}"
               )
               des
            )
            (not (close des))
            (< 0 (setq dch (load_dialog tmp)))
            (new_dialog "listbox" dch)
         )
      )
      (prompt "\nError Loading List Box Dialog.")
     )
     (t
      (start_list "list")
      (foreach itm lst (add_list itm))
      (end_list)
      (setq rtn (set_tile "list" "0"))
      (action_tile "list" "(setq rtn $value)")
      (setq rtn
              (if (= 1 (start_dialog))
                 (if (= 2 (logand 2 bit))
                    (read (strcat "(" rtn ")"))
                    (mapcar '(lambda (x) (nth x lst)) (read (strcat "(" rtn ")")))
                 )
              )
      )
     )
  )
  (if (< 0 dch)
     (unload_dialog dch)
  )
  (if (and tmp (setq tmp (findfile tmp)))
     (vl-file-delete tmp)
  )
  rtn
)

 


<<

Filename: 443639_cg.lsp

Trang 306/330

306