1 giờ} trướ}c, Doan Van Ha đã nói:

Cách bá đạo là: bạn cứ...

>>

1 giờ} trướ}c, Doan Van Ha đã nói:

Cách bá đạo là: bạn cứ add bằng cad rồi sau đó lấy entget rồi tìm cách xử bằng entmod.

(defun c:adt ()
  (setvar "cmdecho" 0)
  (progn
    (setq lst
       (entget
         (car (entsel
            "\nCHON MTEXT CAN ADD GIA TRI: "
          )
         )
       )
    )
    (setq olditem (assoc 1 lst))
    (setq EL (strcat "\\P" (Rtos 2.39 2 2)))
    (setq newitem (subst (list 1 (car olditem) (cadr olditem) EL)
             olditem
             lst
          )
    )
    (entmod lst)
  )
  (setvar "cmdecho" 1)
  (princ)
)

 

Nhờ Bác @Doan Van Ha  Thông Não giúp cháu. Cháu đã thử nhưng trình độ còn non.

<<

Tưởng bạn làm số lượng ít và rời rac, chứ nhiều như vậy thì dù có lisp mà cứ quét 4 cái như trên thấy cũng khá là vất...

>>

Tưởng bạn làm số lượng ít và rời rac, chứ nhiều như vậy thì dù có lisp mà cứ quét 4 cái như trên thấy cũng khá là vất vả.

Thôi làm "rướn" thêm cho bạn cái này, bạn có thể chọn nhiều hàng nhiều cột 1 lúc, cái nào không ok thì sẽ chuyển màu đỏ và có ghi độ vênh. Khi chọn đừng chọn text trùng lên nhau.

Và điều quan trọng là các hàng đều nằm ngang giống file bạn đưa chứ không xiên xéo.

 

(defun test(l / canhngan caodo kq)     
  (setq canhngan (min (distance (caar l) (car (nth 1 l)))
     (distance (caar l) (car (nth 2 l))))       
caodo (mapcar '(lambda(x) (atof (cdr (assoc 1 (entget (last x)))))) l))
  
  (if (> (setq kq (/ (abs (- (+ (nth 0 caodo) (nth 3 caodo))
   (+ (nth 1 caodo) (nth 2 caodo)))) canhngan 1.0)) 0.01)
    (progn 
      (mapcar '(lambda(x) (command "change" (last x) "" "P" "c" "1" "")) l)
      (princ (strcat "\nDo venh " (rtos kq) " > 1%"))
    )
  )
  (princ)  
)
 
(defun c:test(/ tm0 tm tm1 cao n m hang cot a b)
  (setvar 'cmdecho 0)
  (prompt "\nChon text :")
  (setq tm0 (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "TEXT"))))))
tm0 (mapcar '(lambda(x) (list (cdr (assoc 10 (entget x))) x)) tm0)
tm0 (vl-sort tm0 '(lambda(x y) (< (cadar x) (cadar y))))
cao (cdr (assoc 40 (entget (last (car tm0)))))
tm nil
  )
  (while tm0
    (setq tm1 (vl-sort (vl-remove-if-not
'(lambda(x) (equal (cadr (caar tm0)) (cadar x) cao)) tm0)
    '(lambda (x y) (< (caar x) (caar y)) )) 
 tm0 (vl-remove-if
'(lambda(x) (equal (cadr (caar tm0)) (cadar x) cao)) tm0)
 tm (append tm (list tm1))
    )
  )
  (setq m -1
hang (length tm)
cot (length (car tm)))
  (repeat (1- hang)
      (setq n -1
   m (1+ m)
   a (nth m tm)
   b (nth (1+ m) tm))
      (repeat (1- cot)
        (setq n (1+ n))
(test (list (nth n a) (nth (1+ n) a) (nth n b) (nth (1+ n) b)))
      )
  )
  (setvar 'cmdecho 1)
  (princ)
)

Làm cả mặt bằng không vất đâu, công việc hàng ngày của bọn mình là làm lưới cao độ mà. Từ lưới này, nhà thầu thi công sẽ đưa ra thực tế. Đó là mặt bằng đường sân bay nên cần chính xác từng mắt lưới một. Ngoài cao độ còn tính khối lượng, diện tích trên từng ô vuông.

Cảm ơn bạn đã giúp! Chúc bạn ngày mới làm việc hiệu quả!

<<

Test thử lệnh cal thây có Hàm nor cũng vui nên thử viết lisp chuyển 3dpolyline thành lwpoline.

(defun c:test(/ en lp a210 a70 p1 p2 p3)
  (setq en (car(entsel "select 3d polyline"))
	lp (acet-geom-vertex-list en))
  (mapcar 'set '(p1 p2 p3) lp)
  (setq a210 (cal "nor(p1,p2,p3)"))
  (if (eq (car lp) (last lp))
    (setq a70 1
	  lp (reverse (cdr (reverse lp))))
    (setq a70 0))
  (setq lp...
>>

Test thử lệnh cal thây có Hàm nor cũng vui nên thử viết lisp chuyển 3dpolyline thành lwpoline.

(defun c:test(/ en lp a210 a70 p1 p2 p3)
  (setq en (car(entsel "select 3d polyline"))
	lp (acet-geom-vertex-list en))
  (mapcar 'set '(p1 p2 p3) lp)
  (setq a210 (cal "nor(p1,p2,p3)"))
  (if (eq (car lp) (last lp))
    (setq a70 1
	  lp (reverse (cdr (reverse lp))))
    (setq a70 0))
  (setq lp (mapcar '(lambda(x) (trans x 0 a210)) lp))
	
  (entmakex (append
	      (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline")
		    (cons 38 (caddar lp)) (cons 90 (length lp)) (cons 70 a70))
	      (mapcar '(lambda(x) (list 10 (car x) (cadr x))) lp)
	      (list (cons 210 a210))))
  (princ))

Viết sơ đơn giản nên không kiễm tra đấu vào và yêu cầu 3 điểm đấu tiên của 3dpolyline phải không thăng hàng.

Chưa kiểm tra đồng phẳng của 3d polyline (Kiềm tra lại z của các đinh sau khi trans.)

Lệnh cal nor sẽ tính pháp vector làm assoc 210. Bình thường nếu không dùng lệnh cal nor này thì có thể dùng lisp của leemac để tính.

https://www.cadtutor.net/forum/topic/24823-3-3d-point-to-ucs-extrusion-direction/

Xin cám ơn tất cả mọi người đã đọc và đóng góp ý kiến cho chủ đề này, nói chung là các code-Lisp đều chạy tốt trên AutoCAD.

Tuy nhiên do cá nhân tôi, từ khi viết tool cho nhiều nền tảng khác AutoCAD (vd: ZwCAD, BricsCad, IntelliCAD...) tôi thường có thói quen chỉ sử dụng các hàm thuần AutoLISP, hạn chế sử dụng các hàm built-in của AutoCAD như Express-tool (acet-*) hay VisualLISP (vla-*) khi...

Xin cám ơn tất cả mọi người đã đọc và đóng góp ý kiến cho chủ đề này, nói chung là các code-Lisp đều chạy tốt trên AutoCAD.

Tuy nhiên do cá nhân tôi, từ khi viết tool cho nhiều nền tảng khác AutoCAD (vd: ZwCAD, BricsCad, IntelliCAD...) tôi thường có thói quen chỉ sử dụng các hàm thuần AutoLISP, hạn chế sử dụng các hàm built-in của AutoCAD như Express-tool (acet-*) hay VisualLISP (vla-*) khi có thể. Dĩ nhiên nếu không có cách khác thì phải sử dụng các hàm built-in thôi.

Nếu chỉ dùng AutoCAD thì việc sử dụng các hàm này sẽ tiết kiệm rất nhiều thời gian và công sức, đạt hiệu suất cao vì đã được tối ưu cho AutoCAD. Và mục đích chính là làm cho AutoCAD phục vụ mình nhanh hơn, diệu kỳ hơn ... đã đạt được.

Nhưng trong trường hợp phài sử dụng các phần mềm CAD khác (vì lý do bản quyền, chi phí đầu tư ...)  thì sẽ gặp khá nhiều khó khăn khi chuyển đổi, tính tương thích không cao (các CAD khác không hỗ trợ hoặc hỗ trợ rất kém các hàm này). Nếu muốn viết lại hàm thì không có công thức/thuật toán để chuyển đổi.

Trên cơ sở các lisp của mọi người, xin cập nhật và hiệu chỉnh để có thể chạy với các CAD khác.

;; CrossProduct (Gile)
;; Returns the cross product (vector) of two vectors
;;
;; Arguments: two vectors
(defun CrossProduct (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)))
 )
)

;; Normalize (Gile)
;; Returns the single unit vector of a vector
;;
;; Argument : a vector
(defun Normalize (v)
 ((lambda (l)
    (if (/= 0 l)
      (mapcar (function (lambda (x) (/ x l))) v)
    )
  )
   (distance '(0 0 0) v)
 )
)

;; Norm_3Points (Gile)
;; Returns the single unit normal vector of a plane definedby 3 points
;;
;; Arguments: three points
(defun norm_3pts (p0 p1 p2)
 (Normalize (CrossProduct (mapcar '- p1 p0) (mapcar '- p2 p0)))
)

;; Collinearity check (Lee Mac)
(defun isCollinear ( p1 p2 p3 fz )
 (equal (rem (angle p1 p2) pi) (rem (angle p2 p3) pi) fz)
)

(defun c:test(/ lp p1 p2 p3 a210)
  (if
    (and
       (setq p1 (getpoint "\nChon diem 1"))
       (setq p2 (getpoint p1 "\nChon diem 2"))
       (setq p3 (getpoint p2 "\nChon diem 3"))       )
    (progn
      (setq p1 (trans p1 1 0)
	    p2 (trans p2 1 0)
	    p3 (trans p3 1 0))
      (if (isCollinear p1 p2 p3 1e-6)
	(setq a210 '(0 0 1))
	(setq a210 (norm_3pts p1 p2 p3)))
      (setq lp (list p1 p2 p3))
      (setq lp (mapcar '(lambda(x) (trans x 0 a210)) lp))
      (entmakex (append
		  (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline")
			(cons 38 (caddar lp))(cons 90 (length lp)) )
		  (mapcar '(lambda(x) (list 10 (car x) (cadr x))) lp)
		  (list (cons 210 a210))))      )    )
  (princ))    

Bạn nhờ bác nào đó viết cho cái lisp cắt ký tự đầu tiên rồi thay vào đó là ký tự do bạn nhập vào cho tất cả text bạn...

>>

Bạn nhờ bác nào đó viết cho cái lisp cắt ký tự đầu tiên rồi thay vào đó là ký tự do bạn nhập vào cho tất cả text bạn chọn là ok ngay mà. 

(Defun c:ttt (/ b i N kqthay DTMs giatrit)
(command "undo" "be")
(princ "\nChon cac text can chinh")
(setq b (ssget (list (cons 0 "text"))))
(while
(= b nil)
(princ "\nKhong tim thay doi tuong text nao. Chon cac text can chinh")
(setq b (ssget (list (cons 0 "text"))))
)
(princ (strcat "Tim thay " (itoa (sslength b)) " doi tuong text"))
(setq giatrit (getstring 5"\nGia tri thay the: "))
(setq i 0)
(setq N (sslength b))
(while (< i N)
(setq ckq (substr (cdr (assoc 1 (entget (ssname b i)))) 2 (- (strlen (cdr (assoc 1 (entget (ssname b i))))) 1)))
(setq kqthay (strcat giatrit ckq))
(setq DTMs (subst (cons 1 kqthay) (assoc 1 (entget (ssname b i))) (entget (ssname b i))))
(entmod DTMs)
(setq i (1+ i))
)
(command "undo" "end")
(Princ)) 

Viết giúp bạn đây.

Dùng lisp này còn bị lỗi nhiều hơn vì thay thế toàn bộ text chọn. Sửa lại như sau để lọc text

Thêm dòng

(setq giatricu (getstring "\nGia tri cu: "))

trước

(princ "\nChon cac text can chinh")

Sửa 2 chỗ

(ssget (list (cons 0 "text")))

thành

(ssget (list (cons 0 "text")(cons 1 (strcat giatricu "*"))))

<<

Download lisp

Filename: 360852_ttt.lsp

Bạn thử sử dụng đoạn này xem sao. 1 ví dụ điển hình của việc biết lisp thì lợi ntn ^^

(defun c:fix ()
(defun...
>>

Bạn thử sử dụng đoạn này xem sao. 1 ví dụ điển hình của việc biết lisp thì lợi ntn ^^

(defun c:fix ()
(defun chDXF (dxf val ent) 
(entmod (subst (cons dxf val) (assoc dxf (entget ent)) (entget ent))))
(defun dxf (dxf ent) (cdr (assoc dxf (entget ent))))
(foreach e (acet-ss-to-list (ssget "X" (list (cons 0 "TEXT")(cons 1 "~-#")(cons 1 "##"))))
(chDXF  1 (strcat "." (dxf 1 e)) e)
)
)

Chào a ketxu

Nhờ a kiểm tra lại lisp fix dùm e nha

Khi sử dụng fix thì khắc phục đuợc lỗi mất dấu chấm, nhưng o một số text bị tách ra thì lại có thêm 1 dấu chấm nữa

http://www.mediafire.com/?bir8mzv3rb3gi58

<<

Ví dụ lệnh CUA nằm trong file c:\cadviet\lisp\archanwoo.lsp nhưng người sử dụng không biết tên lệnh là CUA. Khi người sử dụng lệnh TEST, sẽ tương đương như lệnh...

>>

Ví dụ lệnh CUA nằm trong file c:\cadviet\lisp\archanwoo.lsp nhưng người sử dụng không biết tên lệnh là CUA. Khi người sử dụng lệnh TEST, sẽ tương đương như lệnh CUA, nhưng chỉ được 5 lần sử dụng.

Code như sau:

(load "c:/cadviet/lisp/archanwoo.lsp");
(defun c:TEST()
(c:cua)
;;; Doc gia tri
(setq tmp (getcfg "AppData/CADViet/Count")
sl (cond
((or (not tmp) (= tmp "")) "5")
(t tmp)
)
)

;;; Kiem tra va thong bao
(if (/= sl "0")
(progn
;;; Thuc thi ma lenh
(princ (strcat "\nBan con " sl " lan su dung nua"))
;;; Luu gia tri
(setcfg "AppData/CADViet/Count" (itoa (1- (atoi sl))))
)
(princ "\nBan da het han su dung!")
)

(princ)
)

(defun c:RESET()
;;; Reset lai gia tri
(setcfg "AppData/CADViet/Count" "")
(princ)
)

Thuật toán rất đơn giản, bạn đưa them 1 Function Test (bao gồm đọc, kiểm tra và ghi số lần thực hiện lệnh Cua) rồi đặt tất cả các biểu thức của lệnh Cua trong 1 biểu thúc điều kiện , hoặc vòng lặp while. Sau đó mã hoá toàn bộ dưới dạng .fas Vậy đơn giản và tính bảo mật cao hơn. Tất nhiên với các cao thủ thì vẫn chỉ là .. vải thưa che mắt thánh

Em chưa hiểu lắm :

Nhờ các Anh giúp em chỉ cho một cách để giới hạn 1 file.lsp với đọan mã trên.

Mong được các anh giúp, mong tin :D

<<

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

lisp mình up lên là của leemac mà...

>>

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

lisp mình up lên là của leemac mà sao không giống nhỉ

;;----------------------=={ Length at Midpoint }==----------------------;;
;;                                                                      ;;
;;  This program prompts the user for a selection of objects to be      ;;
;;  labelled and proceeds to generate an MText object located at        ;;
;;  the midpoint of each object displaying a Field Expression           ;;
;;  referencing the length of the object.                               ;;
;;                                                                      ;;
;;  The program is compatible for use with Arcs, Circles, Lines,        ;;
;;  LWPolylines, 2D & 3D Polylines, and under all UCS & View settings.  ;;
;;                                                                      ;;
;;  The program will generate MText objects positioned directly over    ;;
;;  the midpoint of each object, and aligned with the object whilst     ;;
;;  preserving text readability. The MText will have a background mask  ;;
;;  enabled and will use the active Text Style and Text Height settings ;;
;;  at the time of running the program.                                 ;;
;;----------------------------------------------------------------------;;
;;  Author:  Lee Mac, Copyright © 2013  -  www.lee-mac.com              ;;
;;----------------------------------------------------------------------;;
;;  Version 1.0    -    2013-11-12                                      ;;
;;                                                                      ;;
;;  - First release.                                                    ;;
;;----------------------------------------------------------------------;;
;;  Version 1.1    -    2016-01-16                                      ;;
;;                                                                      ;;
;;  - Modified LM:objectid function to account for 64-bit AutoCAD 2008. ;;
;;----------------------------------------------------------------------;;

(defun c:midlen ( / *error* ent fmt idx ins ocs par sel spc txt typ uxa )

    (setq fmt "%lu6") ;; Field Formatting
    (setq pr "%pr0") ;;  Precision

	(setq 	sca1 (getvar "DIMTXT"))
	(setq 	sca2 (getvar "DIMSCALE"))
	(setq sca3 (* sca1 sca2))
	(setvar "textsize" sca3)

    (defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )
    
    (if
        (setq sel
            (ssget
                (list
                   '(0 . "ARC,CIRCLE,LINE,*POLYLINE")
                   '(-4 . "<NOT")
                       '(-4 . "<AND")
                           '(0 . "POLYLINE")
                           '(-4 . "&")
                           '(70 . 80)
                       '(-4 . "AND>")
                   '(-4 . "NOT>")
                    (if (= 1 (getvar 'cvport))
                        (cons 410 (getvar 'ctab))
                       '(410 . "Model")
                    )
                )
            )
        )
        (progn
            (setq spc
                (vlax-get-property (LM:acdoc)
                    (if (= 1 (getvar 'cvport))
                        'paperspace
                        'modelspace
                    )
                )
            )
            (setq ocs (trans '(0.0 0.0 1.0) 1 0 t)
                  uxa (angle '(0.0 0.0) (trans (getvar 'ucsxdir) 0 ocs t))
            )
            (LM:startundo (LM:acdoc))
            (repeat (setq idx (sslength sel))
                (setq ent (ssname sel (setq idx (1- idx)))
                      par (vlax-curve-getparamatdist ent (/ (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent)) 2.0))
                      ins (vlax-curve-getpointatparam ent par)
                      typ (cdr (assoc 0 (entget ent)))
                )
                (setq txt
                    (vlax-invoke spc 'addmtext ins 0.0
                        (strcat "L="
                            "%<\\AcObjProp Object(%<\\_ObjId " (LM:objectid (vlax-ename->vla-object ent)) ">%)."
                            (cond
                                (   (= "CIRCLE" typ) "Circumference")
                                (   (= "ARC"    typ) "ArcLength")
                                (   "Length"   )
                            )
                            " \\f \"" fmt pr "\">%"
                        )
                    )
                )
                (vla-put-backgroundfill  txt :vlax-true)
                (vla-put-attachmentpoint txt acattachmentpointmiddlecenter)
                (vla-put-insertionpoint  txt (vlax-3D-point ins))
                (vla-put-rotation txt (LM:readable (- (angle '(0.0 0.0 0.0) (trans (vlax-curve-getfirstderiv ent par) 0 ocs t)) uxa)))
            )
            (LM:endundo (LM:acdoc))
        )
    )
    (princ)
)

;; Readable  -  Lee Mac
;; Returns an angle corrected for text readability.

(defun LM:readable ( a )
    (   (lambda ( a )
            (if (and (< (* pi 0.5) a) (<= a (* pi 1.5)))
                (LM:readable (+ a pi))
                a
            )
        )
        (rem (+ a pi pi) (+ pi pi))
    )
)

;; ObjectID  -  Lee Mac
;; Returns a string containing the ObjectID of a supplied VLA-Object
;; Compatible with 32-bit & 64-bit systems

(defun LM:objectid ( obj )
    (eval
        (list 'defun 'LM:objectid '( obj )
            (if (wcmatch (getenv "PROCESSOR_ARCHITECTURE") "*64*")
                (if (vlax-method-applicable-p (vla-get-utility (LM:acdoc)) 'getobjectidstring)
                    (list 'vla-getobjectidstring (vla-get-utility (LM:acdoc)) 'obj ':vlax-false)
                   '(LM:ename->objectid (vlax-vla-object->ename obj))
                )
               '(itoa (vla-get-objectid obj))
            )
        )
    )
    (LM:objectid obj)
)

;; Entity Name to ObjectID  -  Lee Mac
;; Returns the 32-bit or 64-bit ObjectID for a supplied entity name

(defun LM:ename->objectid ( ent )
    (LM:hex->decstr
        (setq ent (vl-string-right-trim ">" (vl-prin1-to-string ent))
              ent (substr ent (+ (vl-string-position 58 ent) 3))
        )
    )
)

;; Hex to Decimal String  -  Lee Mac
;; Returns the decimal representation of a supplied hexadecimal string

(defun LM:hex->decstr ( hex / foo bar )
    (defun foo ( lst rtn )
        (if lst
            (foo (cdr lst) (bar (- (car lst) (if (< 57 (car lst)) 55 48)) rtn))
            (apply 'strcat (mapcar 'itoa (reverse rtn)))
        )
    )
    (defun bar ( int lst )
        (if lst
            (if (or (< 0 (setq int (+ (* 16 (car lst)) int))) (cdr lst))
                (cons (rem int 10) (bar (/ int 10) (cdr lst)))
            )
            (bar int '(0))
        )
    )
    (foo (vl-string->list (strcase hex)) nil)
)

;; Start Undo  -  Lee Mac
;; Opens an Undo Group.

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

;; End Undo  -  Lee Mac
;; Closes an Undo Group.

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

;; Active Document  -  Lee Mac
;; Returns the VLA Active Document Object

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

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

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

Mình giúp bạn đến đây nhé! test thử xem.

<<

Dựa theo lisp MIDLEN.lsp của LEEMAC, Thiep ra lisp LENGFIELD.lsp phù hợp với ý của bạn

Nhớ là cách chọn đối tượng là kiểu Fence nhe bạn, mục đích của mình là đối tượng polyline nào "dính" hàng rào trước thì lisp sẽ tạo ra 1 text gắn field trước, như vậy sẽ pick điểm chèn text cho phù hợp theo trật tự.

>>

Dựa theo lisp MIDLEN.lsp của LEEMAC, Thiep ra lisp LENGFIELD.lsp phù hợp với ý của bạn

Nhớ là cách chọn đối tượng là kiểu Fence nhe bạn, mục đích của mình là đối tượng polyline nào "dính" hàng rào trước thì lisp sẽ tạo ra 1 text gắn field trước, như vậy sẽ pick điểm chèn text cho phù hợp theo trật tự.

;;-------------------=={ Length *POLYLINE _ field }==-------------------;;
;;                                                                      ;;
;;  This program prompts the user for a selection of objects to be      ;;
;;  labelled and proceeds to generate an MText object located at        ;;
;;  the midpoint of each object displaying a Field Expression           ;;
;;  referencing the length of the object.                               ;;
;;                                                                      ;;
;;  The program is compatible for use with *Polylines, and under        ;;
;;  all UCS & View settings.                                            ;;
;;  The MText will have a background mask                               ;;
;;  enabled and will use the active Text Style and Text Height settings ;;
;;  at the time of running the program.                                 ;;
;;----------------------------------------------------------------------;;
;;  Author: Trân Thiêp base lisp midlen.lsp by Lee Mac, Copyright © 2013  -  www.lee-mac.com              ;;
;;----------------------------------------------------------------------;;
;;  - Modified LM:objectid function to account for 64-bit AutoCAD 2008. ;;
;;----------------------------------------------------------------------;;

(defun c:lengfield (/ *error* ent fmt idx ins ocs par sel spc txt typ uxa)
    (setvar "textsize" (getvar "DIMTXT"))
    (defun *error* (msg)
	(LM:endundo (LM:acdoc))
	(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
	    (princ (strcat "\nError: " msg))
	)
	(princ)
    )
    (if	(setq sel (ssget "F"
			 (acet-ui-fence-select)
			 (list '(0 . "*POLYLINE")
			       '(-4 . "<NOT")
			       '(-4 . "<AND")
			       '(0 . "POLYLINE")
			       '(-4 . "&")
			       '(70 . 80)
			       '(-4 . "AND>")
			       '(-4 . "NOT>")
			       (if (= 1 (getvar 'cvport))
				   (cons 410 (getvar 'ctab))
				   '(410 . "Model")
			       )
			 )
		  )
	)
	(progn (setq spc (vlax-get-property (LM:acdoc)
					    (if	(= 1 (getvar 'cvport))
						'paperspace
						'modelspace
					    )
			 )
	       )
	       (setq ocs (trans '(0.0 0.0 1.0) 1 0 t)
		     uxa (angle '(0.0 0.0) (trans (getvar 'ucsxdir) 0 ocs t))
	       )
	       (LM:startundo (LM:acdoc))
	       (repeat (setq idx (sslength sel))
		   (setq ent (ssname sel (setq idx (1- idx)))
			 par (vlax-curve-getparamatdist
				 ent
				 (/ (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent)) 2.0)
			     )
			 ins (vlax-curve-getpointatparam ent par)
			 typ (cdr (assoc 0 (entget ent)))
		   )
		   (setq txt (vlax-invoke spc
					  'addmtext
					  ins
					  0.0
					  (strcat "L="
						  "%<\\AcObjProp Object(%<\\_ObjId "
						  (LM:objectid (vlax-ename->vla-object ent))
						  ">%).Length \\f \"%lu2%pr0%ps%ct8\">%"
					  )
			     )
		   )
		   (vla-put-backgroundfill txt :vlax-true)
		   (vla-put-attachmentpoint txt acattachmentpointmiddlecenter)
		   (vla-put-insertionpoint
		       txt
		       (vlax-3D-point (getpoint "\pick a point for inserttext_field"))
		   )
	       )
	       (LM:endundo (LM:acdoc))
	)
    )
    (princ)
)

;; Readable  -  Lee Mac
;; Returns an angle corrected for text readability.

(defun LM:readable ( a )
    (   (lambda ( a )
            (if (and (< (* pi 0.5) a) (<= a (* pi 1.5)))
                (LM:readable (+ a pi))
                a
            )
        )
        (rem (+ a pi pi) (+ pi pi))
    )
)

;; ObjectID  -  Lee Mac
;; Returns a string containing the ObjectID of a supplied VLA-Object
;; Compatible with 32-bit & 64-bit systems

(defun LM:objectid ( obj )
    (eval
        (list 'defun 'LM:objectid '( obj )
            (if (wcmatch (getenv "PROCESSOR_ARCHITECTURE") "*64*")
                (if (vlax-method-applicable-p (vla-get-utility (LM:acdoc)) 'getobjectidstring)
                    (list 'vla-getobjectidstring (vla-get-utility (LM:acdoc)) 'obj ':vlax-false)
                   '(LM:ename->objectid (vlax-vla-object->ename obj))
                )
               '(itoa (vla-get-objectid obj))
            )
        )
    )
    (LM:objectid obj)
)

;; Entity Name to ObjectID  -  Lee Mac
;; Returns the 32-bit or 64-bit ObjectID for a supplied entity name

(defun LM:ename->objectid ( ent )
    (LM:hex->decstr
        (setq ent (vl-string-right-trim ">" (vl-prin1-to-string ent))
              ent (substr ent (+ (vl-string-position 58 ent) 3))
        )
    )
)

;; Hex to Decimal String  -  Lee Mac
;; Returns the decimal representation of a supplied hexadecimal string

(defun LM:hex->decstr ( hex / foo bar )
    (defun foo ( lst rtn )
        (if lst
            (foo (cdr lst) (bar (- (car lst) (if (< 57 (car lst)) 55 48)) rtn))
            (apply 'strcat (mapcar 'itoa (reverse rtn)))
        )
    )
    (defun bar ( int lst )
        (if lst
            (if (or (< 0 (setq int (+ (* 16 (car lst)) int))) (cdr lst))
                (cons (rem int 10) (bar (/ int 10) (cdr lst)))
            )
            (bar int '(0))
        )
    )
    (foo (vl-string->list (strcase hex)) nil)
)

;; Start Undo  -  Lee Mac
;; Opens an Undo Group.

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

;; End Undo  -  Lee Mac
;; Closes an Undo Group.

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

;; Active Document  -  Lee Mac
;; Returns the VLA Active Document Object

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

(vl-load-com)
(princ
    (strcat "\n:: Lengfield.lsp | by TranThiep | "
	    (menucmd "m=$(edtime,0,yyyy)")
	    ", based lisp midlen.lsp \\U+00A9 Lee Mac "
	    "\n:: Type \"lengfield\" to Invoke ::"
    )
)
(princ)

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

Thân ái, chúc bạn thành công. TranThiep tel:0918841230

;; Vẽ hình chữ nhật có chiều dày 20
(defun c:foo (/ p1 p2 p3 p4 p5 p6 p7 p8 os)
  (setq p1 (getpoint "\nChon point thu nhat")
        p3 (getpoint "\nChon point thu ba")
        p2 (list (car p3) (cadr p1))
        p4 (list (car p1) (cadr p3))
        ;
        p5 (list (car p1) (cadr p1) 20)
        p6 (list (car p2) (cadr p2) 20)
        p7 (list (car p3) (cadr p3) 20)
        p8 (list (car p4) (cadr p4) 20)
  )
 ...
>>

;; Vẽ hình chữ nhật có chiều dày 20
(defun c:foo (/ p1 p2 p3 p4 p5 p6 p7 p8 os)
  (setq p1 (getpoint "\nChon point thu nhat")
        p3 (getpoint "\nChon point thu ba")
        p2 (list (car p3) (cadr p1))
        p4 (list (car p1) (cadr p3))
        ;
        p5 (list (car p1) (cadr p1) 20)
        p6 (list (car p2) (cadr p2) 20)
        p7 (list (car p3) (cadr p3) 20)
        p8 (list (car p4) (cadr p4) 20)
  )
  ;
  (setq os (getvar "osmode"))
  (setvar "osmode" 0)
  (command vpoint "" 1,-1,1 "")
  (command ".3dface" p1 p2 p3 p4 ""
           ".3dface" p5 p6 p7 p8 ""
           ".3dface" p1 p4 p8 p5 ""
           ".3dface" p2 p3 p7 p6 ""
           ".3dface" p3 p4 p8 p7 ""
           ".3dface" p1 p2 p6 p5 ""
  )
  (setvar "osmode" os)
  (command "zoom" "all")
)

Vào lúc 4/7/2021 tại 08:55, vanhuyou đã nói:

Bác nào có thể giúp em...

>>

Vào lúc 4/7/2021 tại 08:55, vanhuyou đã nói:

Bác nào có thể giúp em làm tròn số lên 10 được không, giúp em với.

;;----------------------=={ Length at Midpoint }==----------------------;;
;;                                                                      ;;
;;  This program prompts the user for a selection of objects to be      ;;
;;  labelled and proceeds to generate an MText object located at        ;;
;;  the midpoint of each object displaying a Field Expression           ;;
;;  referencing the length of the object.                               ;;
;;                                                                      ;;
;;  The program is compatible for use with Arcs, Circles, Lines,        ;;
;;  LWPolylines, 2D & 3D Polylines, and under all UCS & View settings.  ;;
;;                                                                      ;;
;;  The program will generate MText objects positioned directly over    ;;
;;  the midpoint of each object, and aligned with the object whilst     ;;
;;  preserving text readability. The MText will have a background mask  ;;
;;  enabled and will use the active Text Style and Text Height settings ;;
;;  at the time of running the program.                                 ;;
;;----------------------------------------------------------------------;;
;;  Author:  Lee Mac, Copyright © 2013  -  www.lee-mac.com              ;;
;;----------------------------------------------------------------------;;
;;  Version 1.0    -    2013-11-12                                      ;;
;;                                                                      ;;
;;  - First release.                                                    ;;
;;----------------------------------------------------------------------;;
;;  Version 1.1    -    2016-01-16                                      ;;
;;                                                                      ;;
;;  - Modified LM:objectid function to account for 64-bit AutoCAD 2008. ;;
;;----------------------------------------------------------------------;;

(defun c:midlen ( / *error* ent fmt idx ins ocs par sel spc txt typ uxa )

    (setq fmt "%lu6") ;; Field Formatting
    (setq pr "%pr0") ;;  Precision
    (setq ps "%ps") ;;  
    (setq ct "%ct8") ;;  
	
	(setq 	sca1 (getvar "DIMTXT"))
	(setq 	sca2 (getvar "DIMSCALE"))
	(setq sca3 (* sca1 sca2))
	(setvar "textsize" sca3)

    (defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )
    
    (if
        (setq sel
            (ssget
                (list
                   '(0 . "ARC,CIRCLE,LINE,*POLYLINE")
                   '(-4 . "<NOT")
                       '(-4 . "<AND")
                           '(0 . "POLYLINE")
                           '(-4 . "&")
                           '(70 . 80)
                       '(-4 . "AND>")
                   '(-4 . "NOT>")
                    (if (= 1 (getvar 'cvport))
                        (cons 410 (getvar 'ctab))
                       '(410 . "Model")
                    )
                )
            )
        )
        (progn
            (setq spc
                (vlax-get-property (LM:acdoc)
                    (if (= 1 (getvar 'cvport))
                        'paperspace
                        'modelspace
                    )
                )
            )
            (setq ocs (trans '(0.0 0.0 1.0) 1 0 t)
                  uxa (angle '(0.0 0.0) (trans (getvar 'ucsxdir) 0 ocs t))
            )
            (LM:startundo (LM:acdoc))
            (repeat (setq idx (sslength sel))
                (setq ent (ssname sel (setq idx (1- idx)))
                      par (vlax-curve-getparamatdist ent (/ (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent)) 2.0))
                      ins (vlax-curve-getpointatparam ent par)
                      typ (cdr (assoc 0 (entget ent)))
                )
                (setq txt
                    (vlax-invoke spc 'addmtext ins 0.0
                        (strcat "L="
                            "%<\\AcObjProp Object(%<\\_ObjId " (LM:objectid (vlax-ename->vla-object ent)) ">%)."
                            (cond
                                (   (= "CIRCLE" typ) "Circumference")
                                (   (= "ARC"    typ) "ArcLength")
                                (   "Length"   )
                            )
                            " \\f \"  " fmt pr ps ct " \">%"
                        )
                    )
                )
                (vla-put-backgroundfill  txt :vlax-true)
                (vla-put-attachmentpoint txt acattachmentpointmiddlecenter)
                (vla-put-insertionpoint  txt (vlax-3D-point ins))
                (vla-put-rotation txt (LM:readable (- (angle '(0.0 0.0 0.0) (trans (vlax-curve-getfirstderiv ent par) 0 ocs t)) uxa)))
            )
            (LM:endundo (LM:acdoc))
        )
    )
    (princ)
)

;; Readable  -  Lee Mac
;; Returns an angle corrected for text readability.

(defun LM:readable ( a )
    (   (lambda ( a )
            (if (and (< (* pi 0.5) a) (<= a (* pi 1.5)))
                (LM:readable (+ a pi))
                a
            )
        )
        (rem (+ a pi pi) (+ pi pi))
    )
)

;; ObjectID  -  Lee Mac
;; Returns a string containing the ObjectID of a supplied VLA-Object
;; Compatible with 32-bit & 64-bit systems

(defun LM:objectid ( obj )
    (eval
        (list 'defun 'LM:objectid '( obj )
            (if (wcmatch (getenv "PROCESSOR_ARCHITECTURE") "*64*")
                (if (vlax-method-applicable-p (vla-get-utility (LM:acdoc)) 'getobjectidstring)
                    (list 'vla-getobjectidstring (vla-get-utility (LM:acdoc)) 'obj ':vlax-false)
                   '(LM:ename->objectid (vlax-vla-object->ename obj))
                )
               '(itoa (vla-get-objectid obj))
            )
        )
    )
    (LM:objectid obj)
)

;; Entity Name to ObjectID  -  Lee Mac
;; Returns the 32-bit or 64-bit ObjectID for a supplied entity name

(defun LM:ename->objectid ( ent )
    (LM:hex->decstr
        (setq ent (vl-string-right-trim ">" (vl-prin1-to-string ent))
              ent (substr ent (+ (vl-string-position 58 ent) 3))
        )
    )
)

;; Hex to Decimal String  -  Lee Mac
;; Returns the decimal representation of a supplied hexadecimal string

(defun LM:hex->decstr ( hex / foo bar )
    (defun foo ( lst rtn )
        (if lst
            (foo (cdr lst) (bar (- (car lst) (if (< 57 (car lst)) 55 48)) rtn))
            (apply 'strcat (mapcar 'itoa (reverse rtn)))
        )
    )
    (defun bar ( int lst )
        (if lst
            (if (or (< 0 (setq int (+ (* 16 (car lst)) int))) (cdr lst))
                (cons (rem int 10) (bar (/ int 10) (cdr lst)))
            )
            (bar int '(0))
        )
    )
    (foo (vl-string->list (strcase hex)) nil)
)

;; Start Undo  -  Lee Mac
;; Opens an Undo Group.

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

;; End Undo  -  Lee Mac
;; Closes an Undo Group.

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

;; Active Document  -  Lee Mac
;; Returns the VLA Active Document Object

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

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

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

test xem nhé!

<<

 ;; Get Dynamic Block Property Value  -  Lee Mac
>>

 ;; Get Dynamic Block Property Value  -  Lee Mac
;; Returns the value of a Dynamic Block property (if present)
;; blk -  VLA Dynamic Block Reference object
;; prp -  Dynamic Block property name (case-insensitive)
;;;
(Defun c:test ()
(LM:getdynpropvalue (vlax-ename->vla-object(car(entsel))) "L")
)
(defun LM:getdynpropvalue ( blk prp )
    (setq prp (strcase prp))
    (vl-some '(lambda ( x ) (if (= prp (strcase (vla-get-propertyname x))) (vlax-get x 'value)))
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)

À nó đây rồi. đã lấy đc giá trị Linear parameter  trong Dynamic.

Hề hề hề.

Làm thử thế này có nhanh hơn không nhé:

;; free lisp from cadviet.com
;;; this lisp was...
>>

Hề hề hề.

Làm thử thế này có nhanh hơn không nhé:

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=13203&st=880
(defun c:mtl(/ doc Util MS c1 c2 kc2tl L1 oldos i j p dgiao pc2)
(vl-load-com)
(setq oldco (getvar "cecolor"))
(setq doc (vla-get-activeDocument (vlax-get-acad-object))
Util (vla-get-utility doc)
MS (vla-get-ModelSpace doc))
(vla-StartUndoMark doc)
(setq c1 (car(entsel "\n Chon duong bien thu nhat :")))
(setq c2 (car(entsel "\n Chon duong bien thu hai :")))
(if (not *kc2tl*) (setq *kc2tl* 2))
(setq kc2tl (getdist (strcat "\n Khoang cach giua taluy ngan va taluy dai < "
			(rtos *kc2tl* 2 2) " > : "
		     )
	   )
)
(if (not kc2tl) (setq kc2tl *kc2tl*) (setq *kc2tl* kc2tl))
(setq L1 (vlax-curve-getDistAtParam c1
		(setq pre (vlax-curve-getEndParam c1))
	)
)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setvar "cecolor" "8")
(setq i 0 j 0)
(Repeat (1+ (fix (/ L1 kc2tl)))
(setq p (vlax-curve-getPointAtDist c1 i))
(setq dgiao (vlax-curve-getClosestPointTo c2 p nil))
(if (= (rem j 2) 0)
(setq pc2 dgiao)
(setq pc2 (list (/ (+ (car p) (car dgiao)) 2) (/ (+ (cadr p) (cadr dgiao)) 2) 0))
)
(vla-addline MS (vlax-3d-point p)
	 (vlax-3d-point pc2)
)
(setq i (+ i kc2tl))
(setq j (1+ j))
;;;;;;;;;;(command ".change" "L" "" "p" "C" 8 "" ""); doi mau doi tuong
;(princ)
);repeat
(setvar "osmode" oldos)
(setvar "cecolor" oldco)
(vla-EndUndoMark doc)
(princ)
)

Chúc bạn vui.

Đoạn này đã như ý muốn chỉ có điều: khi đối tượng chuyển về màu 8 thì sau khi kết thúc lệnh màu của Layer hiện hành cũng là màu 8. Có cách nào để mặc định là Bylayer không ?

<<

Bạn thử cái này xem nhé

(defun c:PLLEV(/ PL LenPL I Points LenPoint)
 (setq PL (entget (car (entsel "\nChon 1 Polyline: ")))
I 0
LenPL (length PL))
 (if (= (cdr (assoc 0...
>>

Bạn thử cái này xem nhé

(defun c:PLLEV(/ PL LenPL I Points LenPoint)
 (setq PL (entget (car (entsel "\nChon 1 Polyline: ")))
I 0
LenPL (length PL))
 (if (= (cdr (assoc 0 PL)) "LWPOLYLINE")
(progn
  (while (	(if (= (nth 0 (nth I PL)) 10 )
  (setq Points (append Points (list (cdr (nth I PL))))
	LenPoints (length Points))
)
(setq I (1+ I))
  )
  (setq LV (getreal "\nNhap cao do dau: ")
	Id (Getreal "\nNhap do doc doc: ")
	I 0)
  (while (	(setq Point (nth I Points))
(If (= I 0)
  (progn
	(command "TEXT" "j" "MC" Point "" "" (rtos LV 2 3) "")
	(setq LPoint Point)
  )
  (progn
	(setq Len (distance Lpoint Point)
	  NewLV (+ LV (/ (* Id Len) 100.0)))
	(command "TEXT" "j" "MC" Point "" "" (rtos NewLV 2 3) "")
	(setq LPoint Point
	  LV NewLV)
  )
)
(setq I (1+ I))
  )
)
 )
)
(defun c:PL2LEV(/ PL LenPL I Points LenPoint)
 (setq PL (entget (car (entsel "\nChon 1 Polyline: ")))
I 0
LenPL (length PL))
 (if (= (cdr (assoc 0 PL)) "LWPOLYLINE")
(progn
  (while (	(if (= (nth 0 (nth I PL)) 10 )
  (setq Points (append Points (list (cdr (nth I PL))))
	LenPoints (length Points))
)
(setq I (1+ I))
  )
  (setq SLV (getreal "\nNhap cao do dau: ")
	ELV (Getreal "\nNhap cao do cuoi: ")
	I 1
	Dist 0)
  (setq SPoint (nth 0 Points))
  (while (	(setq Point (nth I Points)
	  Dist (+ Dist (distance Point Spoint))
	  Spoint Point
	  I (1+ I))
  )
  (setq Id (/ (- ELV SLV) Dist)
	I 0)
  (while (	(setq Point (nth I Points))
(If (= I 0)
  (progn
	(command "TEXT" "j" "MC" Point "" "" (rtos SLV 2 3) "")
	(setq LPoint Point)
  )
  (progn
	(setq Len (distance Lpoint Point)
	  NewLV (+ SLV (* Id Len)))
	(command "TEXT" "j" "MC" Point "" "" (rtos NewLV 2 3) "")
	(setq LPoint Point
	  SLV NewLV)
  )
)
(setq I (1+ I))
  )
)
 )
)

Chào bác hoa35ktxd

Lisp trên chỉ chạy đúng với các tuyến cống thẳng (thể hiện bằng phân đoạn Line (Line segment)

Và nó không còn đúng nữa đối với các tuyến cống cong (thể hiện bằng phân đoạn Arc (Arc segment)

Bởi lẽ bác thể hiện khoảng cách giữa 2 điểm bằng hàm distance thì với Line chính là chiều dài của nó còn với Arc là chiều dài dây cung (nối điểm đầu và điểm cuối arc)

 

1 ý nhỏ nữa là : Lisp chạy 1 mạch từ điểm đầu đến điểm cuối Pline, đôi lúc cũng không trúng ý User. Vì Úser muốn nó chạy theo chiều ngược lại

 

Cái nữa là bác có thể thay thế đoạn mã này :

      (while (

    (if (= (nth 0 (nth I PL)) 10 )

      (setq Points (append Points (list (cdr (nth I PL))))

        LenPoints (length Points))

    )

    (setq I (1+ I))

      )

bằng

(setq Points (mapcar 'cdr (vl-remove-if '(lambda(x) (if (/= (car x) 10) x)) pl)))

 (setq LenPoints (length Points))

 

Biến LenPoints nên đưa ra khỏi vòng lặp While đê tăng tốc độ xử lý List của Lisp

Vài dòng chia sẻ

<<

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

tính cả trường hợp các...

>>

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

tính cả trường hợp các phương còn lại

Bạn thử xem!

(defun C:00 (/ G1 G2 KC LTSDIM OBJ1 OBJXLINE PNTG1 PNTG2 SSCHON SSDIM)
  (vl-load-com)
  (defun *error* (msg)
    (if	Olmode
      (setvar 'osmode Olmode)
    )
    (if	(not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
      (princ (strcat "\nError: " msg))
    )
    (redraw)
    (princ)
  )
  (command "undo" "begin")
  (setq Olmode (getvar "OSMODE"))
  (setvar "OSMODE" 0)
  (setq Obj1 (Car (entsel "\nChon Dimension dau tien: ")))
  (if (= (cdr (assoc 0 (entget Obj1))) "DIMENSION")
    (progn
      (setq ssDim (ssget '((0 . "DIMENSION"))))
      (if ssDim
	(progn
	  (setq LtsDim (acet-ss-to-list ssDim))
	  (if (member Obj1 LtsDim)
	    (vl-remove Obj1 LtsDim)
	  )
	  (if LtsDim
	    (progn
	      (setq G1 (angle (cdr (assoc 13 (entget Obj1))) (cdr (assoc 14 (entget Obj1)))))
	      (setq PntG1 (cdr (assoc 11 (entget Obj1))))
	      (command "Xline" PntG1 (polar PntG1 G1 1.0) "")
	      (setq ObjXline (entlast))
	      (setq ssChon (ssadd))
	      (foreach eDim LtsDim
		(setq G2 (angle (cdr (assoc 13 (entget eDim))) (cdr (assoc 14 (entget eDim)))))
		(setq PntG2 (cdr (assoc 11 (entget eDim))))
		(setq Kc (distance PntG2 (vlax-curve-getClosestPointto ObjXline PntG2)))
		(if (and (not (equal Kc 0.0 1e-8))  (or (equal G2 G1 1e-8) (equal G2 (+ G1 pi) 1e-8)))
		  (ssadd eDim ssChon)
		)
	      )
	      (entdel ObjXline)
	    )
	  )
	)
      )
    )
  )
  (if ssChon
    (sssetfirst nil ssChon)
  )
  (setvar "OSMODE" Olmode)
  (princ)
)

 

<<

 

Mình không rành nhiều về lisp nên chỉ biết viết cho bạn cái lệnh này,bạn dùng thử xem có được không

>>

 

Mình không rành nhiều về lisp nên chỉ biết viết cho bạn cái lệnh này,bạn dùng thử xem có được không

(defun c:dmla ()
(command "undo" "begin")
(command "change" "all" "" "p" "c" "bylayer" "LT" "bylayer" "LW" "bylayer" "" "")
(command "undo" "end")
(princ)
)

Ai giúp sửa lisp này thành lisp có thể chuyển cả màu của mũi tên (vẽ bằng lệnh qleader)  và màu của đo kích thước  thành bylayer với (cả thân mũi tên và đầu mũi tên đều về bylayer nha, hình bên dưới do mình không biết cách chuyển màu của đầu mũi tên về bylayer nên vẫn giữ màu đỏ).

http://www.cadviet.com/upfiles/3/127110_dim.dwg

Trích dẫn help:

70

Attribute flags:

1 = Attribute is invisible (does not appear)

2...

>>

Trích dẫn help:

70

Attribute flags:

1 = Attribute is invisible (does not appear)

2 = This is a constant attribute

4 = Verification is required on input of this attribute

8 = Attribute is preset (no prompt during insertion)

Tôi test OK.

;;;;;;;;MAIN;;;;;;;;;
(defun C:1att (/ p0 G00 G90 LL)
 (setq G00 0.0
	G90 (* pi 0.5))
 (setq p0 (getpoint "\nChon dien chen Attribute: "))
 (setq LL '("111" "222" "333"))

 (Make_att LL "standard" "0" p0 3.0 G00 1 1)

 (princ)
)
(Princ "\nStart command with <1att>")
;;;;; Ham con tao att
(defun Make_att (LIST_ATT STYLE LAYER POINT HEIGHT ANG COLOR FLAG); Ang: Radial
(entmake   (list  (cons 0 "ATTDEF")
(cons 100 "AcDbEntity")
(cons 7 (if STYLE STYLE (getvar "TextSTYLE")))
(cons 8 (if LAYER LAYER (getvar "CLAYER")))
(cons 100  "AcDbText")
(cons 100  "AcDbAttributeDefinition")
(cons 10 POINT)
;	(cons 11 POINT)
             	(cons 70 FLAG)

 	(cons 40 HEIGHT)
(if ANG (cons 50 ANG))
(cons 62 (if COLOR COLOR 256))
(cons 1 (nth 0 LIST_ATT)) ; Default value (string)
(cons 2 (nth 1 LIST_ATT)) ; Tag (string and can not contain spaces)
(cons 3 (nth 2 LIST_ATT)) ; Prompt (string)
);end list
 );entmake
);end defun

Không biết sao nữa! Tôi test thử vẫn không hiện ra được attribute cần tạo!!??

<<

 

Vẫn làm đc ^_^ nhưng sẽ không chính xác 1 số góc cong. Thử cái này xem nhé.

(defun c:test (/ ss pLlst vLst...
>>

 

Vẫn làm đc ^_^ nhưng sẽ không chính xác 1 số góc cong. Thử cái này xem nhé.

(defun c:test (/ ss pLlst vLst n p1 p2 p3)
  (command "ucs" "name" "save" "temp")
  (command "ucs" "w")
  (if (not (setq ss (ssget '((0 . "LWPOLYLINE")))))
    (print "Ban da khong chon pline.")
    (progn
      (setq pLlst (vl-remove-if
		    'listp
		    (mapcar 'cadr (ssnamex ss))
		  )
      )
      
      (foreach pl pLlst
	(setq vLst   (mapcar 'cdr
			     (vl-remove-if-not
			       '(lambda (x) (= 10 (car x)))
			       (entget pl)
			     )
		     )
	)				;setq
	(setq n 0)
	(while (< 1 (length vLst))
	  (setq	p1 (nth n vLst)
		p2 (nth (+ n 1) vLst)
		p3 (nth (+ n 2) vLst)
	  )				;setq
	  (command "_arc" "_none" p1 "_none" p2 "_none" p3)
	  (setq vLst (cddr vLst))
	)				;while
      )					;foreach
    )					;progn
  )					;if
  (command "ucs" "name" "restore" "temp")
  (command "ucs" "name" "delete" "temp")
  (princ)
)					;defun

Bạn Bee có 1 nổ lực tuyệt vời đáng trân trọng!

<<

Download lisp

Filename: 408920_test.lsp

 

Tặng bạn cái mình vẫn đang dùng

(defun c:om (/ offset_dist obj_2_offset offset_side)(setvar 'cmdecho 0)(while (=...
>>

 

Tặng bạn cái mình vẫn đang dùng

(defun c:om (/ offset_dist obj_2_offset offset_side)(setvar 'cmdecho 0)(while (= offset_dist nil)(setq offset_dist (getdist "\nKhoang cach offset: ")));while(while(while (= obj_2_offset nil)(setq obj_2_offset (entsel (strcat "\nKick vao doi tuong can offset <" (rtos offset_dist) ">: "))));while(while (= offset_side nil)(setq offset_side (getpoint "\nPhia offset: ")));while(command "offset" offset_dist obj_2_offset offset_side "")(command "erase" obj_2_offset "")(setq obj_2_offset nil)(setq offset_side nil));while(princ))

Sao down về không sử dụng được bác ah,diễn đàn bị lỗi nên lisp nó cứ dài qua phải,không có xuống hàng gì hết?Bác ketxu up lại giùm mình với.Thanks.

<<

 

Đây!

; Lisp ve thanh thep hinh tu 2 lo bulon, co doan mut. by HA, 2/6/2015
(defun C:HA( / cmd osm p1...
>>

 

Đây!

; Lisp ve thanh thep hinh tu 2 lo bulon, co doan mut. by HA, 2/6/2015
(defun C:HA( / cmd osm p1 p2)
 (command "undo" "be") (setq cmd (getvar "cmdecho") osm (getvar "osmode")) (setvar "cmdecho" 0)
 (or (and kc (or (= (type kc) 'int) (= (type kc) 'real))) (setq kc 30))
 (setq kc (cond ((getdist (strcat "\nChieu dai doan mu <" (rtos kc 2 2) ">: "))) (kc)))
 (command "mline")
 (command pause)
 (setq p1 (getvar "lastpoint"))
 (command pause)
 (setq p2 (getvar "lastpoint"))
 (command "")
 (entdel (entlast))
 (setvar "osmode" 0)
 (command "mline" (polar p1 (+ pi (angle p1 p2)) kc) (polar p2 (angle p1 p2) kc) "")
 (setvar "osmode" osm) (setvar "cmdecho" cmd) (command "undo" "e") (princ))

Oh, quá tuyệt, từ giờ dựng 1 cái trụ là đỡ tốn 2/5 thời gian rồi, hehe, cảm ơn bạn rất nhiều!

<<

Download lisp

Filename: 355117_ha.lsp