Jump to content
InfoFile
Tác giả: Tue_NV
Bài viết gốc: 41317
Tên lệnh: scc vtd dlm
Viết Lisp theo yêu cầu


Đầu tiên, có thể bạn sử dụng lệnh Tjust để chuyển một chữ căn lề trái, một chữ căn lề phải ( mà không bị thay đổi vị trí của text) theo bạn Nataca. Hoặc có thể bạn không dùng cũng được. sau này bạn move ra một chút
. Và bạn sử dụng đoạn Code của mình để thực hiện ý muốn của mình.
Dưới đây là Code :

Để mình giải thích .
Đoạn code trên dựa...
>>

Đầu tiên, có thể bạn sử dụng lệnh Tjust để chuyển một chữ căn lề trái, một chữ căn lề phải ( mà không bị thay đổi vị trí của text) theo bạn Nataca. Hoặc có thể bạn không dùng cũng được. sau này bạn move ra một chút
. Và bạn sử dụng đoạn Code của mình để thực hiện ý muốn của mình.
Dưới đây là Code :

Để mình giải thích .
Đoạn code trên dựa trên lệnh scale với điểm chèn là trung điểm của đường thẳng nối 2 text.
Và tỉ lệ của lệnh Scale trên bằng khoảng cách 2 text đầu (chữ to) chia cho khoảng cách 2 text cuoi (là khoảng cách do mình chọn lúc cuối cùng)
Mục đích là để thu hẹp khoảng cách của 2 text. Sau đó sử dụng hàm tt để thay đổi chiều cao của 2 text đó :
Ở dòng lệnh :
Height/Select:
Nếu bạn chọn S thì : chương trình bảo bạn nhập kích thước text mới
Nếu bạn chọn H thì : chương trình bảo bạn chọn Chieu cao loai Texts can thay doi và chiều cao text thay doi chieu cao thanh:
Trong trường hợp này bạn nên chọn S
Còn bạn muốn thực hiện lệnh là multiple
thì bạn hãy gõ
Command : multiple

Enter command name to repeat: scc
....

Bạn có thể thiết lập lệnh tắt multiple trong file acad.pgp



Nhớ thanks ủng hộ nhé.
Chúc vui :leluoi:
<<

Filename: 41317_scc_vtd_dlm.lsp
Tác giả: mrphuocvie
Bài viết gốc: 297682
Tên lệnh: %60cr1 %60cr2
Tư vấn hiệu chỉnh giúp đoạn lisp về lệnh COPY!

Command: COPY
Select objects: 1 found
Select objects:
Current settings:  Copy mode = Multiple
Specify base point or  <Displacement>:
Specify second point or  <use first point as displacement>: a
Enter number of items to array: 10
Specify second point or : f
Specify second point or :
Specify second point or  <Exit>:
;Phía trên là các dòng lệnh thực hiện trong Autocad2015, mình muốn đơn giản thao tác trên bằng...
>>
Command: COPY
Select objects: 1 found
Select objects:
Current settings:  Copy mode = Multiple
Specify base point or  <Displacement>:
Specify second point or  <use first point as displacement>: a
Enter number of items to array: 10
Specify second point or : f
Specify second point or :
Specify second point or  <Exit>:
;Phía trên là các dòng lệnh thực hiện trong Autocad2015, mình muốn đơn giản thao tác trên bằng đoạn lisp này nhưng...
;Điều mình mong muốn là: Chọn đối tượng, chọn điểm đầu, điểm cuối, số lượng array trong khoảng từ điểm đầu đến diểm cuối.
(defun C:`CR1()
	(setq ss (ssget))
	(setq p1 (getpoint "\nPick first point!"))
	(setq p2 (getpoint "\nPick second point!"))
	(setq nb (getreal "\nInput number <10>:"))
	(command "copy" ss p1 "a" nb "f" p2 "")
)
--------------------------------------------------------------------------------------------------
Command: COPY
Select objects: 1 found
Select objects:
Current settings:  Copy mode = Multiple
Specify base point or  <Displacement>:
Specify second point or  <use first point as displacement>: a
Enter number of items to array: 10
Specify second point or :
Specify second point or  <Exit>:
;Phía trên là các dòng lệnh thực hiện trong Autocad2015, mình muốn đơn giản thao tác trên bằng đoạn lisp này nhưng...
;Điều mình mong muốn là: Chọn đối tượng, chọn điểm đầu, điểm cuối, khoảng cách giữa các đối tượng được array sau đó lisp sẽ tính số lượng và thực hiện lệnh.
(defun C:`CR2()
	(setq ss (ssget))
	(setq p1 (getpoint "\nPick first point!"))
	(setq p2 (getpoint "\nPick second point!"))
	(setq dt (getreal "\nInput distance <100>:"))
	(setq nb (+ fix(/ (distance p1 p2) dt) 1))
	(command "copy" ss p1 "a"  nb "" p2 "")
)

 

Command: COPY
Select objects: 1 found
Select objects:
Current settings:  Copy mode = Multiple
Specify base point or <Displacement>:
Specify second point or <use first point as displacement>: a
Enter number of items to array: 10
Specify second point or : f
Specify second point or :
Specify second point or <Exit>:
;Phía trên là các dòng lệnh thực hiện trong Autocad2015, mình muốn đơn giản thao tác trên bằng đoạn lisp này nhưng...
;Điều mình mong muốn là: Chọn đối tượng, chọn điểm đầu, điểm cuối, số lượng array trong khoảng từ điểm đầu đến diểm cuối.
(defun C:`CR1()
(setq ss (ssget))
(setq p1 (getpoint "\nPick first point!"))
(setq p2 (getpoint "\nPick second point!"))
(setq nb (getreal "\nInput number <10>:"))
(command "copy" ss p1 "a" nb "f" p2 "")
)
--------------------------------------------------------------------------------------------------------------------

 


 

Command: COPY
Select objects: 1 found
Select objects:
Current settings:  Copy mode = Multiple
Specify base point or <Displacement>:
Specify second point or <use first point as displacement>: a
Enter number of items to array: 10
Specify second point or :
Specify second point or <Exit>:
;Phía trên là các dòng lệnh thực hiện trong Autocad2015, mình muốn đơn giản thao tác trên bằng đoạn lisp này nhưng...
;Điều mình mong muốn là: Chọn đối tượng, chọn điểm đầu, điểm cuối, khoảng cách giữa các đối tượng được array sau đó lisp sẽ tính số lượng và thực hiện lệnh.
(defun C:`CR2()
(setq ss (ssget))
(setq p1 (getpoint "\nPick first point!"))
(setq p2 (getpoint "\nPick second point!"))
(setq dt (getreal "\nInput distance <100>:"))
(setq nb (+ fix(/ (distance p1 p2) dt) 1))
(command "copy" ss p1 "a"  nb "" p2 "")
)
;Phía trên là các dòng lệnh thực hiện trong Autocad2015, mình muốn đơn giản thao tác trên bằng đoạn lisp này nhưng...
;Điều mình mong muốn là: Chọn đối tượng, chọn điểm đầu, điểm cuối, số lượng array trong khoảng từ điểm đầu đến diểm cuối.

<<

Filename: 297682_%60cr1_%60cr2.lsp
Tác giả: ketxu
Bài viết gốc: 162964
Tên lệnh: f+nil%3Cbr%3E
(Yêu cầu) lisp fillet. lấy một đối tuợng chọn làm chuân
Định nghĩa lại thì mệt lắm hè...

Filename: 162964_f+nil%3Cbr%3E.lsp
Tác giả: huunhantvxdts
Bài viết gốc: 403174
Tên lệnh: test
Hàm Reverse

Nh? m?i ng??i gi?i thích t?i sao hàm reverse n?m trong ?o?n lisp tôi ?ang dùng nó không ch?y (Chu?i danh sách nó không ??o ng??c l?i, mu?n text ch?n tr??c nó ph?i x?p tr??c)

?ây là lisp:

  (defun c:test (/ lsttn lstte)
  (setq lop1 "entdauco")
  (setq ent (car (entsel "\nChon Pline hoac Hatch mau tinh dien tich:")))
  (while ent
  (setq fltr (ssx_nhan ent))
  (setq lsttn (cons...
>>

Nh? m?i ng??i gi?i thích t?i sao hàm reverse n?m trong ?o?n lisp tôi ?ang dùng nó không ch?y (Chu?i danh sách nó không ??o ng??c l?i, mu?n text ch?n tr??c nó ph?i x?p tr??c)

?ây là lisp:

  (defun c:test (/ lsttn lstte)
  (setq lop1 "entdauco")
  (setq ent (car (entsel "\nChon Pline hoac Hatch mau tinh dien tich:")))
  (while ent
  (setq fltr (ssx_nhan ent))
  (setq lsttn (cons fltr lsttn))
  (prompt "\nChon Text ghi dien tich.")
  (setq DTS (car (entsel)))
  (setq DTS (entget DTS))
  (setq NDTS (cdr (assoc 1 DTS)))
  (setq lstte (cons NDTS lstte))
  (setq ent (car (entsel "\nChon Pline hoac Hatch mau tinh dien tich:")))
   )
  (reverse lstte)
  (princ lstte)
   )
   (defun ssx_nhan (ent / data fltr)
  (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)
    )
  )
)

file ?? test:


<<

Filename: 403174_test.lsp
Tác giả: Nguyen Hoanh
Bài viết gốc: 402687
Tên lệnh: xinchaohoanh1
test code
(defun c:test() (entget (car (entsel "\nAbcde: "))) (princ))
sdfdsf
sdfsdf

(defun c:xinchaohoanh1() (entget (car (entsel "\nAbcde: "))) (princ))

Filename: 402687_xinchaohoanh1.lsp
Tác giả: dckonhi1987
Bài viết gốc: 403216
Tên lệnh: 1234 round hs n
Sửa Lisp Làm Tròn Số

Hiện tại mình đang dùng 1 đoạn code (round3) của bác ssg để làm tròn số, nhưng nó giặp lỗi khi làm tròn số 0 hoặc số nhỏ là không làm tròn được
VD mình muốn với tp =2
số 0 >>0.00
số 0.0612 >> 0.06

Nhờ các bác xem và sửa dùm mình với!

(defun c:1234 () (load "test.LSP"))


;;;;;;;;;;;;;;;Chuyen thanh thap phan;;;;;;;;;;;;;;;;;;;;;
  (defun etype (e);;;Entity Type
(cdr...
>>

Hiện tại mình đang dùng 1 đoạn code (round3) của bác ssg để làm tròn số, nhưng nó giặp lỗi khi làm tròn số 0 hoặc số nhỏ là không làm tròn được
VD mình muốn với tp =2
số 0 >>0.00
số 0.0612 >> 0.06

Nhờ các bác xem và sửa dùm mình với!

(defun c:1234 () (load "test.LSP"))


;;;;;;;;;;;;;;;Chuyen thanh thap phan;;;;;;;;;;;;;;;;;;;;;
  (defun etype (e);;;Entity Type
(cdr (assoc 0 (entget e)))
)
;;;-------------------------------------------------------
(defun rnd(x);;;Round x, return INT
(if (>= x 0) (fix (+ x 0.5)) (fix (- x 0.5)))
) 
;;;-------------------------------------------------------
(defun round3(x / S i j S1 S3)

(setq S (itoa (rnd (* (abs x) (expt 10 thapphan)))))

(setq
i (strlen S)
j (- i thapphan)
S1 (substr S 1 j)
S3 (substr S (1+ j) thapphan)
)
(if (>= x 0) (strcat S1 "." S3) (strcat "-" S1 "." S3))
(if (and (< x 1) (> x (- 0 1))) (strcat "0." S3) (if (>= x 0) (strcat S1 "." S3) (strcat "-" S1 "." S3)))
)
;;;-------------------------------------------
(defun C:Round( / ss k i e d v S)

(setq
ss (ssget '((0 . "TEXT,MTEXT")))
i 0

)

(repeat (sslength ss)
(setq e (ssname ss i))
(if (= (etype e) "MTEXT") (progn
(command "explode" e "")
(setq e (entlast))
))
(setq
d (entget e)
v (atof (cdr (assoc 1 d)))
S (round3 v)
d (subst (cons 1 S) (assoc 1 d) d)
)
(entmod d)
(setq i (1+ i))
)
(princ)
)


;;;;;;;;;;;;;;DO DIEN TICH ;;;;;;;;;;;;
(defun c:hs() (setq tyle (getreal "\nDrawing scale : ")))
(defun c:N()
  (if (= tyle nil) 
  (progn (setq tyle (getreal "\nDrawing scale : ")))
  )
  (setq ntl (/ tyle 100))
    
  (setq tl2 (* ntl ntl))
  (setq dtl 0)

  (setq ss (ssadd))

  (setq oslast (getvar "OSMODE"))

  (command "osnap" "")

  (print)

  (print)

  (setq pt1 (getpoint "\nPick internal point : "))

  (while (/= pt1 nil)

    (command "-boundary" pt1 "")

    (setq et (entlast))

    (ssadd et ss)

    (command "area" "e" "last")

    (setq vsize ( /(getvar "VIEWSIZE") 3 ))

    (command "hatch" "ANSI31" vsize "0" "last" "")

    (setq et (entlast))

    (ssadd et ss)

    (setq dtcon (getvar "AREA"))

    (setq dtl (+ dtcon dtl))

    (print)

    (print)

    (setq pt1 (getpoint "\nPick internal point : "))

  )

  (command "setvar" "OSMODE" oslast)

  (command "erase" ss "")

  (setq ss nil)

  (command "redraw")

  (setq dtl (* dtl (* 1 tl2)))

  (print dtl)
  
  (setq elst (entget (car (entsel "Thay cho so: "))))
  (setq elst (subst (cons 1 (round3 dtl)) (assoc 1 elst) elst))

  (entmod elst)

  (print)

  (prompt (strcat "\nTotal area : " (rtos dtl 2 4)))

  (print)

);defun

<<

Filename: 403216_1234_round_hs_n.lsp
Tác giả: duy782006
Bài viết gốc: 403258
Tên lệnh: xuatgoc
Nhờ Viết Lisp Xuat Xyz Sang Góc Cạnh

-Trước tết mình nhận được cái yêu cầu i chang như vậy. Tin rằng với yêu cầu như của bạn với cái suy nghĩ ai biết viết lisp thì mọi lĩnh vực chỉ cần nhá xèng cái video cái là viết theo được ngay thì bạn sẽ chờ đến muôn thu trừ khi cái người viết lisp làm cùng lĩnh vực với bạn. 

-Còn cái tác giả theo như bạn nói cũng là mem của cadviet đấy thì phải.

-Kết quả của...

>>

-Trước tết mình nhận được cái yêu cầu i chang như vậy. Tin rằng với yêu cầu như của bạn với cái suy nghĩ ai biết viết lisp thì mọi lĩnh vực chỉ cần nhá xèng cái video cái là viết theo được ngay thì bạn sẽ chờ đến muôn thu trừ khi cái người viết lisp làm cùng lĩnh vực với bạn. 

-Còn cái tác giả theo như bạn nói cũng là mem của cadviet đấy thì phải.

-Kết quả của việc viết theo yêu cầu trước tết của mình là không thành mặc dù người yêu cầu ngồi bên cạnh mình nhưng vẩn ko giải thích được là mình phải làm gì. Vì trong dữ liệu nhập có chiều cao máy và chiều cao gương thì ko giải thích được nó tham gia vào việc tính toán như nào.

-Cái không thành phẩm của trước tết nó như này. Lệnh là xuatgoc

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:s_radian>do (gt / gt kq)
(setq kq (* (/ 180 pi) gt))
kq)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:3d>2d (diemtinh / diemtinh)
(setq diembet (list (car diemtinh) (cadr diemtinh)))
diembet)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:3point>gocnam (diemgoch diemdinhhuongh diemxacdinhh / diemgoch diemdinhhuongh diemxacdinhh gocnamh)
(setq gocnamh (- (angle (duy:3d>2d diemgoch) (duy:3d>2d diemxacdinhh)) (angle (duy:3d>2d diemgoch) (duy:3d>2d diemdinhhuongh))  )  )
(setq gocnamh (duy:s_radian>do gocnamh))
gocnamh)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:3point>gocdung (diemgoch diemdinhhuongh diemxacdinhh / diemgoch diemdinhhuongh diemxacdinhh gocdungh)
(setq diemgocnam ( duy:3d>2d diemgoch))
(setq diemdinhhuongnam ( duy:3d>2d diemdinhhuongh))
(setq diemxacdinhnam ( duy:3d>2d diemxacdinhh))
(setq kcgocdinhhuong (distance diemgocnam diemdinhhuongnam))
(setq kcgocgoc (distance diemgocnam diemgocnam))
(setq kcgocxacdinh (distance diemgocnam diemxacdinhnam))
(setq diemgocdung (list kcgocgoc (caddr diemgoch) ))
(setq diemxacdinhdung (list kcgocxacdinh (caddr diemxacdinhh) ))
(setq diemdinhhuongdung (list kcgocdinhhuong (caddr diemdinhhuongh) ))
(setq gocdungh (- (angle diemgocdung diemdinhhuongdung) (angle diemgocdung diemxacdinhdung)))

(setq gocdungh (duy:s_radian>do gocdungh))

(cond
((> gocdungh 90) (setq gocdungh (- 90 gocdungh) ))
((< gocdungh 90) (setq gocdungh (- 90 gocdungh) ))
)


gocdungh)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:point>dongnd (diemgoc diemdinhhuong diemxacdinh / diemgoc diemdinhhuong diemxacdinh)
(setq gocnam  (rtos (duy:3point>gocnam diemgoc diemdinhhuong diemxacdinh) 2 6))
;(setq gocnam (rtos (duy:s_radian>do (- (angle (duy:3d>2d diemgoc) (duy:3d>2d diemdinhhuong)) (angle (duy:3d>2d diemgoc) (duy:3d>2d diemxacdinh)))) 2 6)  )
(setq gocdung  (rtos (duy:3point>gocdung diemgoc diemdinhhuong diemxacdinh) 2 6))
(setq kcxien (rtos (distance diemgoc diemxacdinh) 2 2))
(setq nddong (strcat gocnam dauphancach gocdung dauphancach kcxien))
nddong)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:xuatgoc ()
(command "undo" "be")

(setq dauphancach ",")

(setq cdiemgoc (getpoint "\nChon diem goc:"))
(setq tdiemgoc (getstring "\nNhap ten diem goc:"))
(setq cdiemdinhhuong (getpoint "\nChon diem dinh huong:"))
(setq tdiemdinhhuong (getstring "\nNhap ten diem dinh huong:"))
(setq docaoguong (getstring "\nNhap do cao guong:"))

(princ "\nChon cac diem can tinh toan")
(setq tapdiemchon (ssget (list (cons 0 "POINT"))))

 (setq vitrifiledulieu (getfiled "File xuat du lieu " "" "csv" 1))

(setq nddong1 (strcat tdiemgoc dauphancach (rtos (car cdiemgoc) 2 4)  dauphancach (rtos (cadr cdiemgoc) 2 4) dauphancach (rtos (caddr cdiemgoc) 2 4) dauphancach  tdiemgoc))
(setq nddong2 (strcat tdiemdinhhuong dauphancach (rtos (car cdiemdinhhuong) 2 4)  dauphancach (rtos (cadr cdiemdinhhuong) 2 4) dauphancach (rtos (caddr cdiemdinhhuong) 2 4) dauphancach  tdiemdinhhuong))

(setq filedulieu (open vitrifiledulieu "w"))
(write-line nddong1 filedulieu)
(write-line nddong2 filedulieu)
(write-line "" filedulieu)
(write-line (strcat "stt" dauphancach "goc nam" dauphancach "gocdung" dauphancach "kcxien" dauphancach "Cao guong") filedulieu)

 (setq stt 0)
 (setq sodiem (sslength tapdiemchon))
 (while (< stt sodiem)
 (setq diemdocduoc (cdr (assoc 10 (entget (ssname tapdiemchon stt)))))
(setq nddongn (duy:point>dongnd cdiemgoc cdiemdinhhuong diemdocduoc))
(write-line (strcat (rtos (+ stt 1) 2 0) dauphancach nddongn dauphancach docaoguong) filedulieu)
 (setq stt (+ stt 1))
 )

(close filedulieu)
(command "undo" "end")
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(princ "\nLenh xuatgoc dung xuat tu XYZ sang goc")

<<

Filename: 403258_xuatgoc.lsp
Tác giả: Thaistreetz
Bài viết gốc: 192484
Tên lệnh: rsv+nil%3Cbr%3E
- Lisp theo dõi sự thay đổi biến hệ thống trong quá trình vẽ
Đôi khi ta cần biết những biến hệ thống nào đã bị thay đổi trong và sau khi thực hiện 1 lệnh nào đó trong quá trình vẽ. Việc lấy ra danh sách giá trị của tất cả biến hệ thống trước và sau khi thực hiện lệnh rồi so sánh thực sự vất vả mà kết quả không được đây đủ chi tiết nếu bạn lấy không đủ danh sách biến.
Lisp này có tác dụng theo dõi và thống kê cho bạn biết những...
>>
Đôi khi ta cần biết những biến hệ thống nào đã bị thay đổi trong và sau khi thực hiện 1 lệnh nào đó trong quá trình vẽ. Việc lấy ra danh sách giá trị của tất cả biến hệ thống trước và sau khi thực hiện lệnh rồi so sánh thực sự vất vả mà kết quả không được đây đủ chi tiết nếu bạn lấy không đủ danh sách biến.
Lisp này có tác dụng theo dõi và thống kê cho bạn biết những biến hệ thống nào của cad đã bị thay đổi khi thực hiện 1 lệnh cad, 1 lệnh lisp hay bất kỳ lệnh nào gây ra sự thay đổi biến hệ thống, đồng thời ghi ra luôn giá trị trước và sau khi thay đổi là bao nhiêu để bạn nắm được sự thay đổi đó.
;;;Copyright 2012 Thaistreetz from Cadviet.com
(defun C:RSV nil
(if (vlr-reactors :VLR-SysVar-Reactor)
(and (vlr-remove-all :VLR-SysVar-Reactor)
(prompt "<< Da Tat che do theo doi bien he thong >>"))
(and (vlr-sysvar-reactor "Sysvar Reactor: Sysvar Change" '((:vlr-sysvarwillchange . callback-sysvarchang) (:vlr-sysvarchanged . callback-sysvarchang)))
(prompt "<< Da Bat che do theo doi bien he thong >>"))) (princ))
(defun callback-sysvarchang (reactor sysvar)
(if (= (vlr-current-reaction-name) :vlr-sysvarwillchange)
(setq *sysvar* (getvar (car sysvar)))
(if (not (equal *sysvar* (getvar (car sysvar))))
(progn (princ (strcat "\n" (car sysvar) " : <" )) (princ *sysvar*) (princ ">") (princ " ----> <" ) (princ (getvar (car sysvar))) (princ ">")))))
Lưu ý: Hiện tại lisp này không nhận biết được sự thay đổi biến hệ thống qua việc thay đổi các lựa chọn trong hộp thoại Option của cad nhé. Mình dùng cad 2010 nó không nhận. các bản Cad khác thì mình chưa thử. Còn với command hay các lệnh lisp hoặc lệnh tạo bằng các ngôn ngữ khác nó nhận biết bình thường.
Bạn có thể bật hoặc tắt chế độ theo dõi bằng 1 lệnh duy nhất là RSV (reactor Sysvar)

Có thể cũng bạn quan tâm: Lisp so sánh sự khác nhau giữa các biến hệ thống của 2 bản vẽ
<<

Filename: 192484_rsv+nil%3Cbr%3E.lsp
Tác giả: master_worse
Bài viết gốc: 109300
Tên lệnh: muondatgithidat
Viết lisp theo yêu cầu [phần 2]

Sao bạn không dùng fi (FILTER) ?
Command: fi -> Select filter chọn Text Value nhập vào ô trống bên dưới *nguyễn văn* -> Add to list -> Apply -> chọn tất tần tật
----------------------------
Không biết đúng ý không

Filename: 109300_muondatgithidat.lsp
Tác giả: phamngoctukts
Bài viết gốc: 110477
Tên lệnh: tdd
Viết lisp theo yêu cầu [phần 2]

Cái này mình làm theo đúng ý của bạn. Nó xuất toạ độ các đỉnh ra file txt trong cùng thư mục và cùng tên với bản vẽ đang mở.

Filename: 110477_tdd.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 403670
Tên lệnh: tt%C2%A0
Nhờ Mọi Người Sửa Hộ Lisp Leader.

Điểm C chỉ là để lấy khoảng cách và góc hợp giữa đoạn thẳng nối A-C với khúc đầu của leader. Hướng rải luôn theo hướng mũi tên leader, nếu góc ở trên < 90 thì rải giật lùi và ngược lại.

(defun c:tt  (/ ang apt dis ele ent i lea len lsc lsm lsp pt pt1 pt2)
 (vl-load-com)
 (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
 (if (and (setq...
>>

Điểm C chỉ là để lấy khoảng cách và góc hợp giữa đoạn thẳng nối A-C với khúc đầu của leader. Hướng rải luôn theo hướng mũi tên leader, nếu góc ở trên < 90 thì rải giật lùi và ngược lại.

(defun c:tt  (/ ang apt dis ele ent i lea len lsc lsm lsp pt pt1 pt2)
 (vl-load-com)
 (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
 (if (and (setq ele (ssget "_+.:E:S" '((0 . "LEADER"))))
          (setq ent (ssname ele 0)
                lsp (vl-remove-if-not '(lambda (x) (member (car x) '(10))) (entget ent))
                lsc (vlax-get-property (vlax-ename->vla-object ent) 'ScaleFactor))
          (setq pt1 (cdr (car lsp)))
          (setq dis (getdist "\nKhoang cach giua cac Leader: " pt1))
          (setq pt2 (getpoint "\nDiem ket thuc: " pt1)))
  (progn (setq lsm (vl-remove-if '(lambda (x) (member (car x) '(-1 5 10 330 340))) (entget ent))
               ang (angle pt1 (cdr (cadr lsp)))
               len (distance pt1 pt2)
               i   0)
         (setq apt (angle pt1 pt2))
         (if (or (< (- apt ang) (* 0.5 pi)) (> (- apt ang) (* 1.5 pi)))
          (setq ang ang)
          (setq ang (+ ang pi)))
         (repeat (fix (/ len dis))
          (setq pt (polar pt1 ang (* dis (setq i (1+ i)))))
          (setq lea (entmakex (append lsm (subst (cons 10 pt) (assoc 10 lsp) lsp))))
          (vlax-put-property (vlax-ename->vla-object lea) 'ScaleFactor lsc))))
 (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
 (princ))

<<

Filename: 403670_tt%C2%A0.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 403829
Tên lệnh: tt%C2%A0
Bóc Khối Lượng Block Dynamic Tích Hợp Nhiều Đối Tượng

Ồ vậy mà...! Khi làm lisp, lấy tên block nó ra tiếng Hàn, chỗ thì được chỗ thì lỗi, làm mình phải cài thêm tiếng Hàn cho máy để kiểm tra LISP...

Đây là lisp sửa lại từ BLKQTY của Bác GiaBach (Nếu muốn đổi chiều cao chữ thì gõ lệnh TEXTSIZE nhập giá trị trước khi chạy Lisp).

(defun c:tt  (/ LM:al-effectivename LM:getdynprops blk blk_name ent i lst_blk pt row ss...
>>

Ồ vậy mà...! Khi làm lisp, lấy tên block nó ra tiếng Hàn, chỗ thì được chỗ thì lỗi, làm mình phải cài thêm tiếng Hàn cho máy để kiểm tra LISP...

Đây là lisp sửa lại từ BLKQTY của Bác GiaBach (Nếu muốn đổi chiều cao chữ thì gõ lệnh TEXTSIZE nhập giá trị trước khi chạy Lisp).

(defun c:tt  (/ 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)))
 (or (> (setq htxt (getvar 'TEXTSIZE)) 0) (setq htxt (setvar 'TEXTSIZE 250)))
 (if (setq ss (ssget (list (cons 0 "INSERT"))))
  (progn (vl-load-com)
         (setq i -1)
         (while (setq ent (ssname ss (setq i (1+ i))))
          (setq blk (vlax-ename->vla-object ent))
          (setq blk_name (strcat (LM:al-effectivename ent) ": " (cdar (LM:getdynprops blk))))
          (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))

<<

Filename: 403829_tt%C2%A0.lsp
Tác giả: Tot77
Bài viết gốc: 403865
Tên lệnh: tt
Bóc Khối Lượng Block Dynamic Tích Hợp Nhiều Đối Tượng

Hi cảm ơn bác @gia_bach.

 

- Mình load được rồi nhưng khi sử dụng chỉ đếm được block dynamic, không đếm được block thường.

 

- Bác @gia_bach xem file đính kèm dùm mình nhé.

.

Được voi đòi lung tung, cung may cái đòi lung tung đó không phải sửa nhiều, xài thử cái này.

(defun c:tt (/ 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)))
 
 (or (> (setq htxt (getvar 'TEXTSIZE)) 0) (setq htxt (setvar 'TEXTSIZE 250)))
 (if (setq ss (ssget (list (cons 0 "INSERT"))))
  (progn (vl-load-com)
         (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))

<<

Filename: 403865_tt.lsp
Tác giả: duy782006
Bài viết gốc: 3791
Tên lệnh: nd+%3Cbr%3E
Viết Lisp theo yêu cầu


Mình có cái này hồi xưa thấy trong CD bán ngoài thị trường chẳng biết của ai viết nhưng đúng ý của bạn nè.


Tên lệnh là ND
Chọn chử muốn chỉnh trước rồi chọn chử làm mẫu sau. Chúc vui !!!!!!

Filename: 3791_nd+%3Cbr%3E.lsp
Tác giả: saocuoitroi
Bài viết gốc: 396628
Tên lệnh: gktc
Hỏi-Lisp Ghi Kích Thước Cạnh Tự Động Cho Polyline Theo Tỷ Lệ Tự Chọn

Em sưu tầm được lisp ghi kích thước cạnh tự động của bác Duân, nhưng khi chạy lisp muốn chọn tỷ lệ trước: ví dụ: chọn tỉ lệ 1/1000; 1/2000;1/… thì vẽ độ dài ra text theo đúng tỷ lệ (Tương ứng với tỉ lệ) , đồng thời phần thập dấu chấm “.” thay bằng dấu phẩy “,” . Mong các bác giúp đỡ, cảm ơn nhiều ạ.

LISP: (Em mem mới không biết up lisp thế nào xin thông cảm...

>>

Em sưu tầm được lisp ghi kích thước cạnh tự động của bác Duân, nhưng khi chạy lisp muốn chọn tỷ lệ trước: ví dụ: chọn tỉ lệ 1/1000; 1/2000;1/… thì vẽ độ dài ra text theo đúng tỷ lệ (Tương ứng với tỉ lệ) , đồng thời phần thập dấu chấm “.” thay bằng dấu phẩy “,” . Mong các bác giúp đỡ, cảm ơn nhiều ạ.

LISP: (Em mem mới không biết up lisp thế nào xin thông cảm ạ)

 

(defun c:GKTC (/ ANS ENAME_OBJ I SS)

  (vl-load-com)

  (setvar "CMDECHO" 0)

  (defun *error* (msg)

    (if    Olmode

      (setvar 'osmode Olmode)

    )

    (if    (not (member msg '("*BREAK,*CANCEL*,*EXIT*")))

      (princ (strcat "\nError: " msg))

    )

    (princ)

  )

  (setq Olmode (getvar "OSMODE"))

  (or *Caochu* (setq *Caochu* 2))

  (setq  Caochu (getreal           (strcat  "\nNh\U+1EADp chi\U+1EC1u cao Text <"

                                                (rtos *Caochu* 2 2)

                                                "> :"

                                    )

                   )

  )

  (if (not Caochu)

    (setq Caochu *Caochu*)

    (setq *Caochu* Caochu)

  )

  (or *Sole* (setq *Sole* 2))

  (setq  Sole

             (getint

               (strcat

                 "\nNh\U+1EADp s\U+1ED1 l\U+1EBB sau s\U+1ED1 ph\U+1EA9y <"

                 (rtos *Sole* 2 2)

                 ">: "

               )

             )

  )

  (if (not Sole)

    (setq Sole *Sole*)

    (setq *Sole* Sole)

  )

  (initget "C K")

  (setq  ans

             (strcase

               (getkword

                 "\nB\U+1EA1n mu\U+1ED1n break c\U+00E1c \U+0111\U+1ED1i t\U+01B0\U+1EE3ng t\U+1EA1i c\U+00E1c \U+0111i\U+1EC3m giao nhau kh\U+00F4ng? : "

               )

             )

  )

  (cond

    ((= ans "C")

     (progn

       (breakall

             (ssget

               (list

                 (cons 0

                           "*LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"

                 )

               )

             )

       )

       (alert

             "\U+0110\U+00E3 break t\U+1EA1i c\U+00E1c \U+0111i\U+1EC3m giao nhau, qu\U+00E9t ch\U+1ECDn l\U+1EA1i \U+0111\U+1ED1i t\U+01B0\U+1EE3ng"

       )

       (setq ss

                  (ssget

                        (list

                          (cons

                            0

                            "*LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"

                          )

                        )

                  )

       )

     )

    )

    ((= ans "K")

     (setq ss

                (ssget

                  (list

                        (cons 0

                              "*LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"

                        )

                  )

                )

     )

    )

  )

 

  (setq i 0)

  (repeat (sslength ss)

    (setq Ename_Obj (ssname ss i))

    (cond

      ((= (cdr (assoc 0 (entget Ename_Obj))) "LINE")

       (GKT_Line Ename_Obj)

      )

      ((= (cdr (assoc 0 (entget Ename_Obj))) "LWPOLYLINE")

       (GKT_PLine Ename_Obj)

      )

      ((= (cdr (assoc 0 (entget Ename_Obj))) "POLYLINE")

       (GKT_PLine Ename_Obj)

      )

    )

    (setq i (1+ i))

  )

  (setvar "OSMODE" Olmode)

  (princ)

)

(defun MakeLayer_ (name colour /)

  (if (null (tblsearch "LAYER" name))

    (entmake

      (list

            '(0 . "LAYER")

            '(100 . "AcDbSymbolTableRecord")

            '(100 . "AcDbLayerTableRecord")

            '(70 . 0)

            (cons 2 name)

            (cons 62 colour)

      )

    )

  )

)

 

(defun GKT_PLine (ob / DG_I GOC I KC_I N P PG_IA PG_IB PII PVI P_2)

                                                            ;Ghi kich thuoc

  (setq  n (vlax-curve-getEndParam ob)

            i 0

  )

  (MakeLayer_ "KT_CANH" 7)

  (while (< i n)

    (setq P (vlax-curve-getPointAtParam ob i))

    (setq P_2 (vlax-curve-getPointAtParam ob (+ i 1)))

    (setq goc (angle P P_2))

    (setq KC_i (distance P P_2))

    (setq DG_i (polar P goc (/ KC_i 2)))

    (setq Pii (polar P (/ pi 2) Caochu))

    (setq PVi (TinhgocPV (angle P P_2)))

    (if    (< PVi pi)

      (progn

            (setq PG_ia (polar DG_i (+ (/ pi 2) goc) (* Caochu 0.5)))

            (MakeText PG_ia (rtos KC_i 2 Sole) Caochu goc "C" nil nil nil)

      )

      (progn

            (setq

              PG_ib            (polar DG_i (+ (/ pi 2) (angle P_2 P)) (* Caochu 0.5))

            )

            (MakeText PG_ib

                          (rtos KC_i 2 Sole)

                          Caochu

                          (angle P_2 P)

                          "C"

                          "KT_CANH"

                          nil

                          nil

            )

      )

    )

    (setq i (1+ i))

  )

 

)

;;GKT_Line

 

 

;;;;;;;;;;;;;;;(R2DPG (TinhgocPV (ANGLE (GETPOINT) (GETPOINT))))

(defun GKT_Line       (Ename_Line   /          DG_I  GOC  KC_I

                         P         PG_IA           PG_IB            PII      PVI    P_2

                         TEMP

                        )

 

 

 

  (setq temp (entget Ename_Line))

  (setq P (cdr (assoc 10 temp)))

  (setq P_2 (cdr (assoc 11 temp)))

  (setq goc (angle P P_2))

  (setq KC_i (distance P P_2))

  (setq DG_i (polar P goc (/ KC_i 2)))

  (setq Pii (polar P (/ pi 2) Caochu))

  (setq PVi (TinhgocPV (angle P P_2)))

  (MakeLayer_ "KT_CANH" 7)

  (if (< PVi pi)

    (progn

      (setq PG_ia (polar DG_i (+ (/ pi 2) goc) (* Caochu 0.5)))

      (MakeText PG_ia (rtos KC_i 2 Sole) Caochu goc "C" nil nil nil)

    )

    (progn

      (setq

            PG_ib (polar DG_i (+ (/ pi 2) (angle P_2 P)) (* Caochu 0.5))

      )

      (MakeText PG_ib

                        (rtos KC_i 2 Sole)

                        Caochu

                        (angle P_2 P)

                        "C"

                        "KT_CANH"

                        nil

                        nil

      )

    )

  )

 

 

)

 

(defun mid (p1 p2)

  (mapcar '(lambda (x1 x2) (/ (+ x1 x2) 2.0)) p1 p2)

)

 

 

 

 

(defun TD:Text-Base (ent /  MA71 MA72 X11)

  (setq Ma10 (cdr (assoc 10 (entget ent))))

  (setq Ma11 (cdr (assoc 11 (entget ent))))

  (setq X11 (car Ma11))

  (setq Ma71 (cdr (assoc 71 (entget ent))))

  (setq Ma72 (cdr (assoc 72 (entget ent))))

  (if (or (and (= Ma71 0) (= Ma72 0) (= X11 0))

              (and (= Ma71 0) (= Ma72 3))

              (and (= Ma71 0) (= Ma72 5))

      )

    Ma10

    Ma11

  )

)

 

(defun DTR (Do / radian)

  (setq radian (/ (* Do pi) 180))

)

 

 

(defun MakeText        (point string Height Ang justify Layer Style Color / Lst)

                                                            ; Ang: Radial

  (setq  Lst       (list '(0 . "TEXT")

                              (cons 10 point)

                              (cons 40 Height)

                              (cons 8

                                        (if    Layer

                                          Layer

                                          (getvar "CLAYER")

                                        )

                              )

                              (cons 1 string)

                              (if Ang

                                    (cons 50 Ang)

                              )

                              (cons 7

                                        (if    Style

                                          Style

                                          (getvar "Textstyle")

                                        )

                              )

                              (cons 62 (if Color Color 256))

                        )

            justify  (strcase justify)

  )

  (cond

    ((= justify "C")

     (setq Lst (append Lst (list (cons 72 1) (cons 11 point))))

    )

    ((= justify "L")

     (setq

       Lst (append Lst (list (cons 72 0) (cons 73 0) (cons 10 point)))

     )

    )

    ((= justify "R")

     (setq Lst (append Lst (list (cons 72 2) (cons 11 point))))

    )

    ((= justify "M")

     (setq Lst (append Lst (list (cons 72 4) (cons 11 point))))

    )

    ((= justify "TL")

     (setq

       Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))

     )

    )

    ((= justify "TC")

     (setq

       Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))

     )

    )

    ((= justify "TR")

     (setq

       Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))

     )

    )

    ((= justify "ML")

     (setq

       Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))

     )

    )

    ((= justify "MC")

     (setq

       Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))

     )

    )

    ((= justify "MR")

     (setq

       Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))

     )

    )

    ((= justify "BL")

     (setq

       Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))

     )

    )

    ((= justify "BC")

     (setq

       Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))

     )

    )

    ((= justify "BR")

     (setq

       Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1)))

     )

    )

  )

  (entmakex Lst)

)

 

(defun _layer2 (name colour)

  (if (null (tblsearch "LAYER" name))

    (entmake

      (list

            '(0 . "LAYER")

            '(100 . "AcDbSymbolTableRecord")

            '(100 . "AcDbLayerTableRecord")

            '(70 . 0)

            (cons 2 name)

            (cons 62 colour)

      )

    )

  )

)

                                                            ;revlwpl

(defun revlwpl (ent1 / eo el len)

  (setq ent (entget ent1))

  (vl-load-com)

  (setq eo ent)

  (setq el (list (assoc 210 ent)))

  (while (member (assoc 10 ent) ent)

    (if    (= 0.0 (assoc 42 ent))

      (setq el (cons (assoc 42 ent) el))

      (setq el (cons (cons 42 (- (cdr (assoc 42 ent)))) el))

    )

    (setq el (cons (assoc 41 ent) el))

    (setq el (cons (assoc 40 ent) el))

    (setq el (cons (assoc 10 ent) el))

    (setq ent (member (assoc 10 ent) ent))

    (setq ent (cdr ent))

  )

  (setq len (- (LENGTH eo) (LENGTH (member (assoc 10 eo) eo)) 1))

  (while (>= len 0)

    (setq el (cons (nth len eo) el))

    (setq len (- len 1))

  )

  (setq ent el)

  (entmod ent)

  (princ)

)

 

(defun Rad_to_Do (radian / Do)

  (setq Do (/ (* radian 180) pi))

)

(defun Do_to_Radian (Do / radian)

  (setq radian (/ (* Do pi) 180))

)

(defun R2DPG (gocR / DPG Toando Do Phut1 Phut Giay DPG)

  (setq DPG (list))

  (setq Toando (Rad_to_Do gocR))

  (setq Do (fix Toando))

  (setq Phut1 (* (- Toando Do) 60))

  (setq Phut (fix Phut1))

  (setq Giay (atof (rtos (* (- phut1 phut) 60) 2 3)))

  (setq DPG (list Do Phut giay))

  DPG

)

(defun DPG_to_DO (Goc)

  (setq DD (nth 0 Goc))

  (setq PP (/ (nth 1 Goc) 60))

  (setq GG (/ (nth 2 Goc) 3600))

  (setq DDD (+ DD PP GG))

  DDD

)

(defun Dogoc2diem (P1 P2 /)

  (setq gocP12 (angle P1 P2))

  (setq gocP12_DPG (R2DPG gocP12))

  (setq Goc_12 (DPG_to_DO gocP12_DPG))

  Goc_12

)

(defun Do_to_DPG (Toando /)

  (setq Do (fix Toando))

  (setq Phut1 (* (- Toando Do) 60))

  (setq Phut (fix Phut1))

  (setq Giay (atof (rtos (* (- phut1 phut) 60) 2 3)))

  (setq DPG (list Do Phut giay))

  DPG

)

 

 

(defun TinhgocPV (GocLine /)

  (cond

    ((if (and (>= GocLine 0) (<= GocLine (/ pi 2)))

       (setq GocPV (- (/ pi 2) GocLine))

     )

    )

 

    ((if (and (>= GocLine (/ pi 2)) (<= GocLine (* pi 2)))

       (setq GocPV (- (+ (* 2 pi) (/ pi 2)) GocLine))

     )

    )

 

  )

  GocPV

)

 

 

 

 

(defun breakall            (a / b i p selset j ent)

  (command ".undo" "be")

  (setting)

  (setq b (findallintersction a))

  (setq i 0)

  (repeat (length B)

    (setq p (nth i B))

    (setq selset (selectatonepoint p))

    (setq j 0)

    (repeat (sslength selset)

      (setq ent (ssname selset j))

      (newbreak ent p)

      (setq j (1+ j))

    )

    (setq i (1+ i))

  )

  (resetting)

  (command ".undo" "e")

  (princ)

)

(defun selectatonepoint          (a / tor p1 p2 ss)

  (setq tor 0.01)

  (setq p1 (polar a (* (/ 135 180) pi) tor))

  (setq p2 (polar a (* (/ 315 180) pi) tor))

  (setq ss (ssget "_c" p1 p2))

  ss

)

(defun findallintersction (sset / interlst ssl i e1 j e2 l)

  (setq interlst nil)

  (setq  ssl (sslength sset)

            i   0

  )

  (repeat ssl

    (setq e1 (ssname sset i))

    (setq j (1+ i))

    (repeat (- ssl (1+ i))

      (setq e2 (ssname sset j))

      (setq l (kht-intersect e1 e2))

      (setq interlst (append

                               interlst

                               l

                             )

      )

      (setq j (1+ j))

    )

    (setq i (1+ i))

  )

  interlst

)

(defun kht-intersect (en1 en2 / a b x ex ex-app c d e)

  (vl-load-com)

  (setq  c (cdr (assoc 0 (entget en1)))

            d (cdr (assoc 0 (entget en2)))

  )

  (if (or

            (= c "TEXT")

            (= d "TEXT")

      )

    (setq e -1)

  )

  (setq En1 (vlax-ename->vla-object En1))

  (setq En2 (vlax-ename->vla-object En2))

  (setq a (vla-intersectwith en1 en2 acExtendNone))

  (setq a (vlax-variant-value a))

  (setq b (vlax-safearray-get-u-bound a 1))

  (if (= e -1)

    (setq b e)

  )

  (if (/= b -1)

    (progn

      (setq a (vlax-safearray->list a))

      (repeat (/ (length a) 3)

            (setq ex-app (append

                               ex-app

                               (list (list (car a) (cadr a) (caddr a)))

                             )

            )

            (setq a (cdr (cdr (cdr a))))

      )

      ex-app

    )

    nil

  )

)

(defun kht:list->safearray (lst datatype)

  (vlax-safearray-fill

    (vlax-make-safearray

      (eval datatype)

      (cons 0

                (1-

                  (length lst)

                )

      )

    )

    lst

  )

)

(defun newbreak         (ent pt / obj2Break p1param p2param p2)

  (setq obj2Break (vlax-ename->vla-object ent))

  (cond

    ((and

       (= "AcDbSpline" (vla-get-objectname obj2Break))

 

       (vlax-curve-isClosed obj2Break)

     )

     (setq p1param (vlax-curve-getparamatpoint obj2Break pt)

               p2param (+ p1param 0.000001)

               p2        (vlax-curve-getPointAtParam obj2Break p2param)

     )

     (command "._break"

                  (vlax-vla-object->ename obj2Break)

                  "non"

                  (trans pt 0 1)

                  "non"

                  (trans p2 0 1)

     )

    )

    ((= "AcDbCircle" (vla-get-objectname obj2Break))

     (setq p1param (vlax-curve-getparamatpoint obj2Break pt)

               p2param (+ p1param 0.000001)

               p2        (vlax-curve-getPointAtParam obj2Break p2param)

     )

     (command "._break"

                  (vlax-vla-object->ename obj2Break)

                  "non"

                  (trans pt 0 1)

                  "non"

                  (trans p2 0 1)

     )

     (setq en (entlast))

    )

    ((and

       (= "AcDbEllipse" (vla-get-objectname obj2Break))

 

       (vlax-curve-isClosed obj2Break)

     )

 

     (setq p1param  (vlax-curve-getparamatpoint obj2Break pt)

               p2param  (+ p1param 0.000001)

 

               minparam (min

                              p1param

                              p2param

                            )

               maxparam (max

                              p1param

                              p2param

                            )

     )

     (vlax-put obj2Break 'startparameter maxparam)

     (vlax-put obj2Break 'endparameter (+ minparam (* pi 2)))

    )

 

 

    (t

     (command "._break" ent pt "@")

    )

  )

)

(defun err (s)

  (if (= s "Function cancelled")

    (princ "\nALIGNIT - cancelled: ")

    (progn

      (princ "\nALIGNIT - Error: ")

      (princ s)

      (terpri)

    )

  )

  (resetting)

  (princ "SYSTEM VARIABLES have been reset\n")

  (princ)

)

(defun setv (systvar newval / x)

  (setq x (read (strcat systvar "1")))

  (set x (getvar systvar))

  (setvar systvar newval)

)

(defun setting ()

  (setq oerr *error*)

  (setq *error* err)

  (setv "BLIPMODE" 0)

  (setv "CMDECHO" 0)

  (setv "OSMODE" 0)

)

(defun rsetv (systvar)

  (setq x (read (strcat systvar "1")))

  (setvar systvar (eval x))

)

(defun resetting ()

  (rsetv "BLIPMODE")

  (rsetv "CMDECHO")

  (rsetv "OSMODE")

  (setq *error* oerr)

)

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


<<

Filename: 396628_gktc.lsp
Tác giả: various
Bài viết gốc: 403929
Tên lệnh: ob2wo wof wo2pl
Lỗi Lisp Vẽ Wipeout Không Có Tác Dụng Trong Acad2016

Link ảnh gif để mọi người view cho dễ http://gifyu.com/image/ZyQ

Em sử dụng lisp có code như thế này. Ở Acad2010 vẫn bình thường, sang 2016 thì không có tác dụng nữa. Mong mọi người giúp đỡ

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

Link ảnh gif để mọi người view cho dễ http://gifyu.com/image/ZyQ

Em sử dụng lisp có code như thế này. Ở Acad2010 vẫn bình thường, sang 2016 thì không có tác dụng nữa. Mong mọi người giúp đỡ

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

<<

Filename: 403929_ob2wo_wof_wo2pl.lsp
Tác giả: conmasitinh
Bài viết gốc: 15630
Tên lệnh: ax az
Vẽ đường thằng đặc biệt

Có nhiều trường hợp đấy bạn, phải có thêm ràng buộc thì may ra :bigsmile:

Filename: 15630_ax_az.lsp
Tác giả: Tot77
Bài viết gốc: 403997
Tên lệnh: ob2wo wof wo2pl
Lỗi Lisp Vẽ Wipeout Không Có Tác Dụng Trong Acad2016

Sửa lại và test trên AC2015 ok.

(defun c:OB2WO (/ ent lst nor ss)
  (vl-load-com)
  (if (setq ss (ssget (list (cons 0 "CIRCLE,ELLIPSE,LWPOLYLINE")))) 
   (progn (vla-StartundoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
     (initget "Yes No") 
     (setq ans (getkword "\nDelete source object? [Yes/No] <No>: ")) 
    (foreach ent...
>>

Sửa lại và test trên AC2015 ok.

(defun c:OB2WO (/ ent lst nor ss)
  (vl-load-com)
  (if (setq ss (ssget (list (cons 0 "CIRCLE,ELLIPSE,LWPOLYLINE")))) 
   (progn (vla-StartundoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
     (initget "Yes No") 
     (setq ans (getkword "\nDelete source object? [Yes/No] <No>: ")) 
    (foreach ent (ST:Ss->ListEnt ss)
     (setq lst (ent2ptlst ent))
     (setq nor (cdr (assoc 210 (entget ent)))) 
     (makeWipeout lst nor)
     (if (or (not ans) (wcmatch (strcase ans) "YES"))(entdel ent))
    )
    (vla-EndundoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
   )
  )
 )
 
 (defun c:wof (/ elst)
  (cond ((and (setq elst (dictsearch (namedobjdict) "ACAD_WIPEOUT_VARS"))
(ssget "x" '((0 . "WIPEOUT,INSERT"))) )
(entmod (subst (cons 70 (boole 6 (cdr (assoc 70 elst)) 1)) (assoc 70 elst) elst))
 (vlax-for obj (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object))) (vla-update obj) ) )
    (T (princ "\nHave no wipeout object !"))
  )
  (princ)
 )
 
 (defun c:wo2pl (/ ss n wo elst pts norm ans)
 (if (setq ss (ssget '((0 . "WIPEOUT"))))
 (progn (initget "Yes No") 
  (setq ans (getkword "\nDelete source object? [Yes/No] <No>: ")) 
  (foreach wo (ST:Ss->ListEnt ss) 
   (setq elst (entget wo)
    norm (vunit (v^v (cdr (assoc 11 elst)) (cdr (assoc 12 elst))))
    pts (wipeout2plst wo)
   )
   (entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline")
(cons 90 (length pts)) (cons 38 (caddr (trans (car pts) 0 norm))) '(70 . 1) (cons 210 norm) )
(mapcar '(lambda (pt) (setq pt (trans pt 0 norm)) (list 10 (car pt) (cadr pt)) ) pts ) )
   )
   (if (or (not ans) (wcmatch (strcase ans) "YES"))(entdel wo))
(princ) 
 ))) 
 )
 
 (defun wipeout2plst (wo / elst u v mat)
  (setq elst (entget wo)
  u (cdr (assoc 11 elst))
  v (cdr (assoc 12 elst))
  mat (list u (mapcar '- v) '(0. 0. 1.))
  )
  (mapcar '(lambda (p) (mapcar '+ (mxv (trp mat) p) (mapcar '(lambda (x y) (/ (+ x y) 2.)) u v) (cdr (assoc 10 elst)) ) )
   (cdr (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 14)) elst) )))
 )
 
 (defun trp (m) (apply 'mapcar (cons 'list m)))
 (defun mxv (m v)  (mapcar '(lambda (r) (apply '+ (mapcar '* r v))) m))
 (defun v^v (v1 v2)
  (list (- (* (cadr v1) (caddr v2)) (* (caddr v1) (cadr v2)))
   (- (* (caddr v1) (car v2)) (* (car v1) (caddr v2)))
   (- (* (car v1) (cadr v2)) (* (cadr v1) (car v2)))
  )
 )
 
 (defun vunit (v)
  ((lambda (l) (if (/= 0 l) (mapcar (function (lambda (x) (/ x l))) v) ) )
   (distance '(0 0 0) v)
  )
 )
 
 (defun ent2ptlst (ent / obj dist n lst p_lst prec)
  (vl-load-com)
  (if (= (type ent) 'ENAME)  (setq obj (vlax-ename->vla-object ent)))
  (cond ((member (cdr (assoc 0 (entget ent))) '("CIRCLE" "ELLIPSE"))
(setq dist (/ (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj) ) 50 ) n 0 )
(repeat 50 (setq lst (cons (trans (vlax-curve-getPointAtDist obj (* dist (setq n (1+ n)))) 0 (vlax-get obj 'Normal)) lst ))))
 
   (T (setq p_lst (vl-remove-if-not '(lambda (x) (or (= (car x) 10) (= (car x) 42) ) ) (entget ent) ) )
(while p_lst (setq lst (cons (append (cdr (assoc 10 p_lst)) (list (cdr (assoc 38 (entget ent)))) ) lst ) )
(if (/= 0 (cdadr p_lst))
(progn
(setq prec (1+ (fix (* 25 (sqrt (abs (cdadr p_lst))))))
dist (/ (- (if (cdaddr p_lst) (vlax-curve-getDistAtPoint obj (trans (cdaddr p_lst) ent 0) )
(vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj) ) )
(vlax-curve-getDistAtPoint obj (trans (cdar p_lst) ent 0) ) ) prec ) n 0 )
   (repeat (1- prec)
    (setq lst (cons (trans (vlax-curve-getPointAtDist obj (+ (vlax-curve-getDistAtPoint obj (trans (cdar p_lst) ent 0) )
(* dist (setq n (1+ n))) ) ) 0 ent ) lst ) ))
  )
   )
   (setq p_lst (cddr p_lst))
  )
  )
  )
  lst
)
  (defun MakeWipeout (pt_lst nor / dxf10 max_dist cen dxf_14)
 (setq dxf10 (list (apply 'min (mapcar 'car pt_lst)) (apply 'min (mapcar 'cadr pt_lst)) (caddar pt_lst)))
 (setq max_dist (float (apply 'max (mapcar '- (apply 'mapcar (cons 'max pt_lst)) dxf10))))
 (setq cen (mapcar '+ dxf10 (list (/ max_dist 2) (/ max_dist 2) 0.0)))
 (setq dxf14 (mapcar '(lambda (p) (mapcar '/ (mapcar '- p cen) (list max_dist (- max_dist) 1.0))) pt_lst))
 (setq dxf14 (reverse (cons (car dxf14) (reverse dxf14))))
    (entmake (append (list '(0 . "WIPEOUT") '(100 . "AcDbEntity") '(100 . "AcDbWipeout")
(cons 10 (trans dxf10 nor 0)) (cons 11 (trans (list max_dist 0.0 0.0) nor 0))
(cons 12 (trans (list 0.0 max_dist 0.0) nor 0)) '(13 1.0 1.0 0.0)
'(70 . 7) '(280 . 1) '(281 . 50) '(282 . 50) '(283 . 0)
'(71 . 2) (cons 91 (length dxf14)) )
(mapcar '(lambda (p) (cons 14 p)) dxf14) )
   )
 )
 
 (defun ST:Ss->ListEnt (ss / n e l)
 (setq n (sslength ss))
 (while (setq e (ssname ss (setq n (1- n))))
  (setq l (cons e l))
 ) 
 ) 

<<

Filename: 403997_ob2wo_wof_wo2pl.lsp
Tác giả: minhtu2004
Bài viết gốc: 404057
Tên lệnh: z0
Nhờ Mọi Người Xem Dùm Code Lấy Text Xung Quanh Điểm.

- Mình có viết đoạn code nhờ mọi xem dùm và chỉnh dùm đoạn code lấy text xung quanh điểm và convert thành số. Mình có gửi file cad. Mong mọi người giúp. Có thể thêm dùm mình doạn code nâng độ cao Z của toàn bộ điểm. Bản vẽ có khoảng vài chục ngàn điểm. Thank mọi người.

- Mình có viết đoạn code nhờ mọi xem dùm và chỉnh dùm đoạn code lấy text xung quanh điểm và convert thành số. Mình có gửi file cad. Mong mọi người giúp. Có thể thêm dùm mình doạn code nâng độ cao Z của toàn bộ điểm. Bản vẽ có khoảng vài chục ngàn điểm. Thank mọi người.http://www.cadviet.com/upfiles/6/35974_new_block.dwg

(defun ss2ent (ss / i Le e) ;;;Convert ss to list of ename
(setq i 0)
(repeat (sslength ss)     
(setq e (ssname ss i)        
Le (append Le (list e))        
i (1+ i)    ))
Le)
;///////////////////////////////////////
(defun c:Z0(/ ss etype)
  (setq ss (ssget '((0 . "POINT"))))
  (if ss
    (progn
      (setq ds_line (ss2ent ss))
      (repeat (1- (length ds_line))
	(setq ds_line (vl-remove (setq e0 (car ds_line)) ds_line))
	(foreach e ds_line (setq Lp (append Lp (ds_line e0 e))))
	)
      (foreach k Lp
	(setq pdau (mapcar '+ k '(0.1 0.1 0.0)) pcuoi (mapcar '+ k '(-0.1 -0.1 0.0)))
	(if  (setq ssk   (ssget "_C" pcuoi pdau '((0 . "TEXT"))))
	  (progn
	    (setq ss1 (ss2ent ssk))
	    (foreach u ss1
	      (if (= (cdr (assoc 8 (entget u))) "S-BMK-SRVR")
		(setq te1 (distof (cdr (assoc 1 (entget u))))))
	      )
	    )
	  )
	)
      )
    )

<<

Filename: 404057_z0.lsp
Tác giả: thanh_kta
Bài viết gốc: 404244
Tên lệnh: gc
Sửa Lisp Để Tương Thích Với Autocad Đời

Chào các bác!
Em có tải 1 lisp đo khoảng cách của line,pline... sau đó xuất ra text từ diễn đàn mình, nhưng nó chỉ chạy được trên autocad 2007 nên em muốn nhờ mọi người giúp sửa lại để có thể chạy được trên các phiên bản autocad đời cao hơn.
Em xin cảm ơn!

Chào các bác!
Em có tải 1 lisp đo khoảng cách của line,pline... sau đó xuất ra text từ diễn đàn mình, nhưng nó chỉ chạy được trên autocad 2007 nên em muốn nhờ mọi người giúp sửa lại để có thể chạy được trên các phiên bản autocad đời cao hơn.
Em xin cảm ơn!
http://www.cadviet.com/upfiles/6/122465_ghi_chu_chieu_dai_lineplinegc.lsp

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/9681-lisp-ghi-chieu-dai-doan-thang-theo-scale-factor-cua-dimstyle-hien-thoi/
(defun Length1(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
;;;--------------------------------------------------------------------
(defun C:GC( / ss L e)
(setq
ss (ssget (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))
L 0.0
k (getvar "dimlfac")
)

(vl-load-com)
(while (setq e (ssname ss 0))
(setq L (* k (length1 e)))
(setq ans (getstring "\n Ban hay chon phuong an nhap ket qua "))
(if (= ans "1")
(progn
(setq te (entget(car(entsel "\n Chon Text de gan ket qua :")))
te (subst (cons 1 (rtos L 2 2)) (assoc 1 te) te))
(entmod te)
)
(progn
(setq p (getpoint "\n Chon diem nhap ket qua" ))
(setq h (getreal "\n Nhap chieu cao text ket qua "))
(command "text" p h "0" (strcat "D-L" (rtos L 2 1) " "))
)
)
(ssdel e ss)
)
(princ)
)
;;;--------------------------------------------------------------------

<<

Filename: 404244_gc.lsp

Trang 207/303

207