35 phút trước, Thái An 97 đã nói:

Em có tải lisp này về nhưng...

>>

35 phút trước, Thái An 97 đã nói:

Em có tải lisp này về nhưng khi load thì bị lỗi ; error: syntax error.

Mọi người giúp em fix lỗi này với ạ

Em xin cảm ơn!!

TT-thong ke block.lsp

Sửa lại cho bạn load vào hết lỗi nhé:

(defun c:ttt (/ LM:al-effectivename LM:getdynprops blk blk_name ent i lst_blk pt row ss tblobj x y htxt)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun LM:al-effectivename  (ent / blk rep)
  (if (wcmatch (setq blk (cdr (assoc 2 (entget ent)))) "`**")
   (if (and (setq rep (cdadr (assoc -3 (entget (cdr (assoc 330 (entget (tblobjname "block" blk)))) '("AcDbBlockRepBTag")))))
            (setq rep (handent (cdr (assoc 1005 rep)))))
    (setq blk (cdr (assoc 2 (entget rep))))))
  blk
 )
;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun LM:getdynprops  (blk)
  (mapcar '(lambda (x) (cons (vla-get-propertyname x) (vlax-get x 'value)))
          (vlax-invoke blk 'getdynamicblockproperties))
)
(vl-load-com)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 (or (> (setq htxt (getvar 'TEXTSIZE)) 0) (setq htxt (setvar 'TEXTSIZE 250)))
(if (setq ss (ssget (list (cons 0 "INSERT"))))
(progn 
    (setq i -1)
    (while (setq ent (ssname ss (setq i (1+ i))))
          (setq blk (vlax-ename->vla-object ent))
          (setq blk_name
(if (= "*" (substr (cdr (assoc 2 (entget ent))) 1 1))
(strcat (LM:al-effectivename ent) ": " (cdar (LM:getdynprops blk)))
(LM:al-effectivename ent)
))
          (if (not (assoc blk_name lst_blk))
           (setq lst_blk (cons (cons blk_name 1) lst_blk))
           (setq lst_blk (subst (cons blk_name (1+ (cdr (assoc blk_name lst_blk)))) (assoc blk_name lst_blk) lst_blk)))
	)
         (setq lst_blk (vl-sort lst_blk '(lambda (x y) (< (car x) (car y)))))
         (setq pt     (getpoint "\nSpecify insertion point: ")
               TblObj (vla-addtable (vla-get-modelspace (vla-get-ActiveDocument (vlax-get-Acad-Object)))
                                    (vlax-3d-point pt) (+ (length lst_blk) 2) 4 (* 1.5 htxt) (* 6 htxt)))
         (vla-SetColumnWidth TblObj 0 (* 4 htxt))
         (vla-SetColumnWidth TblObj 1 (* 12 htxt))
         (vla-put-vertcellmargin TblObj (* 0.2 htxt))
         (mapcar '(lambda (x y) (vla-setTextHeight TblObj x y))
                 (list acTitleRow acHeaderRow acDataRow)
                 (list htxt htxt (* 0.75 htxt)))
         (mapcar '(lambda (x) (vla-setAlignment TblObj x 8)) (list acTitleRow acHeaderRow acDataRow))
         (vla-MergeCells TblObj 0 0 0 2)
         (vla-setText TblObj 0 0 "Bang thong ke khoi luong")
         (vla-setText TblObj 1 0 "STT")
         (vla-setText TblObj 1 1 "Ten")
         (vla-setText TblObj 1 2 "Don vi")
         (vla-setText TblObj 1 3 "So luong")
         (setq row 2
               i   1)
         (foreach pt  lst_blk
          (vla-setText TblObj row 0 (itoa i))
          (vla-setText TblObj row 1 (car pt))
          (vla-setText TblObj row 2 "cai")
          (vla-setText TblObj row 3 (itoa (cdr pt)))
          (setq row (1+ row)
                i   (1+ i))))
  (vlax-release-object TblObj))
 (princ))

 

<<

16 giờ trước, saukhoai đã nói:

a cho e hỏi tí, lisp của...

>>

16 giờ trước, saukhoai đã nói:

a cho e hỏi tí, lisp của a chạy đc rồi nhưng e muốn cây thép nó chạy như này đc k a, lisp a chạy ra cây thép nó xếp bậc thang nhưng e muốn nó xếp như kia đc k a

 

+ Của bạn đây :

	(defun c:VTT (/ d i L40 X1 Y1 PT-end X-end Y-end scale L_Tieuchuan L PT1 PT2)

	    (Princ "Write by: Do Danh Cong")

	    (command "undo" "begin")

	    (setq L_TieuChuan

	           (list

	         (cons 10 450)

	         (cons 12 540)

	         (cons 14 630)

	         (cons 16 720)

	         (cons 18 810)

	         (cons 20 900)

	         (cons 22 990)

	         (cons 25 1125)

	         (cons 28 1260)

	         (cons 32 1455)))



	;;;;; So lieu dau vao

	      (setq L (getdist "Nhap chieu dai / Chon 2 diem: "))

	;;;;;; Luu gia tri duong kinh

	      (or #VTT_D (setq #VTT_D 16))

	      (setq #VTT_D (cond ((getreal (strcat "\nNhap D= < " (rtos #VTT_D 2 0) " >:")))(#VTT_D)))

	      (setq    Pt1 (getpoint "\n Nhap diem ve: "))

	      (setq scale (getvar "dimscale"))

	      

	      ;;;;; Tinh toan so lieu:

	      

	      (setq L40 (cdr (assoc #VTT_D L_TieuChuan))

	        X1 (car Pt1)

	        Y1 (cadr Pt1)

	        PT-end (Polar Pt1 0 L)

	        X-end (car Pt-end)

	        Y-end (cadr Pt-end)

	        i 1)

	      ;;;;;; Ve thep



	      (While  (> X-end X1)

	              (if (>= 11700 (- X-end X1))

	            (progn

	                  (command ".line" "non" Pt1 "non" Pt-End "")

	                  (setq X1  X-End))

	            (Progn

	                  (setq Pt2 (polar Pt1 0 11700))

	              (command ".line" "non" Pt1 "non" Pt2 "")

	              (setq     X1 (- (car Pt2) L40)

	                       Y1 (+ (cadr Pt1) (* 1.5 scale i))

	                i (* -1 i)

	                        Pt1 (list X1 Y1)

	                            PT-end (list X-end Y1))

	              )

	          ))

	      (command "undo" "end")

	      (Princ))

<<

39 phút trước, Doan Van Ha đã nói:

Nè bạn!

>>

39 phút trước, Doan Van Ha đã nói:

Nè bạn!

https://lispbox.wordpress.com/2015/05/05/selecting-objects-within-viewport-and-copy-it-to-clipboard-by-selecting-a-ps-viewport/

Em thử mà chưa hiểu nó hoạt động thế nào bác ạ. Cũng k thấy báo lỗi gì.

Mục đích em muốn chế lại lisp này, thay cho đoạn "(getkword "\nPress <ENTER> to go to next viewport")" để nó duyệt qua các viewport rồi chọn các đối tượng trong viewport đấy để up text, up dim theo đúng tỉ lệ của viewport ạ!

;;; Cycle Through Viewports (05-VI-2012)
(defun c:CTV( / oldCmdEcho listVPorts itemVPort )
(vl-load-com)
(setq oldCmdEcho (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(if (/= (getvar "CTAB") "Model")
 (progn
  (setq listVPorts (vl-sort (vports) '(lambda(v1 v2) (< (car v1) (car v2)))))
  (if (> (length listVPorts) 1)
   (progn
    (command "_MSPACE")
    (foreach itemVPort (cdr listVPorts)
     (setvar "CVPORT" (car itemVPort))
     (getkword "\nPress <ENTER> to go to next viewport")
    )
    (command "_PSPACE")
   )
   (prompt "\nThere are no viewports defined in this Layout!")
  )
 )
 (prompt "\nThis routine works only in Layout!")
)

(setvar "CMDECHO" oldCmdEcho)
(princ)
)

 

<<

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

Bước này bác thực...

>>

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

Bước này bác thực hiện trên field hay ở đâu vậy

E thử field lẫn vla đều không có 

(defun c:tt(/ en1 p0)
  (if (and (setq en1 (car (entsel "Chon text:")))
	   (setq p0 (getpoint "chon diem text:")))
    (entmakex (list '(0 . "TEXT") '(100 . "AcDbText") '(40 . 2.0)
		   (cons 10 p0) (cons 1 (strcat "%<\\AcObjProp Object(%<\\_ObjId " (itoa(vla-get-objectid (vlax-ename->vla-object en1))) ">%).Text>%")))))
  (princ))

Thử code trên. Xong regen lại.

Vla-put-TextString vẫn được nhe.

<<

Mình cũng tham gia tý:

(defun c:tt  (/ a d e p s _lwpoly)
  (defun _lwpoly  (l)
    (entmake (append (list (cons 0 "LWPOLYLINE")
                           (cons 100 "AcDbEntity")
                           (cons 100 "AcDbPolyline")
                           (cons 90 (length l))
                           (cons 70 1))
                     (mapcar '(lambda (p) (cons 10 (trans p 1 0))) l))))
  (setq d...
>>

Mình cũng tham gia tý:

(defun c:tt  (/ a d e p s _lwpoly)
  (defun _lwpoly  (l)
    (entmake (append (list (cons 0 "LWPOLYLINE")
                           (cons 100 "AcDbEntity")
                           (cons 100 "AcDbPolyline")
                           (cons 90 (length l))
                           (cons 70 1))
                     (mapcar '(lambda (p) (cons 10 (trans p 1 0))) l))))
  (setq d (cond (#othedglin2rec#)
                (100)))
  (initget 2)
  (setq d (cond ((getdist (strcat "\nChieu dai canh khac <" (rtos d 2 2) ">: ")))
                (d)))
  (setq #othedglin2rec# d)
  (while (setq s (ssget '((0 . "LINE"))))
    (while (and (setq e (ssname s 0)) (ssdel e s))
      (setq p (mapcar '(lambda (x) (cdr (assoc x (entget e)))) '(10 11))
            a (apply 'angle p))
      (entdel e)
      (_lwpoly (mapcar '(lambda (x y) (polar x (+ a (* y pi)) (* 0.5 d)))
                       (append p (reverse p))
                       (list 0.5 0.5 1.5 1.5)))))
  (princ))

Bạn thử xem :

(defun c:rtt(/ ss sst ent)
(setq ss (ssadd))
(while (or 
(= (setq sst (acet-list-to-ss (vl-remove-if '(lambda(x)  (null...
>>

Bạn thử xem :

(defun c:rtt(/ ss sst ent)
(setq ss (ssadd))
(while (or 
(= (setq sst (acet-list-to-ss (vl-remove-if '(lambda(x)  (null (wcmatch (acet-dxf 0 (entget x)) "*TEXT")))  (acet-ss-to-list ss)))) nil)
(>(sslength sst) 1))
(Prompt "\nXin h\U+00E3y ch\U+1ECDn \U+0111\U+1ED1i t\U+01B0\U+1EE3ng :")
   (setq ss (ssget))
) 
   (command ".rotate" ss "" (acet-dxf 10 (setq ent(entget(ssname sst 0)))) (acet-rtod (- (getangle "\nG\U+00F3c quay :") (acet-dxf 50 ent))))
)

 

không còn ý kiến gì ngoài cám ơn bạn!

<<

 

Bạn cần phải khử biến sau khi kết thúc lệnh, thêm các kiểm tra để tránh lỗi, rút ngắn câu lệnh, lisp sau chỉ thêm...

>>

 

Bạn cần phải khử biến sau khi kết thúc lệnh, thêm các kiểm tra để tránh lỗi, rút ngắn câu lệnh, lisp sau chỉ thêm vòng lặp thêm yêu cầu

(defun C:VTT()
(command "undo" "be")
  (setq cmd (getvar "cmdecho")
	osm (getvar "osmode"))
  (setvar "cmdecho" 0)
  (or (and mut (or (= (type mut) 'int) (= (type mut) 'real))) (setq mut 30)) 
  (setq mut (cond ((getdist (strcat "\nChieu dai doan mu <" (rtos mut 2 2) ">: "))) (mut)))
  (while
    (or	(setq dt (entsel "\nChon duong thang: "))
	(and (setq p1 (getpoint "\nChon diem dau"))
	     (setq p2 (getpoint p1 "\nChon diem cuoi"))
	)
    )
  (if dt
;;;    (= dt nil)
;;;	(progn
;;;	(setq p1 (getpoint "\nChon diem dau")
;;;	      p2 (getpoint p1 "\nChon diem cuoi")))
    (if
      (= "LWPOLYLINE" (cdr (assoc 0 (entget (car dt)))))
      (progn
	(setq pt (acet-geom-vertex-list (car dt))
	   p1 (car pt)
	   p2 (last pt)))
      (if
	(= "LINE" (cdr (assoc 0 (entget (car dt)))))
	(progn
        (setq dt (car dt)
	   dt (entget dt)
	   p1 (cdr (assoc 10 dt))
	   p2 (cdr (assoc 11 dt))))
	(princ "\nChon sai")))
    )
  (setvar "osmode" 0)
  (setq	p3 (polar p1 (+ pi (angle p1 p2)) mut)
	p4 (polar p2 (angle p1 p2) mut))
  (command ".mline" p3 p4 "")
  (setvar "osmode" osm)
  );while
  (setvar "cmdecho" cmd)
  (command "undo" "e")
  (princ))

Cảm ơn anh nhé! 

Ý em muốn là khi đã chọn vẽ từ 2 điểm thì chỉ lặp lại pick chọn 2 điểm liên tục hoặc khi đã chọn "line,pline" thì select line liên tục.

như vậy có được không anh!

<<

Download lisp

Filename: 406764_vtt.lsp

Chào các bạn

Nhân đọc bài Ánh xạ giá trị đối tượng text, nguồn đổi giá trị, đích bị sửa của bác Hoành,...

>>

Chào các bạn

Nhân đọc bài Ánh xạ giá trị đối tượng text, nguồn đổi giá trị, đích bị sửa của bác Hoành,

xin gửi các bạn LISP : Ánh xạ giá trị đối tượng gồm

1 . LinkT : Ánh xạ giá trị Text

2 . LinkA : Ánh xạ giá trị Diện tích

chú ý : khi sửa giá trị ở đối tượng nguồn, đối tượng đích (text) chỉ update sau khi sử dụng lệnh REGEN, SAVE, PLOT, ...

(defun c:LinkT (/ ss_ent ent ss e cmd);Link Text
 (if (> (atof (substr (getvar "ACADVER") 1 4)) 16.1) ;;;AutoCAD 2006 16.2
   (progn
     (vl-load-com)
     (command "_.undo" "_begin")
     (setq cmd (getvar "cmdecho"))
     (setvar "cmdecho" 0)
     (and (princ "\nChon Text goc : ")
   (setq ss_ent (ssget "_:S:E" '((0 . "TEXT"))) )
   (setq ent (vlax-ename->vla-object (ssname ss_ent 0)))
   (princ "\nChon Text can Link gia tri tu Text goc : ")
   (setq ss (ssget (list (cons 0 "TEXT")) ))
   (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
     (vla-put-TextString
       (vlax-ename->vla-object e)
       (strcat"%<\\AcObjProp Object(%<\\_ObjId "(vl-princ-to-string (vla-get-ObjectId ent)) ">%).TextString >%")
       )
     )
   )
     (setvar "cmdecho" cmd)
     (command "_.undo" "_end")(princ)
     )
   (alert "\nChi chay tren Autocad 2006-2010")
   )
 )

(defun c:LinkA (/ ss_ent ent ss e cmd sole tile Suff Pref);Link Area
 (if (> (atof (substr (getvar "ACADVER") 1 4)) 16.1) ;;;AutoCAD 2006 16.2
   (progn
     (vl-load-com)
     (command "_.undo" "_begin")
     (setq cmd (getvar "cmdecho"))
     (setvar "cmdecho" 0)
     (and (princ "\nChon doi tuong lay Dien tich : ")
   (setq ss_ent (ssget "_:S:E" '((0 . "*POLYLINE,ARC,SPLINE,ELLIPSE,CIRCLE"))) )
   (setq ent (vlax-ename->vla-object (ssname ss_ent 0)))
   (princ "\nChon Text can Link gia tri Dien tich : ")
   (setq ss (ssget (list (cons 0 "TEXT")) ))
   (setq sole (getvar "Luprec"));so le
   (setq tile 1);ti le
   (setq Pref "S=")
   (setq Suff " mm2")
   (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
     (vla-put-TextString
       (vlax-ename->vla-object e)
       (strcat "%<\\AcObjProp Object(%<\\_ObjId "
	       (vl-princ-to-string (vla-get-ObjectId ent) )
	       ">%).Area \\f \"%lu2%ps%pr" (itoa sole) "%ct8\">%"
	       )
       )
     )
   )
     (setvar "cmdecho" cmd)
     (command "_.undo" "_end")(princ)
     )
   (alert "\nChi chay tren Autocad 2006-2010")
   )
 )

Anh ơi cái này áp dụng cho cad 2007 được không vậy? Em áp dụng sảy ra trường hợp như sau: chọn đối tượng nguồn, sau đó chọn các

đối tượng muốn link rồi. Sau đó thì các text được chọn bị ẩn hết. Thay đổi giá trị nguồn, sau đó regen lại nhưng vẫn không thấy các đối tượng

text bị ẩn hiện lên và thay đổi.

Mong anh giải thích dùm. Cảm ơn anh.

<<

28 phút trước, duy782006 đã nói:

Túm lại là bạn biết làm rồi...

>>

28 phút trước, duy782006 đã nói:

Túm lại là bạn biết làm rồi và đang đố mọi người hay là bãn muốn vậy và đang hỏi mọi người cách làm?

Cái này có gì mà đánh đố đâu anh. Em thấy các tiền bối đã làm nhiều rồi, tra theo từ khóa là ra. Của em cùng toàn cóp nhặt rồi edit lại chứ có gì đâu.

Giờ rảnh ngồi máy gửi code em chế lại thôi chứ cũng không đủ khả năng viết:

(vl-load-com)
;; Add Support File Search Paths  -  Lee Mac
;; Adds a list of Support File Search Paths, excluding duplicates and invalid paths.
;; lst -  list of paths to add, e.g. '("C:\\Folder1" "C:\\Folder2" ... )
;; Returns:  "ACAD" Environment String following modification
;; (LM:sfsp+ <lst>)
;; (LM:sfsp+ '("C:\\Folder1" "C:\\Folder2" "C:\\Folder3"))

(defun LM:sfsp+ ( lst )
    (   (lambda ( str lst )
            (if (setq lst
                    (vl-remove-if
                       '(lambda ( x )
                            (or (vl-string-search (strcase x) (strcase str))
                                (not (findfile x))
                            )
                        )
                        lst
                    )
                )
                (setenv "ACAD" (strcat str ";" (apply 'strcat (mapcar '(lambda ( x ) (strcat x ";")) lst))))
            )
        )
        (vl-string-right-trim ";" (getenv "ACAD"))
        (mapcar '(lambda ( x ) (vl-string-right-trim "\\" (vl-string-translate "/" "\\" x))) lst)
    )
)
;======================================================================================================================
(defun c:AutoLoadAllLisps ( / lst pth x dir )
  (princ "\nAutoRun AutoLoadAllLisps Programs!")
  (if (not (findfile "AutoLoadAllLisps.lsp"))
	(progn
	(setq dir (acet-ui-pickdir "" "" "Ch\U+1ECDn th\U+01B0 m\U+1EE5c ch\U+1EE9a t\U+1EC7p AutoLoadAllLisps.lsp")); de them vao Support File Search Path cua AutoCad"
	(setq dirtv (strcat dir "\\" "Thu vien"))
	(setq dirlk (strcat dir "\\" "Lisp khac"))
	(LM:sfsp+ (list dir dirtv dirlk));Ham them thu muc va SFSP cua AutoCad cua Lee Mac
	(setenv "PrinterStyleSheetDir" dirtv)
	);end progn
  )
  (setq pth (findfile "AutoLoadAllLisps.lsp"))
  (setq pth (vl-string-right-trim "AutoLoadAllLisps.lsp" pth))
  (setq lst (vl-directory-files pth "*.vlx" 1))
  (setq lst (append lst (vl-directory-files pth "*.fas" 1)))
  (setq lst (append lst (vl-directory-files pth "*.lsp" 1)))
  (setq lst (vl-remove "AutoLoadAllLisps.lsp" lst)) 
  (foreach x lst (load x))
  (princ "\nProgram AutoLoadAllLisps was Written by KLN!")
  (princ)
)
;======================================================================================================================
; AutoRun AutoLoadAllLisps Programs when Open AutoCad if Add this programs in Startup Suite in Appload!!!
(c:AutoLoadAllLisps)

 

<<

;;; ReAssHatch.lsp requires Hatchutil.lsp which came with Express Tools.
;;; Add boundaries & reassociate them to a selection of Hatch entities.
;;; by: Tom Beauford
;;; BeaufordT@LeonCountyFL.gov
;;; LEON COUNTY PUBLIC WORKS ENGINEERING SECTION
(defun c:MBH ( / ss e# ent)
  (setq ss (ssget '((0 . "HATCH")(71 . 0)))
        e# (sslength ss)
  )
  (if(not acet-hatch-remake)(load "Hatchutil"))
  (repeat e#
    (setq...
>>

;;; ReAssHatch.lsp requires Hatchutil.lsp which came with Express Tools.
;;; Add boundaries & reassociate them to a selection of Hatch entities.
;;; by: Tom Beauford
;;; BeaufordT@LeonCountyFL.gov
;;; LEON COUNTY PUBLIC WORKS ENGINEERING SECTION
(defun c:MBH ( / ss e# ent)
  (setq ss (ssget '((0 . "HATCH")(71 . 0)))
        e# (sslength ss)
  )
  (if(not acet-hatch-remake)(load "Hatchutil"))
  (repeat e#
    (setq e# (- e# 1))
    (acet-hatch-remake (ssname ss e#))
    (entdel (ssname ss e#))
  )
  (princ)
)

Cad 2007 thì thử dùng cái này thử xem.

Vào lúc 22/4/2021 tại 21:44, jimmy12 đã nói:

>>

Vào lúc 22/4/2021 tại 21:44, jimmy12 đã nói:

Chào các bác.

  Em là dân cơ khí, muốn biểu thị lỗ bulong như hình mà cứ phải dim để edit, bác nào cao tay viết cho e cái lisp hoặc có thể hướng dẫn em viết không ạ

  Em muốn gõ lênh M8 -> kích vào dim -> hiển thị luôn là M8x20,

Cảm ơn các bác đã đọc.

(defun c:M8 (/)
(if (setq ss (ssget"_:L" (list (cons 0 "DIMENSION")) ))
		(progn  
				(foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
					(vla-put-TextOverride (vlax-ename->vla-object ent)
						(strcat "M8x20")
					)
				)
	(princ)  
		)
	)
 )

 

<<

 

Bên trên là version 3.0. người viết lisp trên chưa hỗ trợ chọn nhiều đối tượng 1 lần. Chưa hỗ trợ đối tượng mũi...

>>

 

Bên trên là version 3.0. người viết lisp trên chưa hỗ trợ chọn nhiều đối tượng 1 lần. Chưa hỗ trợ đối tượng mũi tên Leader. Mình update lên version 3.1 hỗ trợ thêm 2 tính năng này. Mình đổi luôn tên lệnh thành RV và RVV tránh trùng với lệnh Reverse của Cad

;|
REVERSE - Reverses line, arc, circle, ellipse, spline, polyline, text,
    	hatch pattern, or gradient fill.
 
   Reverses all line, arc, circle, ellipse, spline, polyline, and
   lightweight polyline entities.
 
   Circles, arcs, and ellipses are converted to polylines; other objects
   retain their respective entity type.  Circles and circular arcs are
   rendered as heavyweight polylines if the system variable plinetype = 0,
   or lightweight polylines if plinetype > 0.  Ellipses and elliptical
   arcs are rendered as high-resolution, curve-fit polylines with up to 64
   exact vertices and tangents.
 
   Reverses all text entities including single-line text, attributes,
   multiline text, dimension text, and remote text.  Fonts with leading or
   trailing white space, and text styles with upside down, backward, or
   vertical effects are fully supported.
 
   Rotates all hatch patterns 90&;#176; counterclockwise.  Rotates all gradient
   fills 180&;#176;. Solid fills are ignored.
 
   Single-line text, multiline text, attributes, hatch patterns, and
   gradient fills may be reversed within blocks.  All other block components
   are ignored.  Nested blocks are not supported.
 
   Preserves color, layer, linetype, linetype scale, plot style, lineweight,
   thickness, elevation, global width, and text style properties.  Preserves
   circular, quadratic, and cubic fitting.  Preserves vertex bulge, segment
   width, and vertex tangent.
 
Copyright(c)2005-2012 Version 3.1 (US)
   Tom Davis (tdavis@metzgerwillard.com)
 
Revision History:
   10/10/12 - Added support for Leader object by Le Thuy Linh - Tri Tue Viet.jsc - VietNam
   10/10/12 - Updated support multiselect object by Le Thuy Linh - Tri Tue Viet.jsc - VietNam
   08/19/10 - Added support for hatch patterns and gradient fills.
   01/27/10 - Removed references.
          	See http://www.metzgerwillard.us/tdavis/lisp/reverse.html
   11/06/08 - Updated reference links.
   09/21/08 - Updated reference links.
   02/15/08 - Updated email address.
   09/09/07 - Added underscores for international language support.
   08/26/07 - Added support for mtext with exact line spacing; single-
          	line text fonts with leading or trailing white space; and
          	upside down, backward, and vertical text effects.
   08/05/07 - Modified to select objects with nentsel instead of entsel;
          	extended support to all text objects in block references
          	including attributes and dimension text.
   10/05/05 - Added limited dimension text support.
   09/22/05 - Added support for single-line text, multiline text, and
          	remote text.
   09/17/05 - First release with initial support for all line, arc,
          	circle, ellipse, spline, and polyline entities.
|;
;------------------------------------------------------------------------------
(defun c:rvv ( / oldecho oldsnap ent e etyp)
  ;reverse text, line, arc, circle, ellipse, spline, or polyline
  (setq oldecho (getvar "cmdecho")
    	oldsnap (getvar "osmode")
  )
  (setvar "cmdecho" 0)                                    	;turn off echo
  (if (< oldsnap 16384) (setvar "osmode" (+ oldsnap 16384)))  ;turn off osnap
  (command "_select" "")                                  	;deselect all
  (while (setq ent (nentsel "\nSelect reversible object: "))
	(setq e	(car ent)
      	etyp (cdr (assoc 0 (entget e)))
	)
	;exclude block components that are neither text nor hatching
	(if (or (< (length ent) 4)(= etyp "TEXT")(= etyp "MTEXT")(= etyp "HATCH"))
  	(progn
    	(while (= (cdr (assoc 0 (entget e))) "VERTEX")    	;skip vertices
      	(setq e (entnext e))
    	)
    	(if (= (cdr (assoc 0 (entget e))) "SEQEND")          	;get hwpolyline
      	(setq e (cdr (assoc -2 (entget e))))            	;	or ellipse
    	)
    	(setq etyp (cdr (assoc 0 (entget e))))
    	(princ etyp)
    	(command "_undo" "_begin")
    	(cond
      	((= etyp "LWPOLYLINE")(revlwpline e))
      	((= etyp "POLYLINE")  (revhwpline e))
      	((= etyp "LINE")  	(revline	e))
      	((= etyp "ARC")	(revarc  e))
      	((= etyp "CIRCLE")	(revcircle  e))
      	((= etyp "HATCH")  (revhatch   e))
      	((= etyp "LEADER")	(revleader  e))
      	((= etyp "ELLIPSE")   (revellipse e))
      	((= etyp "MTEXT")  (revmtext   e))
      	((= etyp "TEXT")  	(revtext	e etyp))
      	((= etyp "ATTRIB")	(revtext	e etyp) (entupd e))
      	((= etyp "RTEXT")  (revrtext   e))
      	((= etyp "SPLINE")	(command "_splinedit" e "_e" ""))
    	)
    	(if (> (length ent) 3)(entupd (car (cadddr ent))))	;block text
                                                          	;or hatching
    	(command "_undo" "_end")
  	)
  	(princ "INSERT")
	)
  )
  (setvar "cmdecho" oldecho)
  (setvar "osmode"  oldsnap)
  (princ)
)
(defun c:rv ( / oldecho oldsnap ent e etyp ss id)
  (prompt "\nSelect reversible object: ")
  (setq oldecho (getvar "cmdecho")
    	oldsnap (getvar "osmode"))
  (setvar "cmdecho" 0)                                   		;turn off echo
  (if (< oldsnap 16384) (setvar "osmode" (+ oldsnap 16384))) 	;turn off osnap
  (command "_select" "")                                 		;deselect all
  (if (setq id -1 ss (ssget))
  (repeat (sslength ss)
	(setq  e (ssname ss (setq id (1+ id)))
   		etyp (cdr (assoc 0 (entget e))))
	;exclude block components that are neither text nor hatching
	(if (or (< (length ent) 4)(= etyp "TEXT")(= etyp "MTEXT")(= etyp "HATCH"))
  	(progn
    	(while (= (cdr (assoc 0 (entget e))) "VERTEX")   		;skip vertices
      	(setq e (entnext e)))
    	(if (= (cdr (assoc 0 (entget e))) "SEQEND")          	;get hwpolyline
      	(setq e (cdr (assoc -2 (entget e)))))              	;	or ellipse
    	(setq etyp (cdr (assoc 0 (entget e))))
    	;(princ etyp)
    	(command "_undo" "_begin")
    	(cond
      	((= etyp "LWPOLYLINE")(revlwpline e))
      	((= etyp "POLYLINE")  (revhwpline e))
      	((= etyp "SPLINE")	(command "_splinedit" e "_e" ""))
      	((= etyp "TEXT")  	(revtext	e etyp))
      	((= etyp "MTEXT") 	(revmtext   e))
      	((= etyp "HATCH") 	(revhatch   e))        
      	((= etyp "LEADER")	(revleader  e))
      	((= etyp "LINE")  	(revline	e))
      	((= etyp "ARC")   	(revarc 	e))
      	((= etyp "CIRCLE")	(revcircle  e))
      	((= etyp "ELLIPSE")   (revellipse e))        
      	((= etyp "ATTRIB")	(revtext	e etyp) (entupd e))
      	((= etyp "RTEXT") 	(revrtext   e)))
    	(if (> (length ent) 3)(entupd (car (cadddr ent))))   	;block text  ;or hatching
    	(command "_undo" "_end"))
  	(princ "INSERT"))))
  (setvar "cmdecho" oldecho)
  (setvar "osmode"  oldsnap)
  (princ))
;------------------------------------------------------------------------------
;LWPOLYLINE
 
(defun revlwpline (e / footer done vertices header flag)
  ;reverse lightweight polyline
  (foreach item (reverse (entget e))
	(cond
  	((not done)
    	(cond
      	((= (car item) 40)
        	(setq footer (cons (cons 41 (cdr item)) footer)  	;swap width
              	done t
        	)
      	)
      	((= (car item) 41)
        	(setq footer (cons (cons 40 (cdr item)) footer))  ;swap width
      	)
      	((= (car item) 42)
        	(setq footer (cons (cons 42 (- (cdr item))) footer)) ;negate bulge
      	)
      	((= (car item) 210)
        	(setq footer (cons item footer))
      	)
    	)
  	)
  	((= (car item) 10)
    	(setq vertices (cons item vertices))
  	)
  	((= (car item) 40)
    	(setq vertices (cons (cons 41 (cdr item)) vertices))  ;swap width
  	)
  	((= (car item) 41)
    	(setq vertices (cons (cons 40 (cdr item)) vertices))  ;swap width
  	)
  	((= (car item) 42)
    	(setq vertices (cons (cons 42 (- (cdr item))) vertices)) ;negate bulge
  	)
  	(t (setq header (cons item header)))
	)
  )
  (setq flag (assoc 70 header))
  (if (< (cdr flag) 128)          	;turn on linetype generation
	(setq header (subst (cons 70 (+ (cdr flag) 128)) flag header))
  )
  (entmod (append header (reverse vertices) footer))
)
;------------------------------------------------------------------------------
;POLYLINE
 
(defun revhwpline (e / oldname old ent1 buldge end start ent tangent radians
                	vertex vertices flag)
  ;reverse heavyweight polyline
  (setq oldname  e
    	old   (entget oldname)
    	e  (entnext e)
    	ent1  (entget e)          	;get first vertex
    	bulge (cdr (assoc 42 ent1))
    	end   (cdr (assoc 41 ent1))
    	start (cdr (assoc 40 ent1))
    	e  (entnext e)
    	ent   (entget e)          	;get second vertex
  )
  (while (= (cdr (assoc 0 ent)) "VERTEX")
	(if (= (logand (cdr (assoc 70 ent)) 2) 2)
  	(setq tangent (assoc 50 ent)
        	radians (- (cdr tangent) pi) ;reverse tangent
        	ent  (subst (cons 50 radians) tangent ent)
  	)
	)
	(setq vertex   (subst (cons 42 (- bulge))(assoc 42 ent) ent)	;negate bulge
      	vertex   (subst (cons 41 start)	(assoc 41 ent) vertex) ;swap width
      	vertex   (subst (cons 40 end)  	(assoc 40 ent) vertex) ;swap width
      	bulge	(cdr  (assoc 42 ent))
      	end  	(cdr  (assoc 41 ent))
      	start	(cdr  (assoc 40 ent))
      	vertices (cons vertex vertices)
      	e    	(entnext e)
      	ent  	(entget e)        	;get next vertex or seqend
	)
  )
  (setq flag (assoc 70 old))
  (if (< (cdr flag) 128)          	;turn on linetype generation
	(setq old (subst (cons 70 (+ (cdr flag) 128)) flag old))
  )
  (entmake old)                      	;make new polyline
  (foreach ent vertices (entmake ent))   ;make new vertices
  (if (= (logand (cdr (assoc 70 ent1)) 2) 2)
	(setq tangent (assoc 50 ent1)
      	radians (- (cdr tangent) pi)   ;reverse tangent
      	ent1	(subst (cons 50 radians) tangent ent1)
	)
  )
  (setq ent1 (subst (cons 42 (- bulge))(assoc 42 ent1) ent1) ;negate bulge
    	ent1 (subst (cons 41 start)	(assoc 41 ent1) ent1) ;swap width
    	ent1 (subst (cons 40 end)  	(assoc 40 ent1) ent1) ;swap width
  )
  (entmake ent1)                  	;make last new vertex
  (entmake ent)                      	;make new seqend
  (entdel oldname)                	;delete old polyline
)
;------------------------------------------------------------------------------
;LINE
 
(defun revline (e / ent start end)
  ;reverse line
  (setq ent   (entget e)
    	start (assoc 10 ent)
    	end   (assoc 11 ent)      	;swap line endpoints
    	ent   (subst (cons 10 (cdr end)) start ent)
    	ent   (subst (cons 11 (cdr start)) end ent)
  )
  (entmod ent)
)
;------------------------------------------------------------------------------
;ARC
 
(defun revarc (e)
  ;reverse arc
  (command "_pedit" e "_y" "_l" "_on" "");turn arc into polyline
  (setq e (entlast))
  (if (> (getvar "plinetype") 0)
	(revlwpline e)
	(revhwpline e)
  )
)
;------------------------------------------------------------------------------
;CIRCLE
 
(defun revcircle (e / ent radius center pt1 pt2)
  ;reverse circle
  (setq ent	(entget e)
    	radius (cdr (assoc 40 ent))
    	center (cdr (assoc 10 ent))
    	pt1	(mapcar '+ center (list radius 0 0))
    	pt2	(mapcar '- center (list radius 0 0))
  )
  (command "_break" e pt1 pt2)            	;turn circle into semicircle
  (command "_pedit" e "_y" "_l" "_on" "_c" "");turn semicircle into closed polyline
  (setq e (entlast))
  (if (> (getvar "plinetype") 0)
	(revlwpline e)
	(revhwpline e)
  )
)
;------------------------------------------------------------------------------
;HATCH
 
(defun revhatch (e / ent solid item ang pi2 new y)
  ;reverse hatch
  (setq ent   (entget e)
    	solid (cdr (assoc 70 ent))            	;solid fill flag
    	pi2   (* 2 pi)
  )
  (cond
	((= solid 0)                              	;pattern fill
  	(foreach item (reverse ent)
    	(cond
      	((or (= (car item) 52) (= (car item) 53))  ;pattern or line angle
        	(setq ang (+ (* pi 0.5) (cdr item)))  ;rotate 90°
        	(if (>= ang pi2) (setq ang (- ang pi2))) ;normalize angle
        	(setq new (cons (cons (car item) ang) new))
      	)
      	((or (= (car item) 43) (= (car item) 45))  ;line origin or offset x
        	;rotate line origin or offset 90°: new y = old x; new x = - old y
        	(setq new (cons (cons (1+ (car item)) (cdr item)) new)
              	new (cons (cons (car item) (- y)) new))
      	)
      	((or (= (car item) 44) (= (car item) 46))  ;line origin or offset y
        	(setq y (cdr item))
      	)
      	(t (setq new (cons item new)))
    	)
  	)
  	(entmod new)
	)
	((= solid 1)                              	;solid fill
  	(if (= (cdr (assoc 450 ent)) 1)            	;gradient fill
    	(progn
      	(setq item (assoc 460 ent)          	;gradient angle
            	ang  (+ pi (cdr item))        	;rotate 180°
      	)
      	(if (>= ang pi2) (setq ang (- ang pi2)))   ;normalize angle
      	(setq ent (subst (cons 460 ang) item ent))
      	(entmod ent)
    	)
  	)
	)
  )
)
;------------------------------------------------------------------------------
;RTEXT
 
(defun revrtext (e / ent ins w h rot ang hd vd new)
  ;reverse rtext
  (command "_explode" e)                  	;explode rtext into mtext
  (setq ent  (entget (entlast))              	;get mtext
    	w	(cdr (assoc 42 ent))            	;width
    	h	(cdr (assoc 43 ent))            	;height
  )
  (command "_undo" 1)
  (setq ent  (entget e)                      	;get rtext
    	ins  (assoc 10 ent)                  	;insertion point
    	rot  (assoc 50 ent)                  	;rotation
    	ang  (cdr rot)
    	hd   (polar '(0 0 0)	ang    	w) ;horizontal displacement
    	vd   (polar '(0 0 0) (- ang (/ pi 2)) h) ;vertical displacement
    	new  (mapcar '+ (cdr ins) hd vd)  	;new insertion point
    	ang  (rem (+ ang pi) (* 2 pi))    	;normalize angle
    	ent  (subst (cons 50 ang) rot ent)	;reverse direction
    	ent  (subst (cons 10 new) ins ent)	;set new insertion point
  )
  (entmod ent)
)
;------------------------------------------------------------------------------
;TEXT or ATTRIB
 
(defun revtext (e etyp / vc ent box hj vj rot ang p1 p2 h w
                  	dist phi hd vd new gf gfs sn p s done)
  ;reverse text or attribute
  (if (= etyp "TEXT")
	(setq vc 73) ;text
	(setq vc 74) ;attribute
  )
  (setq ent (entget e)
    	box (textbox ent)                          	;((x1 y1 z1)(x2 y2 z2))
    	gf  (cdr (assoc 71 ent))                	;generation flag
    	sn  (cdr (assoc  7 ent))                	;style name
    	hj  (cdr (assoc 72 ent))                	;horizontal justification
    	vj  (cdr (assoc vc ent))                	;vertical justification
    	rot (assoc 50 ent)                      	;rotation
    	ang (cdr rot)                              	;angle
    	p1  (assoc 10 ent)                      	;first  alignment point
    	p2  (assoc 11 ent)                      	;second alignment point
    	h   (cdr (assoc 40 ent))                	;displacement height
    	p   1                                      	;rewind pointer
  )
  (while (not done)                  	;traverse style table
	(setq s   (tblnext "Style" p)
      	p   nil                    	;reset pointer
	)
	(if (= sn (cdr (assoc 2 s)))  	;find style name
  	(progn
    	(setq done t
          	gfs  (cdr (assoc 71 s))	;style generation flag
    	)
    	(if (= (logand (cdr (assoc 70 s)) 4) 4)
      	(setq gf (1+ gf))          	;vertical
    	)
  	)
	)
  )
  (if  (= gfs (logand gf gfs)) ;exclude conflicting generation flags
	(progn
  	(cond                                        	;displacement width
    	((= hj 0)                    	;left
      	(setq w (+ (caadr box) (caar box)))
    	)
    	(t                        	;otherwise
      	(setq dist (distance (cdr p1) (cdr p2))
            	phi  (angle	(cdr p1) (cdr p2))
            	dist (abs (* dist (cos (- phi ang))))
      	)
      	(if (= (logand gf 2) 2) (setq dist (- dist)))	;backward
      	(if (or (= hj 5) (= hj 3))
        	(setq w (-(+ (caar box) (caadr box))  	dist))  ;fit or aligned
        	(setq w (-(+ (caar box) (caadr box)) (* 2 dist))) ;right, center, middle
      	)
    	)
  	)
  	(if (= vj 1)                	;bottom
    	(setq dist (distance (cdr p1) (cdr p2))
          	phi  (angle	(cdr p1) (cdr p2))
          	dist (abs(* dist (sin (- phi ang))))  ;descender depth
          	h	(+ h (* 2 dist))
    	)
  	)
  	(if (= (logand gf 1) 1)        	;vertical
    	(cond
      	((or (> hj 2) (= hj 1))                  	;center,aligned,middle,fit
        	(setq h 0)
      	)
      	(t                                    	;otherwise
        	(setq h (- (cadadr box) (cadar box)))
        	(if (= (+ hj vj) 0) (setq h (- h)))    	;baseline left
        	(cond
          	((and (= hj 0) (> vj 0)) (setq vj 3))	;bottom,middle,top left
          	((= hj 2) (setq vj 0))            	;right
        	)
      	)
    	)
  	)
  	(if (= (logand gf 4) 4) (setq h (- h)))      	;upside down
  	(setq hd   (polar '(0 0 0)	ang    	w)   ;horizontal displacement
        	vd   (polar '(0 0 0) (+ ang (/ pi 2)) h)   ;vertical displacement
  	)
  	(cond                          	;compute new alignment point
    	((or (and (= vj 0) (= hj 1))  ;center
      	(and (= vj 0) (= hj 2))  ;right
      	(= vj 1))            	;bottom
      	(setq new (mapcar '+ (cdr p2) hd vd))
    	)
    	((or (= vj 2) (= hj 4))      	;middle
      	(setq new (mapcar '+ (cdr p2) hd))
    	)
    	((= vj 3)                    	;top
      	(setq new (mapcar '+ (cdr p2) hd)
            	new (mapcar '- new vd)
      	)
    	)
  	)
  	(cond
    	((= (+ hj vj) 0)          	;left
      	(setq new (mapcar '+ (cdr p1) hd vd)
            	ent (subst (cons 10 new) p1 ent)  	;set new alignment point
            	ent (subst (cons 50 (+ ang pi)) rot ent) ;reverse direction
      	)
    	)
    	((or (= hj 5) (= hj 3))      	;fit or aligned
      	(setq new (mapcar '+ (cdr p2) vd hd)
            	ent (subst (cons 10 new) p1 ent)  	;swap alignment points
            	new (mapcar '+ (cdr p1) vd hd)
            	ent (subst (cons 11 new) p2 ent)
      	)
    	)
    	(t
      	(setq ent (subst (cons 11 new) p2 ent)  	;set new alignment point
            	ent (subst (cons 50 (+ ang pi)) rot ent) ;reverse direction
      	)
    	)
  	)
  	(entmod ent)
	)
	(alert (strcat "The selected text object is not compatible with\n"
            	"its text style.  When the text style is upside\n"
            	"down or backwards, the text object should also	\n"
            	"be upside down or backwards."))
  )
)
;------------------------------------------------------------------------------
;MTEXT (including dimension text)
 
(defun revmtext (e / ent ins w h just lss ls ch rot hd vd new)
  ;reverse mtext or dimension text
  (setq ent  (entget e)
    	ins  (assoc 10 ent)          	;insertion point
    	w	(cdr (assoc 42 ent))    	;width
    	h	(cdr (assoc 43 ent))    	;displacement height
    	just (cdr (assoc 71 ent))    	;justification
    	rot  (assoc 50 ent)          	;rotation
    	lss  (cdr (assoc 73 ent))    	;line spacing style
    	ch   (cdr (assoc 40 ent))    	;character height
    	ls   (/ ch 3)                	;interline half-space
	;ls = (5 ch/3 - ch)/2 = ch/3
  )
  (cond
	((and (= lss 2) (> just 6))      	;exact bottom
  	(setq h (+ h ls))
	)
	((and (= lss 2) (< just 4))      	;exact top
  	(setq h (- h ls))
	)
	((= lss 2)                    	;exact middle
  	(setq h ls)
	)
	((and (> just 3) (< just 7))  	;at least middle
  	(setq h 0)
	)
  )
  (setq hd   (polar '(0 0 0)	(cdr rot)    	w) ;horizontal displacement
    	vd   (polar '(0 0 0) (- (cdr rot) (/ pi 2)) h) ;vertical displacement
  )
  (cond                              	;compute new insertion point
	((= just 1)                      	;top left
  	(setq new (mapcar '+ (cdr ins) hd vd))
	)
	((= just 2)                      	;top center
  	(setq new (mapcar '+ (cdr ins) vd))
	)
	((= just 3)                      	;top right
  	(setq new (mapcar '- (cdr ins) hd)
        	new (mapcar '+ new vd)
  	)
	)
	((= just 4)                      	;middle left
  	(setq new (mapcar '+ (cdr ins) hd)
        	new (mapcar '- new vd)
  	)
	)
	((= just 5)                      	;middle center
  	(setq new (mapcar '- (cdr ins) vd))
	)
	((= just 6)                      	;middle right
  	(setq new (mapcar '- (cdr ins) hd vd))
	)
	((= just 7)                      	;bottom left
  	(setq new (mapcar '+ (cdr ins) hd)
        	new (mapcar '- new vd)
  	)
	)
	((= just 8)                      	;bottom center
  	(setq new (mapcar '- (cdr ins) vd))
	)
	((= just 9)                      	;bottom right
  	(setq new (mapcar '- (cdr ins) hd vd))
	)
  )
  (setq ent (subst (cons 10 new) ins ent)          	;set new insertion point
    	ent (subst (cons 50 (+ (cdr rot) pi)) rot ent) ;reverse direction
  )
  (entmod ent)
)
;------------------------------------------------------------------------------
;ELLIPSE
 
(defun revellipse (e / old oldent center p1 ratio start end major a b rot
                	minor inc tol 2pi i j phi closed p tan ent flag)
  ;reverse ellipse
  (setq old	e
    	oldent (entget old)
    	center (cdr (assoc 10 oldent))
    	p1  (cdr (assoc 11 oldent))
    	ratio  (cdr (assoc 40 oldent))
    	start  (cdr (assoc 41 oldent))
    	end	(cdr (assoc 42 oldent))
    	major  (mapcar '+ center p1)
    	a  	(distance center major)
    	b  	(* ratio a)
    	rot	(angle center major)
    	minor  (polar center (+ rot (/ pi 2)) <img src='http://www.cadviet.com/forum/public/style_emoticons/<#EMO_DIR#>/cool.png' class='bbc_emoticon' alt='B)' />
  )
  (setq inc 64                    	;number of vertices on full ellipse
    	tol 1e-5                  	;closure tolerance
    	2pi (* 2 pi)
    	i   (1+ (fix (+ (* (/ inc 2pi) start) 0.5))) ;start index
    	j	(fix (+ (* (/ inc 2pi)   end) 0.5))  ;end index
    	phi (list start)
  )
  (while (< i j)                  	;build parameter list
	(setq phi (cons (* (/ 2pi inc) i) phi)
      	i   (1+ i)
	)
  )
  (if (and (< start tol) (< (abs (- end 2pi)) tol))
	(setq closed t)
	(setq closed nil
      	phi	(cons end phi)
	)
  )
  ;parametric ellipse in object coordinate system
  ;  x = a cos(q);  y = b sin(q);  r = b/a
  ;  dx/dq = -a sin(q);  dy/dq = b cos(q)
  ;  dy/dx = -b/a cot(q) = -r^2 x/y
  ;  tangent direction = atan(dy/dx)
 
  (setq p   (mapcar '(lambda (q)  	;compute OCS points on ellipse
                	(list (* a (cos q)) (* b (sin q)))
              	)
              	phi
        	)
    	tan (mapcar '(lambda (q)  	;compute WCS tangent directions
                	(+ (atan (* (- (expt ratio 2)) (car q)) (cadr q)) rot)
              	)
              	p
        	)
  )
  (command "_ucs" "_n" 3 center major minor)  	;create OCS
  (setq p (mapcar '(lambda (q)(trans q 1 0)) p))  ;transform from OCS to WCS
  (command "_ucs" "_p")                          	;restore UCS
  (command "_pline")
  (mapcar 'command p)
  (command "")
  (command "_matchprop" old (entlast) "")
  (if closed
	(command "_pedit" (entlast) "_l" "_on" "_c" "_f" "");force hwpline creation
	(command "_pedit" (entlast) "_l" "_on"  	"_f" "")
  )
  (setq e   (entnext (entlast))
    	ent (entget e)            	;get first vertex
    	i   0
  )
  (while (= (cdr (assoc 0 ent)) "VERTEX")
	(setq flag (assoc 70 ent))
	(if (/= (logand (cdr flag) 1) 1)  ;skip curve fitting vertices
  	(progn                      	;set tangent and flag bit
    	(setq ent (subst (cons 50 (nth i tan)) (assoc 50 ent) ent)
          	i   (1+ i)
          	ent (subst (cons 70 (+ (cdr flag) 2)) flag ent)
    	)
    	(entmod ent)
  	)
	)
	(setq e   (entnext e)
      	ent (entget e)          	;get next vertex or seqend
	)
  )
  (command "_pedit" (entlast) "_f" "")   ;update fit
  (entdel old)                    	;delete ellipse
)
(princ)
;------------------------------------------------------------------------------
;LEADER by Le Thuy Linh - Tri Tue Viet.jsc
(defun revleader (e / lst1 lst2 lst10)
(if (> (atoi (getvar "acadver")) 17) (vl-cmdf "._Chprop" e "" "A" "N" ""))
(foreach asoc (entget e)
  (if (/= (car asoc) 10)
   (if lst10
	(setq lst2 (cons asoc lst2))
	(setq lst1 (cons asoc lst1)))
   (setq lst10 (cons asoc lst10))))
(entmod (append (reverse lst1) lst10 (reverse lst2)))
(if (> (atoi (getvar "acadver")) 17) (vl-cmdf "._Chprop" e "" "A" "Y" "")))

Mong bạn cập nhật thêm đối tượng multiline. Tôi dùng mline thường xuyên, mỗi lần muốn đổi chiều cho nó thì phải nắm grip lôi kéo rất bất tiện.

 

Xin cảm ơn

<<

Cảm ơn bác Hạ đã quan tâm, mục đích gom nhóm của em ở đây nằm trong một bài toán lớn hơn, các bước em giải quyết bao gồm:

1. Chọn tất cả các text, mtext, line, LWPolyline (có 2 điểm) 

2. Chia cho các đối tượng  có cùng góc xoay x cộng trừ 3 độ, và cùng một layer vào một nhóm (ví dụ text có góc xoay là 0 độ thì các line, LWPolyline từ 357 đến 3 độ cũng được gom vào...

Cảm ơn bác Hạ đã quan tâm, mục đích gom nhóm của em ở đây nằm trong một bài toán lớn hơn, các bước em giải quyết bao gồm:

1. Chọn tất cả các text, mtext, line, LWPolyline (có 2 điểm) 

2. Chia cho các đối tượng  có cùng góc xoay x cộng trừ 3 độ, và cùng một layer vào một nhóm (ví dụ text có góc xoay là 0 độ thì các line, LWPolyline từ 357 đến 3 độ cũng được gom vào một nhóm)

3. Làm các phần tiếp theo của lisp

Nếu bác có thời gian thì giúp em bước 1 và bước 2 với. Hiện tại em mới chỉ chia được theo cùng layer còn chưa chia được theo góc xoay. Em cảm ơn bác, em xin post phần lisp em đã viết lên đây ạ

(defun c:XL ( / LM:Unique doidauline sortline del_duplicate_line main tapobj f1 f bientam list_dxf list_layer m taptext tapline tapdt dataout)
(setvar 'cmdecho 0)
(vl-load-com)
(command "undo" "BE")
;=========================================================================================================
; Del duplicate text
(defun LM:Unique ( l )
    (if l (cons (car l) (LM:Unique (vl-remove (car l) (cdr l)))))
)
;==========================================================================================================
; point: (list x y z)
; list_line (list '((list x y z) (list x y z)) '((list x y z) (list x y z)) ...)
(defun doidauline ( point list_line )	
	(setq list_line (mapcar '(lambda (x)	(if (> (distance point (car x))(distance point (last x)))
											(reverse x)
											x
											)	 
							)
							list_line
					)
		)
	list_line	
)
;==========================================================================================================
; point: (list x y z)
; list_line (list '((list x y z) (list x y z)) '((list x y z) (list x y z)) ...)
(defun sortline ( point list_line )
	(setq 	list_line (doidauline point list_line)
			list_line	(vl-sort list_line 
								'(lambda (x y)(< (distance point (car x)) (distance point (car y))))
						)
	)
	list_line
)	
;==========================================================================================================
; Del duplicate line (after resevere whole line to the same direction
(defun del_duplicate_line ( point lst numric-fuzz / a b lstkq )
	(setq lst (sortline point lst))
	(while 
		(setq	a	(car lst)
				b	(cadr lst))
		(if (or
				(> (distance (car a) (car b)) numric-fuzz)
				(> (distance (cadr a) (cadr b)) numric-fuzz)
			)
			(setq lstkq (append (list a) lstkq))	
		)		
		(setq	lst (cdr lst))	
	)
	(setq lstkq (reverse (append (list a) lstkq))) ; nhap member cuoi cung
)
;=========================================================================================================
(defun main ( tapten taplinekhaosat / tapdiemtext diemtextdau tapten m dt diemdau diemsau)
	(setq	tapdiemtext (mapcar 'last tapten)
			tapten (mapcar 'car tapten)
			diemtextdau (car tapdiemtext)
	)
;===================================================================================================	
; Doi lai dau line	
;	(setq taplinekhaosat (mapcar '(lambda (x)	(if (> (distance diemtextdau (car x)) (distance diemtextdau (last x)))
;													(reverse x)
;													x
;												)	 
;									)
;									taplinekhaosat
;							)
;	)
;	(setq taplinekhaosat (doidauline 
;=====================================================================================================
; sap xep lai cac line tu gan diemtextdau den xa diem text dau	
;		(setq taplinekhaosat	(vl-sort taplinekhaosat 
;										'(lambda (x y)(< (distance diemtextdau (car x)) (distance diemtextdau (car y))))
;								)
;		)
		(setq	taplinekhaosat (del_duplicate_line diemtextdau taplinekhaosat 5.0)  ; xoa line nam gan nhau , nho hon 5.0
;				tapten  (LM:Unique tapten) ; xoa cac ten line giong nhau
		)
;============================================================================================
(if (= (length tapten) (length taplinekhaosat))
	(progn
		(setq  m 0)
		(repeat (length taplinekhaosat)
			(setq 	
					taplinekhaosat (sortline (nth m tapdiemtext) taplinekhaosat)
;					taplinekhaosat (vl-sort taplinekhaosat 
;										'(lambda (x y)(< (distance (nth m tapdiemtext) (car x)) (distance (nth m tapdiemtext) (car y))))
;									) 
					dt (car taplinekhaosat)
					taplinekhaosat (cdr taplinekhaosat)
					diemdau (car dt)			
					diemsau (cadr dt)
					diemdau (list (car diemdau) (cadr diemdau))
					diemsau (list (car diemsau) (cadr diemsau))
					dt (append diemdau diemsau (list(distance diemdau diemsau)))
					dt (mapcar '(lambda (x) (strcat (chr 9)(rtos x 2 3) ) ) dt)
					dt (apply 'strcat dt)
					dt (list (nth m tapten) dt)
					dataout (append (list dt) dataout)
					m (+ 1 m)
			)
		);end repeat
	); end progn
	(alert "Number Of \"LINE\" Is Difference With Number Of \"LINE NAME\" \nPlease Check Again")
)
) ; end defunc main app
;===============================================================================================================
(Prompt "\nPlease Select Line & Line Name:")
	(setq tapobj (ssget '((-4 . "<OR")
                         (0 . "LINE")
						 (-4 . "<AND") (0 . "LWPOLYLINE") (70 . 0)(-4 . "AND>")
						 (0 . "*TEXT")
						 (-4 . "OR>")))
		f1	(getfiled "Copyright Of Trinh Van Hieu - PTSC G&S)"(getvar "dwgprefix") "txt" 1)
		f	(open f1 "w")
	  )
	 (setq m 0)
	 (repeat (sslength tapobj)
			(setq 	bientam (entget(ssname tapobj m))
					list_dxf (append (list bientam) list_dxf)
					m (1+ m)
			)
	 )
	(setq 
			tapobj nil
			bientam nil
			m nil
			list_layer (mapcar '(lambda ( x ) (cdr(assoc 8 x))) list_dxf)
			list_layer (LM:Unique list_layer)
	)
	(foreach x list_layer
			(setq	taptext (vl-remove-if-not '(lambda (y)	(and(= (cdr(assoc 8 y)) x)
																(wcmatch (cdr(assoc 0 y)) "*TEXT")
															)
												)				
												list_dxf)
					tapline (vl-remove-if-not '(lambda (y)	(and(= (cdr(assoc 8 y)) x)
																(wcmatch (cdr(assoc 0 y)) "*LINE")
															)
												)				
											list_dxf)
					taptext (mapcar '(lambda (z) (list(cdr(assoc 1 z))(cdr(assoc 10 z)))) taptext)
					taptext (vl-sort taptext '(lambda (a b) (< (car a) (car b))))						
			)
			(foreach ent tapline   
				(setq 
					ent (mapcar 'cdr (vl-remove-if-not '(lambda(x) (or (= (car x) 10) (= (car x) 11))) ent))
					tapdt (append (list ent) tapdt)
				)			
			)
			(setq	tapline tapdt 
					tapdt nil    
			)
			(main taptext tapline)
	)	
		
	(setq dataout (vl-sort dataout '(lambda (x y) (< (car x) (car y))) )
		  dataout (mapcar '(lambda ( x ) (apply 'strcat x)) dataout)
	)
	(mapcar '(lambda (x) (write-line x f)) dataout)
	(close f)
	(princ)
	(command "undo" "E")
	;(Prompt "\nCopyright of HSD -Surveyor PTSC G&S...")
	(Prompt "\nIf You Need Support, Please Email To hieutrinh87@gmail.com...")
	(Prompt "\n...")
	(princ)
)

Bạn đã bao giờ mệt vì phải tính toán để đánh cốt cao độ của mặt cắt và mặt đứng hay chưa?

vừa phải tính xem từ điểm cần tính đến cốt 0.00 có khoảng...

>>

Bạn đã bao giờ mệt vì phải tính toán để đánh cốt cao độ của mặt cắt và mặt đứng hay chưa?

vừa phải tính xem từ điểm cần tính đến cốt 0.00 có khoảng cách h bao nhiêu, rồi lại nhập vào bản vẽ.

 

Bây giờ, bạn có thể làm điều này một cách nhanh chóng và tự động nhờ vào lisp dc của cadviet.

với lisp này, bạn chỉ cần gõ lệnh dc, chương trình sẽ hỏi bạn điểm bạn cần đánh cốt, sau đó chương trình sẽ chèn ký hiệu cốt vào đúng vị trí và giá trị mà bạn cần. Bạn dùng lệnh cot00 để định nghĩa điểm có cao độ là cot00.

 

Để sử dụng lệnh, trước tiên phải copy file cot.dwg vào thư mục support - Đây là file chứa nội dung của ký hiệu cốt. Sau đó appload file danhcot.lsp để sử dụng lệnh.

 

(defun c:cot00 ()
 (setq Cot00 (cadr (getpoint "\nDiem co cot 0.000: ")))
 (princ)
)
(defun c:dc (/ diem caodo dau giatri dodaichuoi)
 (if (not cot00)
(progn
  (alert "chua co cot 0.000")
  (c:cot00)
)
 )
 (grdraw (list	(+ (car (getvar "VIEWCTR")) (* -1.0 (getvar "VIEWSIZE")))
	cot00
  )
  (list	(+ (car (getvar "VIEWCTR")) (* 1.0 (getvar "VIEWSIZE")))
	cot00
  )
  1
  1
 )
 (setq
diem   (getpoint "\nVao diem can danh cot: ")
caodo  (- (cadr diem) cot00)
dau	   (cond
	 ((equal caodo 0.0 0.01) "%%p")
	 ((> caodo 0.0) "+")
	 (t "-")
   )
giatri (rtos caodo 2 0)
 )
 (if (= "-" (substr giatri 1 1))
(setq giatri (substr giatri 2))
 )
 (while (< (strlen giatri) 4)
(setq giatri (strcat "0" giatri))
 )
 (setq	dodaichuoi (strlen giatri)
giatri	   (strcat (substr giatri 1 (- dodaichuoi 3))
		   "."
		   (substr giatri (- dodaichuoi 2))
	   )
 )
 (command ".insert" "danhcot" diem 100.0 100.0 0.0 dau giatri)
 (redraw)
)

file danhcot.lsp: <a href="http://www.cadviet.com/upfiles/danhcot.lsp" target="_blank">http://www.cadviet.com/upfiles/danhcot.lsp</a>

file danhcot.dwg: <a href="http://www.cadviet.com/upfiles/DANHCOT.zip" target="_blank">http://www.cadviet.com/upfiles/DANHCOT.zip</a>

 

Lưu ý: Với mỗi file DWG mà bạn vẽ, bạn phải đặt lại biến ATTDIA về 0 trước khi dùng lệnh DC (chỉ cần đặt 1 lần cho mỗi file).

 

Rất mong có được sự phản hồi.

Cảm ơn.

 

có cách nào để bỏi chữ SL trước cao đọ không vậy Pác?

<<

;Chuong trinh ve duong tam nhap thong so Celtscale theo y muon
;;;;;;;;;;;;;;;;;;;;;
(defun c:lcen (/ HIENHANH CEL p1 p2)
  	(setvar "cmdecho" 0)
  	(setq HIENHANH (getvar "clayer"))
  	(if (not (tblsearch "layer" "CENT1"))
	(command "layer" "m" "CENT1" "c" "1" "" "lt" "center"  "" "")
	  )
  	(setvar "clayer" "CENT1")
  	(initget 7)
  	(setq CEL (getint "\nNhap ty le CELTSCALE:"))
  	(setvar "celtscale" cel)
 ...
>>

;Chuong trinh ve duong tam nhap thong so Celtscale theo y muon
;;;;;;;;;;;;;;;;;;;;;
(defun c:lcen (/ HIENHANH CEL p1 p2)
  	(setvar "cmdecho" 0)
  	(setq HIENHANH (getvar "clayer"))
  	(if (not (tblsearch "layer" "CENT1"))
	(command "layer" "m" "CENT1" "c" "1" "" "lt" "center"  "" "")
	  )
  	(setvar "clayer" "CENT1")
  	(initget 7)
  	(setq CEL (getint "\nNhap ty le CELTSCALE:"))
  	(setvar "celtscale" cel)
  	(setvar "ltscale" 1)
  	(setq p1 (getpoint "\nNhap diem 1:"))
  	(setq p2 (getpoint p1 "\nNhap diem 2:"))
        (entmake (list (cons 0 "LINE") (cons 8  (getvar "clayer")) (cons 10 p1) (cons 11 p2)))
   	(setvar "cmdecho" 1)
   	(setvar "clayer" HIENHANH)
  	(princ)
  );end dedun

Nhờ các bạn xem giúp mình, không biết lỗi gì mà sau khi thực hiện lệnh Lcen mà không trả (setvar "clayer" Hienhanh) không trả về layer ban đầu.

tmp.lsp

22 phút trước, lanvientkh đã nói:

(defun C:XY( / p1 p2)

>>

22 phút trước, lanvientkh đã nói:

(defun C:XY( / p1 p2)
(setq
    p1 (getpoint "\nFirst point:")
    p2 (getpoint p1 "\nNext point:")
)
(setvar "dimtad" 1)
(command "leader" p1 p2 "a" (strcat "X="(rtos (cadr p1)) "\\P" (strcat "Y="(rtos (car p1)))) "")
(princ)
)

Mình muốn thêm dòng lặp và chỉ kết thúc khi enter mà tìm hiểu chưa làm được, bạn hỗ trợ dùm

(defun C:XY( / p1 p2)
(setq
    p1 (getpoint "\nFirst point:")
    p2 (getpoint p1 "\nNext point:")
)
(setvar "dimtad" 1)
(command "leader" p1 p2 "a" (strcat "X="(rtos (cadr p1)) "\\P" (strcat "Y="(rtos (car p1)))) "")
(while (setq
    p1 (getpoint "\nFirst point:"))
(setq
    p2 (getpoint p1 "\nNext point:")
)
(setvar "dimtad" 1)
(command "leader" p1 p2 "a" (strcat "X="(rtos (cadr p1)) "\\P" (strcat "Y="(rtos (car p1)))) "")
)
(princ)
)

Sửa lại cho bạn nhé

<<

5 giờ trước, lanvientkh đã nói:

Cảm ơn bạn, nhưng khi dùng báo...

>>

5 giờ trước, lanvientkh đã nói:

Cảm ơn bạn, nhưng khi dùng báo lỗi, bạn kiểm tra dùm mình với nhé

First point:; error: bad argument type: point

Không hiểu sao máy bạn lại bị lỗi, mình kiểm tra trên máy mình chạy ok nhé

viết lại lisp bỏ phần dư thừa

(defun C:XY( / p1 p2)
(setq dimtadold (getvar "dimtad"))
(setvar "dimtad" 1)
(while (setq
    p1 (getpoint "\nFirst point:"))
(setq
    p2 (getpoint p1 "\nNext point:")
)
(command "leader" p1 p2 "a" (strcat "X="(rtos (cadr p1)) "\\P" (strcat "Y="(rtos (car p1)))) "")
)
(setvar "dimtad" dimtadold)
(princ)
)

 

<<

Không hẳn là phá sản đâu. Nếu bạn chịu khó ngồi sửa lại điểm InsertPoint của Block trùng vào đúng tâm point đó, mình có thể giúp bạn...

>>

Không hẳn là phá sản đâu. Nếu bạn chịu khó ngồi sửa lại điểm InsertPoint của Block trùng vào đúng tâm point đó, mình có thể giúp bạn luôn phần chèn Block vào chỗ đó và lấy tên luôn ^^ Có lẽ, nếu bạn nghĩ như thế là hay hơn thì hãy tạo Block đi, rồi mai mình giúp bạn, vì giờ mình chuẩn bị vào ổ r ^^ .CÒn đây là lời hứa đoạn code vừa nãy.Sau khi chạy E2c để có tên và point, bạn chạy thằng này, quét qua 1 block và 1 text để cập nhật.

Trong code có sử dụng Function bác Hoành và bác Tuệ giới thiệu

(defun ChangeAttributes (lst blk / item atts)  
 (if blk    
     (if (safearray-value
           (setq atts
                  (vlax-variant-value
                    (vla-getattributes (vlax-ename->vla-object blk))
                  )
           )
         )
       (progn
         (foreach item lst
           (mapcar
             '(lambda (x)
                (if
                  (= (strcase (car item))
                     (strcase (vla-get-tagstring x))
                  )
                   (vla-put-textstring x (cdr item))
                )
              )
             (vlax-safearray->list atts)
           )
         )
         (vla-update (vlax-ename->vla-object blk))
       )
     )    
 )
)
(defun laydt(ss kieu)
 (acet-list-to-ss
  (vl-remove-if '(lambda(x)
		   (null (wcmatch (acet-dxf 0 (entget x)) kieu)))
	   	 (acet-ss-to-list ss)
  )
 )
)

(defun c:e2cc(/ ss eText tName)
(princ "\n Free Lisp From Cadviet.com @ ketxu")
(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))))
(princ "\nChon Blocks va text :")
(setq ss (ssget))
(setq tname(dxf 1 (setq eText(ssname (Laydt ss "TEXT") 0))))
(ChangeAttributes (list (cons "TENHOGA"  tName)) (ssname (Laydt ss "INSERT") 0))
(entdel eText)
)

nhưng bạn ơi để chạy đoạn code này thì làm như thế nào?

<<

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

Nhờ ECE trên diễn đàn giúp...

>>

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

Nhờ ECE trên diễn đàn giúp đỡ.

Trong Acad có lệnh MATCHPROP (lệnh tắt là MA), có lisp nào tương tự để Dim b có được text overide ABC. Thanks!

MATCHROP TEXT OVERIDE.dwg

Chủ thớt test hàng họ nhé ^_^

(defun c:MD ()
  (vlax-put (vlax-ename->vla-object (car (entsel "\nChon Dim matchprop: "))) 'TextOverride (vlax-get (vlax-ename->vla-object (car (entsel "\nChon Dim goc: "))) 'TextOverride))
  (princ)
  )

 

<<

6 giờ trước, HOABAN_QD đã nói:

Trước là cảm ơn bạn Bee đã...

>>

6 giờ trước, HOABAN_QD đã nói:

Trước là cảm ơn bạn Bee đã xem và giúp đỡ, nhưng mình có ý này cần trao đổi thêm chút nha.

1. Có thể thực hiện theo chiều ngược lại được không? nghĩa là sau khi nhập lệnh thì chọn Dim nguồn trước (Dim có mấy ký tự ABC ấy), sau đó mới quét chọn Dim cần được MatchProp. (vì thói quen hay dùng như vậy)

2. Vì có nhiều Dim cần được Matchprop, do đó sau khi nhập lệnh -->chọn Dim nguồn, tiếp đến có thể bung cửa sổ để chọn tất cả các Dim cần được Matchprop, hoặc là click trái chuột để chọn từng Dim riêng lẻ, khi nào thôi không chọn nữa thì Enter kết thúc là hoàn thành.

3. Trong Acad sau khi nhập lệnh tắt MA và click chọn đối tượng nguồn, thì đối tượng nguồn chuyển sang hình dạng nét đứt, ở đây mình có thể thực hiện giống như vậy không, hoặc là có cách nào khác (đổi màu khác chẳng hạn) để khi mình chọn nó thì mình có thể quan sát và biết rằng đối tượng nguồn đã được chọn.

Cảm ơn bạn.

(defun c:MD ()
	(setq ent2 (car (entsel "\nChon Dim goc: ")))
	(redraw ent2 3)
	(setq ss1 (ssget '((0 . "DIMENSION"))))
	(setq n (sslength ss1) i 0)
	(while (< i n)
		(setq ent1 (ssname ss1 i))
		(vlax-put (vlax-ename->vla-object ent1)'TextOverride (vlax-get (vlax-ename->vla-object ent2) 'TextOverride))
		(setq i (1+ i))				
	)
	(command "REGEN")
	(princ)
)

 

<<