Hy vọng Code này sẽ làm hài lòng HoangSon :


@790312 : Đề nghị bạn đọc từ đầu đến cuối những bài viết liên quan đến Lisp sắp dim của bác Hoành .
Bạn đọc bài mà bỏ dở giữa chừng thì bạn làm không được đó cũng là điều dễ hiểu và chẳng có ai có thể giúp...

Hy vọng Code này sẽ làm hài lòng HoangSon :


@790312 : Đề nghị bạn đọc từ đầu đến cuối những bài viết liên quan đến Lisp sắp dim của bác Hoành .
Bạn đọc bài mà bỏ dở giữa chừng thì bạn làm không được đó cũng là điều dễ hiểu và chẳng có ai có thể giúp bạn được trong trường hợp này cả
Khi làm việc thì nên làm đến nơi đến chốn đừng bao giờ bỏ dở giữa chừng. Điều đó là không nên.
Thứ nữa là bạn không nên post bài cùng 1 nội dung mà ở 2 chủ đề khác nhau là điều không nên và làm khó cho người đọc và theo dõi. Bạn nên sử dụng chức năng tìm kiếm của diễn đàn trước khi lập 1 topic mới

Vài lời khuyên và góp ý cùng bạn

Chào Hoan, làm gì mà yêu cầu "được kết quả nhanh nhất" dữ quá, làm cho Thiep cũng không kịp hoàn thiện Lisp đúng cho mọi trường hợp. Xin hỏi Hoan đang thiết kế vét bùn cái gì mà gấp thế? Thôi thì Hoan tạm sử dụng lisp này vậy:

Hoan chú ý:
- Lisp sẽ hỏi các thông số 1 lần đầu tiên thôi, lần sau sẽ không hỏi nữa cho dù phát lệnh VBU đến lần thứ n. Muốn thay đổi các...

Chào Hoan, làm gì mà yêu cầu "được kết quả nhanh nhất" dữ quá, làm cho Thiep cũng không kịp hoàn thiện Lisp đúng cho mọi trường hợp. Xin hỏi Hoan đang thiết kế vét bùn cái gì mà gấp thế? Thôi thì Hoan tạm sử dụng lisp này vậy:

Hoan chú ý:
- Lisp sẽ hỏi các thông số 1 lần đầu tiên thôi, lần sau sẽ không hỏi nữa cho dù phát lệnh VBU đến lần thứ n. Muốn thay đổi các thông số này phải phát lệnh KHD trước khi phát lệnh VBU.

BT 2-1



;;;BAI 1

(defun c:bt2-1 (/ x y z e)
(setq x (+ 7 2))
(setq y (- 3 1.25))
(setq z 5.0)
(setq z (* x y))
(setq e (+ z (* 0.4 (- x y))))
(setq ketqua (+ x y z e))
)
;;;BAI 2
(defun c:bt2-2(/ a B c)
(setq a 1000)
(setq b 2000)
(setq c (* a B 0.5))
)
(defun tbc (a B c) ;;;ham trung binh cong
(/ (+ a b c) 3.0)
)
(defun stg (a B ) ;;;;ham...

BT 2-1



;;;BAI 1

(defun c:bt2-1 (/ x y z e)
(setq x (+ 7 2))
(setq y (- 3 1.25))
(setq z 5.0)
(setq z (* x y))
(setq e (+ z (* 0.4 (- x y))))
(setq ketqua (+ x y z e))
)
;;;BAI 2
(defun c:bt2-2(/ a B c)
(setq a 1000)
(setq b 2000)
(setq c (* a B 0.5))
)
(defun tbc (a B c) ;;;ham trung binh cong
(/ (+ a b c) 3.0)
)
(defun stg (a B ) ;;;;ham tinh dien tich tam giac
(* (+ a B ) 0.5)
)
(defun tich4s (a B c d) ;;;;;ham tich 4 so
(* a B c d)
)
(defun lp (a) ;;;ham lap phuong bon so
(* a a a )
)


Nhận xét Bài 1 : chưa đạt
- Không khử biến ketqua ở thủ tục thứ 2
- Sai hàm tính diện tích tam giác - mục 5
- Thiếu mục 3

Bài 2 :


(defun svk (r1 r2)
( * pi ( abs(- r1 r2))))
;;;dien tich tam giac khi biet 3 canh
;cau lenh
(defun c:sbc(/ a b c)
(setq a (getint "\ncanh thu nhat:"))
(setq b (getint "\ncanh thu hai:"))
(setq c (getint "\ncanh thu ba:"))
(dttg3c a b c)
)
;;;ham
(defun dttg3c(x y z)
(setq p (*(+ x y z) 0.5))
(sqrt(* p(* (- p x) (- p y) (- p z))))
)
;;HAM TINH DIEN TICH MAT CAT THEP TRON
(defun sth(d pi)
(* pi (* (* d 0.5) (* d 0.5)))
)
(defun klt(d pi )
(setq s (* pi (* (* d 0.5) (* d 0.5))))
(* s 11.7 7850)
)
;; HAM TINH KHOI LUONG THEP VUONG;;CAU E
;a : canh
;k : be day thep
(defun klth1(a k)
(* (- (* a a) (* (- a (* 2 k)) (- a (* 2 k)))) 11.7 7850)
)
;;HAM TINH KHOI LUONG THEP;;CAU F
;a :cach
;b :canh trong
(defun klth2(a
(* ( - (* a a) (* b ) 11.7 7850)
)



Nhận xét bài 2 : chưa đạt
- Thừa câu lệnh
- Thừa tham số trong các hàm liên quan đến pi (pi là hằng số, không nên đưa ra làm tham số)
- Câu f không tận dụng được câu e
- Sai diện tích vành khăn mất rồi ^^

sửa lại cho bạn theo code của bác Bình :
Sorry bác Bình vì lược bỏ những phần không cần thiết.

(defun c:xt2ex (/ c1 c2 c3 c4 c5 c6 c7 c8 f filename lay sslst sslst1 tlst)
(vl-load-com)
(if (and (setq sslst (acet-ss-to-list (ssget (list (cons 0 "LWPOLYLINE") (cons 8 "Main_tach_o")))))
(setq filename (getfiled "Select a File" "" "csv" 1)) )
(progn
(setq f...

sửa lại cho bạn theo code của bác Bình :
Sorry bác Bình vì lược bỏ những phần không cần thiết.

(defun c:xt2ex (/ c1 c2 c3 c4 c5 c6 c7 c8 f filename lay sslst sslst1 tlst)
(vl-load-com)
(if (and (setq sslst (acet-ss-to-list (ssget (list (cons 0 "LWPOLYLINE") (cons 8 "Main_tach_o")))))
(setq filename (getfiled "Select a File" "" "csv" 1)) )
(progn
(setq f (open filename "a"))
(write-line "Main_STT,Main_H_Dap,Main_S_Dap,Main_V_Dap,Main_H_Dao,Main_S_Dao,Main_V_Dao,Main_S_O" f)
(foreach e sslst
(setq sslst1 (acet-ss-to-list (ssget "wp" (acet-geom-vertex-list e) (list (cons 0 "text")) )) )
(setq tlst "")
(setq C1 "STT" C2 " " C3 " " C4 " " C5 " " C6 " " C7 " " C8 " ")
(foreach en sslst1
(setq lay (cdr (assoc 8 (entget en))))
(cond
( (= lay "Main_STT")
(setq C1 (cdr (assoc 1 (entget en))) ) )
( (= lay "Main_H_Dap")
(setq C2 (cdr (assoc 1 (entget en))) ) )
( (= lay "Main_S_Dap")
(setq C3 (cdr (assoc 1 (entget en))) ) )
( (= lay "Main_V_Dap")
(setq C4 (cdr (assoc 1 (entget en))) ) )
( (= lay "Main_H_Dao")
(setq C5 (cdr (assoc 1 (entget en))) ) )
( (= lay "Main_S_Dao")
(setq C6 (cdr (assoc 1 (entget en))) ) )
( (= lay "Main_V_Dao")
(setq C7 (cdr (assoc 1 (entget en))) ) )
( (= lay "Main_S_O")
(setq C8 (cdr (assoc 1 (entget en))) ) ) ))
(setq tlst (strcat C1 (chr 44) C2 (chr 44) C3 (chr 44) C4 (chr 44)
C5 (chr 44) C6 (chr 44) C7 (chr 44) C8 ))
(write-line tlst f) )
(close f)))
(princ))

Thực ra bạn có thể chọn đối tượng rồi thay đổi layer trên thanh công cụ cũng là nhanh rồi
Nhưng nếu bạn muốn một LISP như vậy bạn dùng thử xem nhé
@ Mạn phép bác DOAN VAN HA chút nhé, đây chỉ là một cách khác

;;Free lisp code from CADViet.com
(defun c:ko ( / SS )
(prompt "\nChon cac doi tuong muon chuyen ve layer Defpoint: ")
(setq ss (ssget))
(command...

Thực ra bạn có thể chọn đối tượng rồi thay đổi layer trên thanh công cụ cũng là nhanh rồi
Nhưng nếu bạn muốn một LISP như vậy bạn dùng thử xem nhé
@ Mạn phép bác DOAN VAN HA chút nhé, đây chỉ là một cách khác

;;Free lisp code from CADViet.com
(defun c:ko ( / SS )
(prompt "\nChon cac doi tuong muon chuyen ve layer Defpoint: ")
(setq ss (ssget))
(command "CHANGE" "P" "" "PROPERTIES" "LAYER" "DEFPOINTS" "" )
(princ)
);;end defun

Theo mình, yêu cầu này gần với lệnh SSX của AutoCAD (hình như có từ Cad2004). Tuy nhiên lệnh SSX tìm trong toàn bản vẽ và chỉ trả về tập chọn cuối cùng (mà không làm gì cả).
Mình đã cải tiến nó lại, cho phép khoanh vùng chọn trên màn hình và grip kết quả chọn được.


;;
;;;
;;; SSX.LSP
;;; Copyright © 1999 by Autodesk, Inc.
;;;
;;; Your use of this software...

Theo mình, yêu cầu này gần với lệnh SSX của AutoCAD (hình như có từ Cad2004). Tuy nhiên lệnh SSX tìm trong toàn bản vẽ và chỉ trả về tập chọn cuối cùng (mà không làm gì cả).
Mình đã cải tiến nó lại, cho phép khoanh vùng chọn trên màn hình và grip kết quả chọn được.


;;
;;;
;;; SSX.LSP
;;; Copyright © 1999 by Autodesk, Inc.
;;;
;;; Your use of this software is governed by the terms and conditions of the
;;; License Agreement you accepted prior to installation of this software.
;;; Please note that pursuant to the License Agreement for this software,
;;; "opying of this computer program or its documentation except as
;;; permitted by this License is copyright infringement under the laws of
;;; your country. If you copy this computer program without permission of
;;; Autodesk, you are violating the law."
;;;
;;; AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.
;;; AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF
;;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE. AUTODESK, INC.
;;; DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
;;; UNINTERRUPTED OR ERROR FREE.
;;;
;;; Use, duplication, or disclosure by the U.S. Government is subject to
;;; restrictions set forth in FAR 52.227-19 (Commercial Computer
;;; Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)
;;; (Rights in Technical Data and Computer Software), as applicable.
;;;
;;; ----------------------------------------------------------------

;;; DESCRIPTION
;;; SSX.LSP
;;;
;;; "(SSX)" - Easy SSGET filter routine.
;;;
;;; Creates a selection set. Either type "SSX" at the "Command:" prompt
;;; to create a "previous" selection set or type "(SSX)" in response to
;;; any "Select objects:" prompt. You may use the functions "(A)" to add
;;; entities and "(R)" to remove entities from a selection set during
;;; object selection. More than one filter criteria can be used at a
;;; time.
;;;
;;; SSX returns a selection set either exactly like a selected
;;; entity or, by adjusting the filter list, similar to it.
;;;
;;; The initial prompt is this:
;;;
;;; Command: ssx
;;; Select object/<None>: (RETURN)
;;; >>Block name/Color/Entity/Flag/LAyer/LType/Pick/Style/Thickness/Vector:
;;;
;;; Pressing RETURN at the initial prompt gives you a null selection
;;; mechanism just as (ssx) did in Release 10, but you may select an
;;; entity if you desire. If you do so, then the list of valid types
;;; allowed by (ssget "x") are presented on the command line.
;;;
;;; Select object/<None>: (a LINE selected)
;;; Filter: ((0 . "LINE") (8 . "0") (39 . 2.0) (62 . 1) (210 0.0 0.0 1.0))
;;; >>Block name/Color/Entity/Flag/LAyer/LType/Pick/Style/Thickness/Vector:
;;;
;;; At this point any of these filters may be removed by selecting the
;;; option keyword, then pressing RETURN.
;;;
;;; >>Layer name to add/<RETURN to remove>: (RETURN)
;;;
;;; Filter: ((0 . "LINE") (39 . 2.0) (62 . 1) (210 0.0 0.0 1.0))
;;; >>Block name/Color/Entity/Flag/LAyer/LType/Pick/Style/Thickness/Vector:
;;;
;;; If an item exists in the filter list and you elect to add a new item,
;;; the old value is overwritten by the new value, as you can have only
;;; one of each type in a single (ssget "x") call.
;;;
;;;--------------------------------------------------------------------------;
;;;
;;; Find the dotted pairs that are valid filters for ssget
;;; in entity named "ent".
;;;
;;; ssx_fe == SSX_Find_Entity
;;;

(defun ssx_fe (/ data fltr ent)
(setq ent (car (entsel "\nSelect object <None>: ")))
(if ent
(progn
(setq data (entget ent))
(foreach x '(0 2 6 7 8 39 62 66 210) ; do not include 38
(if (assoc x data)
(setq fltr
(cons (assoc x data) fltr)
)
)
)
(reverse fltr)
)
)
)
;;;
;;; Remove "element" from "alist".
;;;
;;; ssx_re == SSX_Remove_Element
;;;
(defun ssx_re (element alist)
(append
(reverse (cdr (member element (reverse alist))))
(cdr (member element alist))
)
)
;;;
;;; INTERNAL ERROR HANDLER
;;;
(defun ssx_er (s) ; If an error (such as CTRL-C) occurs
; while this command is active...
(if (/= s "Function cancelled")
(princ (acet-str-format "\nError: %1" s))
)
(if olderr (setq *error* olderr)) ; Restore old *error* handler
(princ)
)
;;;
;;; Get the filtered sel-set.
;;;
;;;
(defun ssx (/ olderr fltr)
(gc) ; close any sel-sets
(setq olderr *error*
*error* ssx_er
)
(setq fltr (ssx_fe))
(ssx_gf fltr)
)
;;;
;;; Build the filter list up by picking, selecting an item to add,
;;; or remove an item from the list by selecting it and pressing RETURN.
;;;
;;; ssx_gf == SSX_Get_Filters
;;;
(defun ssx_gf (f1 / t1 t2 t3 f2)
(while
(progn
(cond (f1 (prompt "\nCurrent filter: ") (prin1 f1)))
(initget
"Block Color Entity Flag LAyer LType Pick Style Thickness Vector")
(setq t1 (getkword
"\nEnter filter option : "))
)
(setq t2
(cond
((eq t1 "Block") 2) ((eq t1 "Color") 62)
((eq t1 "Entity") 0) ((eq t1 "LAyer") 8)
((eq t1 "LType") 6) ((eq t1 "Style") 7)
((eq t1 "Thickness") 39) ((eq t1 "Flag" ) 66)
((eq t1 "Vector") 210)
(T t1)
)
)
(setq t3
(cond
((= t2 2) (getstring "\n>>Enter block name to add <RETURN to remove>: "))
((= t2 62) (initget 4 "?")
(cond
((or (eq (setq t3 (getint
"\n>>Enter color number to add <RETURN to remove>: ")) "?")
(> t3 256))
(ssx_pc) ; Print color values.
nil
)
(T
t3 ; Return t3.
)
)
)
((= t2 0) (getstring "\n>>Enter entity type to add <RETURN to remove>: "))
((= t2 8) (getstring "\n>>Enter layer name to add <RETURN to remove>: "))
((= t2 6) (getstring "\n>>Enter linetype name to add <RETURN to remove>: "))
((= t2 7)
(getstring "\n>>Enter text style name to add <RETURN to remove>: ")
)
((= t2 39) (getreal "\n>>Enter thickness to add <RETURN to remove>: "))
((= t2 66) (if (assoc 66 f1) nil 1))
((= t2 210)
(getpoint "\n>>Specify extrusion Vector to add <RETURN to remove>: ")
)
(T nil)
)
)
(cond
((= t2 "Pick") (setq f1 (ssx_fe) t2 nil)) ; get entity
((and f1 (assoc t2 f1)) ; already in the list
(if (and t3 (/= t3 ""))
;; Replace with a new value...
(setq f1 (subst (cons t2 t3) (assoc t2 f1) f1))
;; Remove it from filter list...
(setq f1 (ssx_re (assoc t2 f1) f1))
)
)
((and t3 (/= t3 ""))
(setq f1 (cons (cons t2 t3) f1))
)
(T nil)
)
)
(princ "\nKhoanh vung chon <enter=all>: ")
(setq chon (ssget))
(if chon (if f1 (setq f2 (ssget "_p" f1)))
(if f1 (setq f2 (ssget "_x" f1))))
(setq *error* olderr)
(if (and f1 f2)
(progn
(princ (acet-str-format "\n%1 found. " (itoa (sslength f2))))
f2
)
(progn (princ "\n0 found.") (prin1))
)
)
;;;
;;; Print the standard color assignments.
;;;
;;;
(defun ssx_pc ()
(if textpage (textpage) (textscr))
(princ "\n ")
(princ "\n Color number | Standard meaning ")
(princ "\n ________________|____________________")
(princ "\n | ")
(princ "\n 0 | <BYBLOCK> ")
(princ "\n 1 | Red ")
(princ "\n 2 | Yellow ")
(princ "\n 3 | Green ")
(princ "\n 4 | Cyan ")
(princ "\n 5 | Blue ")
(princ "\n 6 | Magenta ")
(princ "\n 7 | White ")
(princ "\n 8...255 | -Varies- ")
(princ "\n 256 | <BYLAYER> ")
(princ "\n \n\n\n")
)
;;;
;;; C: function definition.
;;;
(defun c:ssx ()
(ssx)
(princ)
)
;(princ "\n\tType \"ssx\" at a Command: prompt or ")
;(princ "\n\t(ssx) at any object selection prompt. ")

(princ)


;ch&#228;n &#174;&#232;i t&#173;&#238;ng b&#187;ng l&#214;nh (ssx) c&#241;a Express
(defun c:ssx(/ chon)
(if (/= (ssx)(princ))
(progn
(setq chon (ssget "p"))
(if (> (sslength chon) 0)
(progn
(sssetfirst chon chon)
(princ "\nChon duoc ")(princ (sslength chon))(princ " doi tuong.")
(setq chon (gc))))))
(princ))

Em có cái Lisp copy 1 nhóm đối tượng từ 1 layout sang tất cả các layout.... Em mong các Anh sửa giúp em: Lisp này sẽ xóa một nhóm đối tượng đã có trên các layout.

(defun c:c1 (/ objects x layouts)
(setq objects (ssget))
(setq layouts (getvar "ctab"))
(command "_copybase" "0,0" objects "")
(command "erase" "p" "")
(foreach x (layoutlist)

>>

Em có cái Lisp copy 1 nhóm đối tượng từ 1 layout sang tất cả các layout.... Em mong các Anh sửa giúp em: Lisp này sẽ xóa một nhóm đối tượng đã có trên các layout.

(defun c:c1 (/ objects x layouts)
(setq objects (ssget))
(setq layouts (getvar "ctab"))
(command "_copybase" "0,0" objects "")
(command "erase" "p" "")
(foreach x (layoutlist)
(setvar "ctab" x)
(command "_pasteblock" "0,0")
(command "explode" "l" "")
)
(setvar "ctab" layouts)
(princ))

Mình cũng đang có 1 lisp giãn text tuy nhiên lúc giãn xong thì các text lại bị thay đổi thứ tự và bị "nhẩy" sang trái.Mong các bác có thể sửa hộ em với


(defun c:gc ()
(BLIP)
(command "redraw")
(prompt "\nSelect text objects to evenly space: ")
(setq ssText (ssget '((0 . "TEXT")))) ; select text
(setq ssNumber (sslength ssText) ; lines of text
...

Mình cũng đang có 1 lisp giãn text tuy nhiên lúc giãn xong thì các text lại bị thay đổi thứ tự và bị "nhẩy" sang trái.Mong các bác có thể sửa hộ em với


(defun c:gc ()
(BLIP)
(command "redraw")
(prompt "\nSelect text objects to evenly space: ")
(setq ssText (ssget '((0 . "TEXT")))) ; select text
(setq ssNumber (sslength ssText) ; lines of text
ssIndex ssNumber ; pointer
ssY_Handles '() ; list of Y values and Handles
dYfactor 1.05 ; default Y displacement factor
)
(repeat ssNumber
(setq ssIndex (- ssIndex 1))
(setq eName (ssname ssText ssIndex)); entity name
(setq eData (entget eName))
(setq eY (car (assoc '10 eData))) ; entity Y location value
(setq eYe (/ eY 100000)) ; assure correct ordering
(setq eYe (+ eYe 5))
(setq eYe (rtos eYe 2 8)) ; change to a string
(setq eHnd (cdr (assoc '5 eData))) ; entity handle
(setq ssY_Handles
(cons (strcat eYe "*" eHnd) ; add string to
ssY_Handles ; list
)
)
);repeat
(setq ssY_Handles
(acad_strlsort ssY_Handles) ; sort in order of Y value
)
(setq ssIndex ssNumber ; pointer
ssY '() ; sorted list of Y values
ssHandles '() ; sorted list of handles
)
(repeat ssNumber
(setq ssIndex (- ssIndex 1))
(setq eY_H ; entity Y value and handle
(nth ssIndex ssY_Handles)
)
(setq eSL (strlen eY_H)) ; entity string length
(setq eSLIndex 1) ; pointer
(repeat eSL
(if (/=
(substr eY_H eSLIndex 1) ; if substring is not "-"
"*"
)
(setq eSLIndex (+ eSLIndex 1)); go to next substring
)
); repeat
(setq eHnd
(substr eY_H (+ eSLIndex 1) eSL) ; entity handle
)
(setq
eName (handent eHnd) ; get name of entity
eData (entget eName) ; get entity data
eText (assoc 1 eData) ; get text
lName (assoc '-1 eData)
)
(if (= (- ssNumber 1) ssIndex) ; if this is first line of text
(progn
(setq
eX (cadr (assoc '10 eData)) ; X location value
eY (caddr (assoc '10 eData)) ; Y location
eZ (cadddr(assoc '10 eData)) ; Z location
eX1 (cadr (assoc '11 eData)) ; X location value
eY1 (caddr (assoc '11 eData)) ; Y location
eZ1 (cadddr(assoc '11 eData)) ; Z location
eH (cdr (assoc '40 eData)) ; text height
eColor (assoc 62 eData) ; color
); setq
(if (not eColor) (setq
eData (subst '(62 . 256) (assoc 62 eData) eData))
)
(setq
feData eData
)
);progn
(progn
(setq eX (- eX (* eH dYfactor))) ; otherwise decrease y value
(setq eX1 (- eX1 (* eH dYfactor))) ; otherwise decrease y1 value
)
);if
(setq eXYZ (list 10 eX eY eZ ))
(setq eXYZ1 (list 11 eX1 eY1 eZ1))
(setq eData feData)
(setq eData (subst eText (assoc 1 eData) eData))
(setq eData (subst eXYZ (assoc '10 eData) eData))
(setq eData (subst eXYZ1 (assoc '11 eData) eData))
(setq eData (subst (cons 5 eHnd) (assoc 5 eData) eData))
(setq eData (subst lName (assoc -1 eData) eData))
(entmod eData) ; modify text entity
); repeat
(unblip)
)
(defun BLIP ()
(setq sblip (getvar "blipmode")
scmde (getvar "cmdecho")
)
(setvar "blipmode" 0)
(setvar "cmdecho" 0)
(princ)
)
(defun UNBLIP ()
(setvar "blipmode" sblip)
(setvar "cmdecho" scmde)
(princ)
)
(princ)

Đây là lisp mình viết lại. Nó không nhanh hơn lisp của bạn DVH nhưng chắc chắn nhanh hơn của "chính chủ".

;;; ThuyLinh313 - TriTueViet.jsc
(defun c:sf (/ A101 A102 A103 A104 A111 A112 E EN FUZ I LST LST-POINT P P1 P2 S1 SS)
(setq fuz 0.001)
; (1) get root_object
(if (setq en (ssget "_:E:S" (list...

Đây là lisp mình viết lại. Nó không nhanh hơn lisp của bạn DVH nhưng chắc chắn nhanh hơn của "chính chủ".

;;; ThuyLinh313 - TriTueViet.jsc
(defun c:sf (/ A101 A102 A103 A104 A111 A112 E EN FUZ I LST LST-POINT P P1 P2 S1 SS)
(setq fuz 0.001)
; (1) get root_object
(if (setq en (ssget "_:E:S" (list '(-4 . "<OR")
'(0 . "LINE,ARC")
'(-4 . "<AND") '(0 . "LWPOLYLINE,SPLINE") '(-4 . "<NOT") '(-4 . "&=") '(70 . 1) '(-4 . "NOT>") '(-4 . "AND>")
'(-4 . "<AND") '(0 . "POLYLINE") '(-4 . "<NOT") '(-4 . "&") '(70 . 89) '(-4 . "NOT>") '(-4 . "AND>")
'(-4 . "<AND") '(0 . "ELLIPSE") '(-4 . "<OR") '(-4 . "<>") '(41 . 0.0) '(-4 . "<>") (cons 42 (+ pi pi)) '(-4 . "OR>") '(-4 . "AND>")
'(-4 . "OR>")
(if (= 1 (getvar "cvport")) (cons 410 (getvar "ctab")) '(410 . "Model")))))
(progn
(setq en (ssname en 0))
(if (setq ss (ssget "X" (list '(-4 . "<OR")
'(0 . "ARC")
'(-4 . "<AND") '(0 . "ELLIPSE") '(-4 . "<OR") '(-4 . "<>") '(41 . 0.0) '(-4 . "<>") (cons 42 (+ pi pi)) '(-4 . "OR>") '(-4 . "AND>")
'(-4 . "OR>")
(if (= 1 (getvar "cvport")) (cons 410 (getvar "ctab")) '(410 . "Model")))))
(progn
(ssdel en ss)
(repeat (setq i (sslength ss))
(setq e (ssname ss (setq i (1- i)))
lst (cons (list (setq p1 (vlax-curve-getstartpoint e)) (setq p2 (vlax-curve-getendpoint e)) e) lst)
lst (cons (list p2 p1 e) lst))))) ;_(1)

(setq lst-point (list (vlax-curve-getstartpoint en) (vlax-curve-getendpoint en))
ss (ssadd en))
(while (setq p (car lst-point))
(setq lst-point (cdr lst-point))
; (2) add arc, elip
(if lst
(setq lst (vl-remove-if '(lambda (a) (and (equal (car a) p fuz)
(ssadd (caddr a) ss)
(setq lst-point (cons (cadr a) lst-point)))) lst))) ;_(2)
; (3) add *Line
(setq A101 (cons 10 (setq p1 (polar p 0.7854 fuz)))
A102 (cons 10 (setq p2 (polar p 0.7854 (* -1 fuz))))
A103 (cons 10 (polar p -0.7854 fuz))
A104 (cons 10 (polar p -0.7854 (* -1 fuz)))
A111 (cons 11 p1)
A112 (cons 11 p2))
(if
(setq s1 (ssget "X" (list '(-4 . "<OR")
'(-4 . "<AND") '(0 . "LINE") '(-4 . "<,<,*") A101 '(-4 . ">,>,*") A102 '(-4 . "AND>")
'(-4 . "<AND") '(0 . "LINE") '(-4 . "<,<,*") A111 '(-4 . ">,>,*") A112 '(-4 . "AND>")
'(-4 . "<AND") '(0 . "LWPOLYLINE,SPLINE") '(-4 . "<,<,*") A101 '(-4 . ">,>,*") A102 '(-4 . "<,>,*") A103 '(-4 . ">,<,*") A104
'(-4 . "<NOT") '(-4 . "&=") '(70 . 1) '(-4 . "NOT>")'(-4 . "AND>")
'(-4 . "OR>"))))
(progn
(ssdel en s1)
(repeat (setq i (sslength s1))
(setq e (ssname s1 (setq i (1- i))))
(if (not (ssmemb e ss))
(progn
(ssadd e ss)
(if (not (equal (setq p1 (vlax-curve-getstartpoint e)) p fuz))
(setq lst-point (cons p1 lst-point))
(setq lst-point (cons (vlax-curve-getendpoint e) lst-point)))))))))
(sssetfirst nil ss)))
(princ))

Nhờ các bác sửa cho em đoạn code này, mục đích là chuyển xref thành no path. Có lẽ lisp không update dữ liệu vào được nên không chạy. Em đang gặp khó khăn nếu reference name bị thay đổi (không trùng tên với file xref).

(defun c:aaa(/ tmp1)
;(vl-load-com)
(setq tmp1 (tblnext "BLOCK" 1))
(WHILE (/= tmp1 NIL)
(IF(/= (assoc 1 tmp1) nil)
(PROGN
(SETQ xfname (cdr (ASSOC 2...

Nhờ các bác sửa cho em đoạn code này, mục đích là chuyển xref thành no path. Có lẽ lisp không update dữ liệu vào được nên không chạy. Em đang gặp khó khăn nếu reference name bị thay đổi (không trùng tên với file xref).

(defun c:aaa(/ tmp1)
;(vl-load-com)
(setq tmp1 (tblnext "BLOCK" 1))
(WHILE (/= tmp1 NIL)
(IF(/= (assoc 1 tmp1) nil)
(PROGN
(SETQ xfname (cdr (ASSOC 2 tmp1)))
(princ xfname) (princ "\n Current: ")
(setq pathname (cdr (assoc 1 tmp1)))
(princ pathname)
(setq ct (strlen pathname))
(setq c ct)
(setq test (substr pathname ct 1))
(while (/= test "\\")
(setq test (substr pathname c 1))
(setq c (1- c))
) ;while
(setq pathdir (substr pathname 1 c))
(setq filenameex (substr pathname (1+ c)))
(if (/= (assoc 2 tmp1) (substr pathname 1 (- (strlen pathname) 4)))
(progn
(setq tmp1 (subst (cons 1 (strcat (cdr (assoc 2 tmp1)) ".dwg")) (assoc 1 tmp1) tmp1))
(entmod tmp1)
(entupd (cdr(assoc -2 tmp1)))
)
))))
(setq tmp1 (tblnext "BLOCK"))
)