Jump to content
InfoFile
Tác giả: Doan Nguyen Van
Bài viết gốc: 437890
Tên lệnh: num
Nhờ sửa lisp

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

  (defun...
>>

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

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

Sửa luôn trong file giúp bạn.


<<

Filename: 437890_num.lsp
Tác giả: duongthanh85
Bài viết gốc: 66401
Tên lệnh: tdd
Rắc rối lấy nội dung text từ đối tượng text được chọn bởi chuột

Em có nhờ giúp làm 1 lisp như trong bài này

 

Các huynh cho đệ 1 lisp như sau:

- Tạo 1 file text tên là C:\Ketqua.txt nếu chưa có; ghi ở chế độ ghi thêm (thêm dòng...

>>

Em có nhờ giúp làm 1 lisp như trong bài này

 

Các huynh cho đệ 1 lisp như sau:

- Tạo 1 file text tên là C:\Ketqua.txt nếu chưa có; ghi ở chế độ ghi thêm (thêm dòng vào nội dung có sẵn).

- Chọn đối tượng text thứ nhất, ghi giá trị text này vào file C:\Ketqua.txt và thêm dấu TAB (chưa xuống dòng).

- Chọn đối tượng text thứ 2, ghi giá trị text thứ 2 này vào cùng dòng với giá trị text thứ nhất và thêm dấu TAB.

- Chọn 1 loạt đối tượng là Line, Pline... ghi tổng giá trị chiều dài và xuống dòng (gọi hàm tính tổng chiều dài các đường- Lisp trên cadviet).

 

Mỗi lần thực hiện lệnh lại ghi thêm 1 dòng.

 

VD:

có 02 đối tượng text là "Diem 1" và "Diem 2", giữa 2 đối tượng text này có vài đường thẳng.

Khi gõ lệnh như trên sẽ ghi thêm vào file text 1 dòng như sau:

Diem 1 Diem 2 128.5

 

Mong các huynh giúp đỡ, đệ đã đọc thử bài liên kết Acad và Txt cũng như mã nguồn lisp tính tổng các đối tượng được chọn rồi như vẫn không làm được.

 

Sau đó em làm được open/write vào file nhưng lỗi text. Bây giờ sau khi google về các hàm string em đã làm ra thành quả. Tuy nhiên kết quả chưa đúng mong muốn lắm:

Thay vì ghi thông số theo định dạng:

Điểm đầu (Tab) điểm thứ 2 (tab) chiều dài tổng

 

Thì em đang ghi kiểu:

Điểm đầu

Điểm thứ 2

Chiều dài tổng

------

 

Trong đó "------" là ký tự em dùng tạm để phân biệt các lần lấy dữ liệu. Em đã cố gắng join các thông số vào chung bằng hàm STRCAT nhưng toàn lỗi. Nay em đưa lisp lên mong các huynh giúp đỡ để ghi kết quả vào file đúng định dạng mong muốn (mỗi lần thực hiện chỉ ghi thêm 1 dòng vào file text).

(trong lisp này em có sử dụng lisp tính tổng chiều dài của CadViet và đổi tên hàm để đỡ trùng khi sử dụng, dù hàm này em không định nghĩa C:

xin chân thành cảm ơn tác giả Lisp tính tổng chiều dài).

 

 

(Defun C:tdd (/ fname txt selset count nme oldtx)
 (setq fname (getstring "\nGhi ten file luu ket qua: "))
 (setq txt (open fname "a"))		;open file, assign symbol
 (setq selset (ssget))					;get selection set
 (setq count 0)						;set count to zero
 (if (/= selset nil)
	 (while (< count (sslength selset));while count < # of lines
			(setq nme (ssname selset count));extract text string
			(setq oldtx (cdr (assoc 1 (entget nme))))
			(write-line oldtx txt)		;write string to file
			(setq count (1+ count))	;go to next line
	 );end while
(close txt)								;close file
);end C:tdd


;; ----------------Lisp tong chieu cadviet--------------------------

(defun add_mline ()
(foreach e_record_sub e_record
(cond ((= 10 (car e_record_sub))
(setq pt1 (cdr e_record_sub)
mline_len 0.0
)
)
((= 11 (car e_record_sub))
(setq pt2 (cdr e_record_sub)
mline_len (+ mline_len (distance pt2 pt1))
pt1 pt2
)
)
)
)
(setq tot_len (+ tot_len mline_len))
(ssdel e_name ss)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun tgt (/ tot_len ss e_name e_record e_type)
(princ "\nCADViet.com (c) 2007")
(setq tot_len 0.0)
(setq ss (ssget))
(if (null ss)
(exit)
)
(while (> (sslength ss) 0)
(setq e_name (ssname ss 0))
(setq e_record (entget e_name))
(setq e_type (cdr (assoc '0 e_record)))
(cond ((wcmatch e_type "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")
(command "lengthen" e_name "")
(setq tot_len (+ tot_len (getvar "PERIMETER")))
(ssdel e_name ss)
)
((wcmatch e_type "MLINE") (add_mline))
(e_type (ssdel e_name ss))
)
)
(prompt (strcat "\nTotal length is: " (rtos tot_len 2 2)))
(write-line (rtos tot_len 2 2) txt)
(princ)
)
(princ)


<<

Filename: 66401_tdd.lsp
Tác giả: q288
Bài viết gốc: 66408
Tên lệnh: tdd
Rắc rối lấy nội dung text từ đối tượng text được chọn bởi chuột

Em có nhờ giúp làm 1 lisp như trong bài này

Sau đó em làm được open/write vào file nhưng...

>>
Em có nhờ giúp làm 1 lisp như trong bài này

Sau đó em làm được open/write vào file nhưng lỗi text. Bây giờ sau khi google về các hàm string em đã làm ra thành quả. Tuy nhiên kết quả chưa đúng mong muốn lắm:

Thay vì ghi thông số theo định dạng:

Thì em đang ghi kiểu:

Trong đó "------" là ký tự em dùng tạm để phân biệt các lần lấy dữ liệu. Em đã cố gắng join các thông số vào chung bằng hàm STRCAT nhưng toàn lỗi. Nay em đưa lisp lên mong các huynh giúp đỡ để ghi kết quả vào file đúng định dạng mong muốn (mỗi lần thực hiện chỉ ghi thêm 1 dòng vào file text).

(trong lisp này em có sử dụng lisp tính tổng chiều dài của CadViet và đổi tên hàm để đỡ trùng khi sử dụng, dù hàm này em không định nghĩa C:

xin chân thành cảm ơn tác giả Lisp tính tổng chiều dài).

(Defun C:tdd (/ fname txt selset count nme oldtx)
 (setq fname (getstring "\nGhi ten file luu ket qua: "))
 (setq txt (open fname "a"))			;open file, assign symbol
 (setq selset (ssget))						;get selection set
 (setq count 0)							;set count to zero
 (if (/= selset nil)
	 (while (< count (sslength selset))	;while count < # of lines
			(setq nme (ssname selset count));extract text string
			(setq oldtx (cdr (assoc 1 (entget nme))))
			(write-line oldtx txt)			;write string to file
			(setq count (1+ count))		;go to next line
	 );end while
 );end if
 (tgt)
 (write-line "---" txt)
(close txt)									;close file
);end C:tdd
;; ----------------Lisp tong chieu cadviet--------------------------

(defun add_mline ()
(foreach e_record_sub e_record
(cond ((= 10 (car e_record_sub))
(setq pt1 (cdr e_record_sub)
mline_len 0.0
)
)
((= 11 (car e_record_sub))
(setq pt2 (cdr e_record_sub)
mline_len (+ mline_len (distance pt2 pt1))
pt1 pt2
)
)
)
)
(setq tot_len (+ tot_len mline_len))
(ssdel e_name ss)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun tgt (/ tot_len ss e_name e_record e_type)
(princ "\nCADViet.com © 2007")
(setq tot_len 0.0)
(setq ss (ssget))
(if (null ss)
(exit)
)
(while (> (sslength ss) 0)
(setq e_name (ssname ss 0))
(setq e_record (entget e_name))
(setq e_type (cdr (assoc '0 e_record)))
(cond ((wcmatch e_type "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")
(command "lengthen" e_name "")
(setq tot_len (+ tot_len (getvar "PERIMETER")))
(ssdel e_name ss)
)
((wcmatch e_type "MLINE") (add_mline))
(e_type (ssdel e_name ss))
)
)
(prompt (strcat "\nTotal length is: " (rtos tot_len 2 2)))
(write-line (rtos tot_len 2 2) txt)
(princ)
)
(princ)

 

Bạn thay dòng (write-line oldtx txt) trong lệnh c:tdd

bằng dòng (princ (strcat oldtx "\t") txt) là xong .


<<

Filename: 66408_tdd.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 438071
Tên lệnh: te
Nối các đường line bị hở
12 phút trước, AUTOCAD_2019 đã nói:

em thấy lisp trong clip cũng...

>>
12 phút trước, AUTOCAD_2019 đã nói:

em thấy lisp trong clip cũng ổn đó anh còn những line lỗi em cũng có thể sửa tay được, đa số file không bị chồng chỉ một vài file bị thôi anh

(vl-load-com)
(defun c:te (/ ss d ptp pt1 pt2 lst p1 p2 lst2)
(setq ss (acet-ss-to-list (ssget (list (cons 0 "LWPOLYLINE")))))
  (setq d (getdist "nhap khoang cach noi"))
  (command "UNDO" "BE")
  (setq lst (list))
  (foreach ent ss
    (setq lstp (acet-geom-vertex-list ent))
    (setq p1 (car lstp)
	  p2 (last lstp))
    (setq lst (append lst (list p1 p2)))
    )
  (while (and (setq pt (car lst))
    (setq lst2 (cdr lst)))
    (setq lst (vl-remove pt lst))
    (mapcar '(lambda (pt2) (setq dis (distance pt pt2))
	       (if (< dis d) (progn (setq lst (vl-remove pt2 lst))
			       (command "PLINE" "_non" pt "_NON" pt2 "")))) lst2)
    )
  (command "UNDO" "E")
  
  )

Đầu tiên Overkill, sau đó pedit line thành polyline rồi join lại, cuối cùng mới dùng đến lisp nhé bạn.

Chắc cũng k đúng ý bạn đâu


<<

Filename: 438071_te.lsp
Tác giả: phuongtran613
Bài viết gốc: 204762
Tên lệnh: ddt
Nhờ giúp Lisp tính diện tích và lập bảng

Hề hề hề,

Mình giúp bạn lần này đưa vấn đề bạn hỏi về cùng topic gốc. Lần sau bạn nên rút kinh nghiệm để diễ...

>>

Hề hề hề,

Mình giúp bạn lần này đưa vấn đề bạn hỏi về cùng topic gốc. Lần sau bạn nên rút kinh nghiệm để diễ đàn đỡ rối rắm.

Bạn dùng thử cái này xem đã ưng ý chưa nhé.


(defun c:ddt(/ lacol ladin laos tl h tl1 cao1 k tdt ss pt p1 p2 p3 p4 p5 p6 p7 p8
                       pa pt1 pt2 e ep p9 p10 p11 p12 p13 et dtcon )
 (setvar "cmdecho" 0)
 (setq lacol (getvar "CEColor"))
 (setq ladin (getvar "dimzin"))
 (setq laos (getvar "osmode"))  
 (if (not tl) (setq tl 1))
 (if (not h) (setq h 1))
 (setq tl1 (getreal (strcat "\nty le ban ve < 1/" (rtos tl 2 0) " >: 1/"))
caot1 (getreal (strcat "\nCao text < " (rtos h 2 0) " >: ")))
 (if tl1 (setq tl tl1))
 (if caot1 (setq h caot1))
 (command "undo" "be")
 (setq  k 0
tdt 0)
 (setq ss (ssadd))

(setvar "dimzin" 0)
(setvar "OSMODE" 0)
(setq PT (getpoint "\nChon diem xuat bang thong ke dien tich (mep trai):"))
(setq  P1 (list (+ (car PT)(* 6 h)) (cadr PT))
P2 (list (+ (car PT)(* 22 h)) (cadr PT))
P3 (list (car PT) (- (cadr PT)(* 3 h)))
P4 (list (car P1) (cadr P3))
P5 (list (car P2) (cadr P3))
P6 (list (+ (car PT)(* 11 h)) (+ (cadr PT)(* 2 h)))
P7 (list (+ (car PT)(* 3 h)) (- (cadr PT)(* 1.5 h)))
P8 (list (+ (car PT)(* 14 h)) (- (cadr PT)(* 1.5 h)))
);setq
(command  "pline" PT P2 P5 P3 "C"
"pline" P1 P4 ""
"text" "m" P6 (* 1.2 h) 0 "Bang thong ke dien tich"
"text" "m" P7 h 0 "STT"
"text" "m" P8 h 0 "Dien tich (mm2)"
);command
(setq PA  (getstring "\n Ban chon phuong an chon doi tuong < 1 or 2 > : "))
(if (= pa "1")
   (setq pt1 (getpoint "\n Chon mien tinh dien tich : "))
   (setq ep (car (setq e (entsel "\n Chon doi tuong la polyline kin")))
             pt2 (cadr e)  )
)
 (while (or (/= pt1 nil) (/= ep nil) )
(setq k (+ 1 k))
                 (if pt1
(command "TEXT" "m" pt1 (* 1 h) 0 (rtos k 2 0))
                 )
                 (if ep
                 (command "TEXT" "m" pt2 (* 1 h) 0 (rtos k 2 0))
                 )
(setq  PT (list (car P3) (cadr P3))
P1 (list (+ (car PT)(* 6 h)) (cadr PT))
P2 (list (+ (car PT)(* 22 h)) (cadr PT))
P3 (list (car PT) (- (cadr PT)(* 3 h)))
P4 (list (car P1) (cadr P3))
P5 (list (car P2) (cadr P3))
P7 (list (+ (car PT)(* 3 h)) (- (cadr PT)(* 1.5 h)))
P8 (list (+ (car PT)(* 14 h)) (- (cadr PT)(* 1.5 h)))
P9 (list (car PT) (- (cadr P3)(* 3 h)))
P10 (list (car P1) (cadr P9))
P11 (list (car P2) (cadr P9))
P12 (list (car P7) (- (cadr P3)(* 1.5 h)))
P13 (list (car P8) (cadr P12))
);setq
                 (if  pt1
                     (progn
       (command "CECOLOR" 4 "-boundary" pt1 "" )
       (setvar "CECOLOR" lacol)
       (setq et (entlast))
       (ssadd et ss)
       (command "area" "e" "last")
                     )
                 )
                 (if ep
                     (command "area" "o" ep)
                 )
;;;;;;(setq et (entlast))
;;;;;;(ssadd et ss)
(setq dtcon (* (getvar "AREA") tl tl))
(setq tdt (+ dtcon tdt))
(command "erase" ss "")

(command "pline" PT P2 P5 P3 "C"
"pline" P1 P4 ""
"text" "m" P7 h 0 (rtos k 2 0)
"text" "m" P8 h 0 (rtos dtcon 2 2))
                 (if pt1
	(setq pt1 (getpoint "\n chon mien tinh dien tich tiep theo hoac enter de ket thuc lenh..."))
                 )
                 (if ep
                     (setq ep (car (setq e (entsel "\n Chon polyline tiep theo hoạc enter de ket thuc lenh ..."))) pt2 (cadr e)  )
                 )
);while
(setq ss nil)
(setvar "DIMZIN" ladin)
(command  "pline" P3 P9 P11 P5 "C"
"pline" P10 P4 ""
"text" "m" P12 h 0 "Tong"
"text" "m" P13 h 0 (rtos tdt 2 2)
);command
(command "undo" "e")
(setvar "OSMODE" laos)
(setvar "cmdecho" 1)
(princ)
)

Chúc bạn vui......

 

cám ơn bác Phạm Thanh Bình nhiều lắm, líp sử dụng rất tốt


<<

Filename: 204762_ddt.lsp
Tác giả: Tue_NV
Bài viết gốc: 89969
Tên lệnh: chonthuc
Chọn text là số
Các lisp trên có nhược điểm là sau khi chọn text rồi mới kiểm tra xem text đó là số hay không. Lisp dưới đây chỉ chọn text số luôn mà không cần mã lệnh kiểm...
>>
Các lisp trên có nhược điểm là sau khi chọn text rồi mới kiểm tra xem text đó là số hay không. Lisp dưới đây chỉ chọn text số luôn mà không cần mã lệnh kiểm tra.

 

Lisp chọn số thực:

(defun c:chonthuc()
 (setq ss (ssget '((0 . "TEXT") (1 . "~*,`.*~`.*"))))
)

 

Lisp chọn số nguyên:

(defun c:chonnguyen()
 (setq ss (ssget '((0 . "TEXT") (1 . "~**"))))
)

Chào bác Hoành

Lisp chọn số nguyên chạy OK.

 

Lisp chọn số thực có vấn đề

-> chọn số thực, chọn số nguyên và cả string nữa :D


<<

Filename: 89969_chonthuc.lsp
Tác giả: tien2005
Bài viết gốc: 438170
Tên lệnh: sco
Lisp scale 2 đối tượng cùng lúc

@AUTOCAD_2019Bạn dùng lisp sau, lệnh là SCO

(vl-load-com)
(defun LM:ssboundingbox ( s / a b i m n o )
    (repeat (setq i (sslength s))
        (if
            (and
                (setq o...
>>

@AUTOCAD_2019Bạn dùng lisp sau, lệnh là SCO

(vl-load-com)
(defun LM:ssboundingbox ( s / a b i m n o )
    (repeat (setq i (sslength s))
        (if
            (and
                (setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
                (vlax-method-applicable-p o 'getboundingbox)
                (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))))
            )
            (setq m (cons (vlax-safearray->list a) m)
                  n (cons (vlax-safearray->list b) n)
            )
        )
    )
    (if (and m n)
        (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list m n))
    )
)

(defun c:sco (/ sc ss lsp mip); scale object
  (initget (+ 1 2 4))
  (setq sc (getreal "\nHe so scale: "))
  (while (setq ss (ssget '((0 . "*TEXT"))))
    (setq lsp (LM:ssboundingbox ss))
    (setq mip (mapcar '(lambda (x y) (* (+ x y) 0.5)) (car lsp)(cadr lsp)))
    (command "_.scale" ss "" mip sc)
    )
  (princ)
  )

 


<<

Filename: 438170_sco.lsp
Tác giả: tien2005
Bài viết gốc: 438235
Tên lệnh: wb
Lisp tách nhiều block thành bản vẽ khác nhau

@Cad member Bạn dùng lisp sau:

Lệnh là WB, chọn thư mục muốn ghi file, nếu không thì lisp lấy thư mục của bản vẽ

FIle được ghi ra nếu trùng tên thì tự động thêm số phía sau

>>

@Cad member Bạn dùng lisp sau:

Lệnh là WB, chọn thư mục muốn ghi file, nếu không thì lisp lấy thư mục của bản vẽ

FIle được ghi ra nếu trùng tên thì tự động thêm số phía sau

(vl-load-com)
(defun LM:effectivename (obj)
    (vlax-get-property
      obj
      (if (vlax-property-available-p obj 'effectivename)
	'effectivename
	'name
      )
    )
  )
(defun DirectoryDialog ( msg dir flag / Shell Fold Self Path )
    (vl-catch-all-apply
      (function
        (lambda ( / ac HWND )
          (if
            (setq Shell (vla-getInterfaceObject (setq ac (vlax-get-acad-object)) "Shell.Application")
                  HWND  (vl-catch-all-apply 'vla-get-HWND (list ac))
                  Fold  (vlax-invoke-method Shell 'BrowseForFolder (if (vl-catch-all-error-p HWND) 0 HWND) msg flag dir)
            )
            (setq Self (vlax-get-property Fold 'Self)
                  Path (vlax-get-property Self 'Path)
                  Path (vl-string-right-trim "\\" (vl-string-translate "/" "\\" Path))
            )
          )
        )
      )
    )
    (if Self  (vlax-release-object  Self))
    (if Fold  (vlax-release-object  Fold))
    (if Shell (vlax-release-object Shell))
    Path
  )
(defun LM:Unique ( l )
    (if l (cons (car l) (LM:Unique (vl-remove (car l) (cdr l)))))
    )

(DEFUN C:WB (/ fol ss lswb wn)
  (setvar "cmdecho" 0)
  (if (setq FOL (DirectoryDialog "Select Directory" nil(+ 1 64 256)))
    (setq FOL (strcat fol "\\"))
    (setq fol (getvar "DWGPREFIX"))
    )
  (WHILE (setq ss (ssget '((0 . "INSERT"))))
    (setq lswb (LM:Unique(mapcar '(lambda (x) (LM:effectivename (vlax-ename->vla-object x)))(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))))
    (foreach wn lswb
      (if (equal (open (strcat fol  wn ".DWG") "r") nil)
            (command "wblock" (strcat fol  wn) wn)
	(progn
	  (setq n 0
		chk t
		)
	  (while  chk
	    (if (equal (open (strcat fol  wn (rtos (setq n (1+ n)) 2 0)".DWG") "r") nil)
		(setq chk nil)
	      )
	    )
	  (command "wblock" (strcat fol  wn (rtos n 2 0)) wn)
	  )
	)
      
      )
    )
  (PRINC)
  )

 


<<

Filename: 438235_wb.lsp
Tác giả: nhoclangbat
Bài viết gốc: 438295
Tên lệnh: scc
Lisp scale 2 đối tượng cùng lúc

chắc bạn muốn đỗ file vào phần mềm xuất bảng biểu, theo mình cái này nên xử lý trước ở phần tạo nhãn bên micro, làm nhãn nhỏ thui để chạy, 1 file nhãn lớn để trình bày, mình mẹo 1 tý dựa trên lisp bạn trên, tuy nhiên chắc không triệt để đc vì khi text nó lớn hơi khó kiểm soát chưa kể nhãn nằm ngoài vùng thửa

(defun...
>>

chắc bạn muốn đỗ file vào phần mềm xuất bảng biểu, theo mình cái này nên xử lý trước ở phần tạo nhãn bên micro, làm nhãn nhỏ thui để chạy, 1 file nhãn lớn để trình bày, mình mẹo 1 tý dựa trên lisp bạn trên, tuy nhiên chắc không triệt để đc vì khi text nó lớn hơi khó kiểm soát chưa kể nhãn nằm ngoài vùng thửa

(defun c:scc (/ ss_30 ds_30 ss_text tam ds-33 ds_30  ss_33 mid1 ip2 ip3 ip4 ip1) 
(setvar 'cmdecho 0)	
;---------------------------------------------
(setq ss_33 (ssget '((0 . "*text") (8 . "Level 33"))))
(if ss_33
	(progn	
		(setq ds-33 (ss2ent ss_33))
		(foreach k ds-33
			(setq s1 (ssadd k))
			(setq mid1 (mapcar '(lambda (x y) (* (+ x y) 0.5)) (car (LM:ssboundingbox s1))(cadr (LM:ssboundingbox s1))))
			(setq ip1 (mapcar '+ mid1 '(-10 3.5 0)) ip4 (mapcar '+ mid1 '(10 3.5 0)))
			(setq ip2 (mapcar '+ mid1 '(10 -35 0)))
			(setq ip3 (mapcar '+ mid1 '(-10 -35 0)))
			(setq ss_text (ssget "_CP" (list  ip1 ip4 ip2 ip3) '((0 . "*text"))))
			(vl-cmdf "_.scale" ss_text "" mid1 0.1)
			(setq s1 nil)
		)
	)
)
(princ)
)
(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 LM:ssboundingbox ( sel / idx llp ls1 ls2 obj urp )
    (repeat (setq idx (sslength sel))
        (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))))
        (if (and (vlax-method-applicable-p obj 'getboundingbox)
                 (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp))))
            )
            (setq ls1 (mapcar 'min (vlax-safearray->list llp) (cond (ls1) ((vlax-safearray->list llp))))
                  ls2 (mapcar 'max (vlax-safearray->list urp) (cond (ls2) ((vlax-safearray->list urp))))
            )
        )
    )
    (if (and ls1 ls2) (list ls1 ls2))
)

 


<<

Filename: 438295_scc.lsp
Tác giả: huunhantvxdts
Bài viết gốc: 361368
Tên lệnh: dopl
Lisp dim khoảng cách liên tiếp trên Polyline - Pline

 

Mình cũng nghĩ hướng ghi dim cũng tuỳ thuộc váo ý chủ quan của người dùng nữa nên đã viết thêm vào Lisp

Nếu dim ghi...

>>

 

Mình cũng nghĩ hướng ghi dim cũng tuỳ thuộc váo ý chủ quan của người dùng nữa nên đã viết thêm vào Lisp

Nếu dim ghi không phù hợp thì sau khi ghi dim ra thì lsp hỏi có muốn đặt dim theo hướng ngược lại <Y/N>?

Nếu gõ Y thì Lsp sẽ tự đảo chiều ghi dim, còn nếu nhấn N hoặc enter thì lsp giữ nguyên chiều ghi dim đó

- Bổ sung thêm lsp ghi dim bán kính

(defun c:dopl(/ ghidim acadObj doc modelSpace e ddat)
(defun ghidim(e ddat i / dis lst-dim)
       (setq obj (vlax-ename->vla-object e))
       (setq dis (distance ddat (vlax-curve-getclosestpointto e ddat t)))
     (Repeat (fix (vlax-curve-getEndParam e))
       (if (= 0 (vla-GetBulge obj i))
      (vla-AddDimAligned modelSpace
                    (vlax-3d-point (vlax-curve-getpointatparam e i)) (vlax-3d-point (vlax-curve-getpointatparam e (1+ i)) )
                    (vlax-3d-point (polar (vlax-curve-getpointatparam e (+ i 0.5))
                           (- (angle '(0 0 0) (vlax-curve-getFirstDeriv e (+ i 0.5))) (/ pi 2.0)) dis)
                    )
      )
(progn
 (vla-adddimradial modelSpace (vlax-3d-point (mapcar '+ (vlax-curve-getpointatparam e (+ i 0.5)) (vlax-curve-getSecondDeriv e (+ i 0.5)))) 
  (vlax-3d-point (vlax-curve-getpointatparam e (+ i 0.5))) 0.0
 ) (setq lst-dim (append lst-dim (list (entlast))))
          (vla-AddDimArc modelSpace (vlax-3d-point (mapcar '+ (vlax-curve-getpointatparam e (+ i 0.5)) (vlax-curve-getSecondDeriv e (+ i 0.5))))
                    (vlax-3d-point (vlax-curve-getpointatparam e i)) (vlax-3d-point (vlax-curve-getpointatparam e (1+ i)) )
                    (vlax-3d-point (polar (vlax-curve-getpointatparam e (+ i 0.5))
                           (- (angle '(0 0 0) (vlax-curve-getFirstDeriv e (+ i 0.5))) (/ pi 2.0)) dis)
                    )
          )
)
        );if
(setq lst-dim (append lst-dim (list (entlast))))
    (setq i (1+ i))
    );Repeat
lst-dim
)
    (setq acadObj (vlax-get-acad-object))
    (setq doc (vla-get-ActiveDocument acadObj))
 
    (setq modelSpace (vla-get-ModelSpace doc))
  (if (and (setq e (car(entsel "\n Chon Pline : "))) (setq ddat (getpoint (vlax-curve-getstartpoint e) "\nDist (Pick diem) :")))
     (progn
(setq lst-dim (ghidim e ddat 0))
(initget "Y N")
(if (= "Y" (getkword "\nBan muon ghi dim theo huong nguoc lai <Y/N>")) (progn
   (mapcar 'entdel lst-dim) (command "._pedit" e "R" "") (ghidim e ddat 0)
))
  );progn
 );if
(princ)
)

Lỗi Bác Tue_NV ơi

Bấm N thì ok

Bấm Y lỗi không thấy Dim xuất hiện (Thấy PL được highlight)

lỗi như sau:

Ban muon ghi dim theo huong nguoc lai <Y/N>y
 
Invalid option keyword.
; error: Function cancelled
 
Enter an option : Osmode Reseted!

<<

Filename: 361368_dopl.lsp
Tác giả: nhoclangbat
Bài viết gốc: 438370
Tên lệnh: ha
Về vấn đề lisp chọn đối tượng theo màu

lâu rùi ko vọc vạch lsp, bạn xem thử ^^

(defun c:ha ( / lst1 lst2 clr cly)
(setq ent (car (entsel "\nDoi tuong mau :")))
(if ent
	(progn
		(setq clr (cdr (assoc 62 (entget ent))))
		(setq cly (cdr (assoc 8 (entget ent))))
		(if clr
			(progn
				(setq lst1 (acet-ss-to-list (ssget "x" (list (cons 62 clr)))))
				(setq lst2 (ssadd))
				(foreach name lst1 (ssadd name lst2))
				(sssetfirst nil...
>>

lâu rùi ko vọc vạch lsp, bạn xem thử ^^

(defun c:ha ( / lst1 lst2 clr cly)
(setq ent (car (entsel "\nDoi tuong mau :")))
(if ent
	(progn
		(setq clr (cdr (assoc 62 (entget ent))))
		(setq cly (cdr (assoc 8 (entget ent))))
		(if clr
			(progn
				(setq lst1 (acet-ss-to-list (ssget "x" (list (cons 62 clr)))))
				(setq lst2 (ssadd))
				(foreach name lst1 (ssadd name lst2))
				(sssetfirst nil lst2)
			)
			(progn	
				(setq lst1 (acet-ss-to-list (ssget "x" (list (cons 8 cly)))))
				(setq lst2 (ssadd))
				(foreach name lst1 (ssadd name lst2))
				(sssetfirst nil lst2)
			)
		)
	)
)	
(princ)
			
)
  
 

 


<<

Filename: 438370_ha.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 438397
Tên lệnh: ha
Lisp Lọc Text Dạng Số Ra Khỏi Chuỗi Text

Xử!


(defun C:HA(/ ss x so ed)
 (princ "\nChon cac Text...")
 (setq ss (ssget '((0 . "text"))) x 0)
 (repeat (sslength ss)
  (setq so (itoa (last (read (strcat "(" (cdr (assoc 1 (setq ed (entget (ssname ss x))))) ")")))))
  (entmod (subst (cons 1 so) (assoc 1 ed) ed))
  (setq x (1+ x)))
 (princ))


Filename: 438397_ha.lsp
Tác giả: Biet ve CAD
Bài viết gốc: 438423
Tên lệnh: bvc
Lisp Lọc Text Dạng Số Ra Khỏi Chuỗi Text
10 phút trước, google123 đã nói:

bản vẽ đây anh, quét chọn...

>>
10 phút trước, google123 đã nói:

bản vẽ đây anh, quét chọn vùng lớn không chạy lisp được ạ

file cad.dwg

Có mấy dòng, thấy bạn cũng cầu thị nên giúp bạn, bạn thử xem có được ko nhé

(defun C:BVC(/ e ss str)
 (foreach e (acet-ss-to-list (ssget '((0 . "text"))))
   (setq str (cdr (assoc 1 (entget e))))
   (if(vl-string-search "T\\" str)
     (vla-put-textstring (vlax-ename->vla-object e) (substr str (+ (vl-string-position 32 str nil t) 1)))
     )
   )
  )

 


<<

Filename: 438423_bvc.lsp
Tác giả: ngokiet
Bài viết gốc: 438421
Tên lệnh: ha
Về vấn đề lisp chọn đối tượng theo màu

Hình như hơi đi xa quá.

(defun c:ha(/ en)  (sssetfirst nil (ssget (list (cond ((assoc 420 (setq en (entget(car(entsel)))))) ((assoc 62 en)) ((cons 62 256)))))))

 


Filename: 438421_ha.lsp
Tác giả: nhoclangbat
Bài viết gốc: 438411
Tên lệnh: ha
Về vấn đề lisp chọn đối tượng theo màu

-ý chọn theo bylayer của bạn nó hơi rộng mình hiểu vậy, bạn nên đặt trường hợp hay ví dụ củ thể để dễ hình dung, theo ý của anh Mod trình bày mình hiểu nôm na là dựa trên màu của đối tượng đc chọn  làm mẫu đầu tiên không cần biết có đúng màu chính chủ không, sau đó quét vùng đối tượng rồi lọc ra highlight các đối tượng có màu giống đối tượng mẫu, bạn chạy thử, lâu...

>>

-ý chọn theo bylayer của bạn nó hơi rộng mình hiểu vậy, bạn nên đặt trường hợp hay ví dụ củ thể để dễ hình dung, theo ý của anh Mod trình bày mình hiểu nôm na là dựa trên màu của đối tượng đc chọn  làm mẫu đầu tiên không cần biết có đúng màu chính chủ không, sau đó quét vùng đối tượng rồi lọc ra highlight các đối tượng có màu giống đối tượng mẫu, bạn chạy thử, lâu rùi ko viết code nên  biến đặt nó hơi lung tung ^^

(defun c:ha ( / lst1 lst2 clr cly ss2 ds_ent ds_ent2 ds_ent3 mau mau2 mau_lay_goc ds_ent2_1 ds_ent5 ds_ent4)
(setq ent (car (entsel "\nDoi tuong mau :")))
(if ent
	(progn
		(setq clr (cdr (assoc 62 (entget ent))))
		(setq cly (cdr (assoc 8 (entget ent))))
		(if clr
			(progn
				(setq lst1 (acet-ss-to-list (ssget "x" (list (cons 62 clr)))))
				(setq lst2 (ssadd))
				(foreach name lst1 (ssadd name lst2))
				(sssetfirst nil lst2)
			)
			(progn
				(setq mau_lay_goc (vla-get-color (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) cly)))
			;----------------------------------------------------------------------------------------------------------------------
				(prompt "chon vung: ")
				(setq ss2 (ssget))
				(if ss2 
						(progn
							(setq ds_ent (ss2ent ss2)) 
							;(setq ds_lay_chon (mapcar '(lambda (x) (cdr (assoc 8 (entget x)))) ds_ent))
							(foreach k ds_ent
								(setq mau (cdr (assoc 62 (entget k ))))
								(if (= mau nil) (setq ds_ent2 (append (list k) ds_ent2))   (setq ds_ent2_1 (append (list k) ds_ent2_1))  ) 
							)
							;--------------------
							(foreach k ds_ent2 
								(setq mau2 (vla-get-color (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) (cdr (assoc 8 (entget k )))  )))
								(if (= mau2  mau_lay_goc) (setq ds_ent3 (append (list k) ds_ent3)))
							)
							;---------------------------------------------------------------
							(foreach k ds_ent2_1 (setq mau4 (cdr (assoc 62 (entget k ))))
								(if (= mau4 mau_lay_goc) (setq ds_ent4 (append (list k) ds_ent4)))
							)
							;----------------------------------------------------------
							(setq ds_ent5 (append ds_ent3 ds_ent4))	
							;------------------------------------------------------------
							(setq lst2 (ssadd))
							(foreach name ds_ent5 (ssadd name lst2))
							(sssetfirst nil lst2)
						)
				)			
			);end progn clr
		); end if clr
	);end progn ent
)	
(princ)
			
)
(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)
;===============

-bạn copy them code phần dưới vô code trên mình copy thiếu ^^


<<

Filename: 438411_ha.lsp
Tác giả: nhoclangbat
Bài viết gốc: 438442
Tên lệnh: ha ha2
Về vấn đề lisp chọn đối tượng theo màu

-theo cách hiểu dân dã của mình thì 3 trường của bạn có thể gôm làm 1, chủ yếu thằng mẫu đầu tiên nó mang màu đang hiển thị là gì thì vùng chọn sẽ lọc tất cả đối tượng có màu đó ko quan tâm bylayer hay tùy chọn chỉ cần màu nó đang hiển thị giống màu mẫu ban đầu chọn ^^, code thử vội đi ngoại nghiệp

(defun c:ha...
>>

-theo cách hiểu dân dã của mình thì 3 trường của bạn có thể gôm làm 1, chủ yếu thằng mẫu đầu tiên nó mang màu đang hiển thị là gì thì vùng chọn sẽ lọc tất cả đối tượng có màu đó ko quan tâm bylayer hay tùy chọn chỉ cần màu nó đang hiển thị giống màu mẫu ban đầu chọn ^^, code thử vội đi ngoại nghiệp

(defun c:ha ( / lst1 lst2 clr cly ss2 ds_ent ds_ent2 ds_ent3 mau mau2 mau_lay_goc ds_ent2_1 ds_ent5 ds_ent4)
(setq ds_layer (K:dsbg "layer"))
(setq ent (car (entsel "\nDoi tuong mau :")))
(if ent
	(progn
		(setq clr (cdr (assoc 62 (entget ent))))
		(setq cly (cdr (assoc 8 (entget ent))))
		(if clr
			(progn
			    (prompt "chon vung: ")
				(setq lst1 (acet-ss-to-list (ssget "x" (list (cons 62 clr)))))
				(setq lst2 (ssadd))
				(foreach name lst1 (ssadd name lst2))
				(sssetfirst nil lst2)
			)
			(progn
				(setq mau_lay_goc (vla-get-color (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) cly)))
			;----------------------------------------------------------------------------------------------------------------------
				(prompt "chon vung: ")
				(setq ss2 (ssget))
				(if ss2 
						(progn
							(setq ds_ent (ss2ent ss2)) 
							;(setq ds_lay_chon (mapcar '(lambda (x) (cdr (assoc 8 (entget x)))) ds_ent))
							(foreach k ds_ent
								(setq mau (cdr (assoc 62 (entget k ))))
								(if (= mau nil) (setq ds_ent2 (append (list k) ds_ent2))   (setq ds_ent2_1 (append (list k) ds_ent2_1))  ) 
							)
							;--------------------
							(foreach k ds_ent2 
								(setq mau2 (vla-get-color (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) (cdr (assoc 8 (entget k )))  )))
								(if (= mau2  mau_lay_goc) (setq ds_ent3 (append (list k) ds_ent3)))
							)
							;---------------------------------------------------------------
							(foreach k ds_ent2_1 (setq mau4 (cdr (assoc 62 (entget k ))))
								(if (= mau4 mau_lay_goc) (setq ds_ent4 (append (list k) ds_ent4)))
							)
							;----------------------------------------------------------
							(setq ds_ent5 (append ds_ent3 ds_ent4))	
							;------------------------------------------------------------
							(setq lst2 (ssadd))
							(foreach name ds_ent5 (ssadd name lst2))
							(sssetfirst nil lst2)
						)
				)			
			);end progn clr
		); end if clr
	);end progn ent
)	
(princ)
			
)

 
;1- ham lay ten cac phan tu trong 1 tab
(defun K:dsbg (table / lst phu)
(tblnext table t)
(while (setq phu (tblnext table nil))
(setq lst (cons (cdr (assoc 2 phu)) lst))
)
)
;=========================================
;==================
(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:ha2 ( / lst1 lst2 clr cly ss2 ds_ent ds_ent2 ds_ent3 mau mau2 mau_lay_goc ds_ent2_1 ds_ent5 ds_ent4 ds_ss_new clr_ex lay_k ds_ss clr_k)
(setq ent (car (entsel "\nDoi tuong mau :")))
(if ent
(progn
	(setq cly (cdr (assoc 8 (entget ent))))
	(setq clr_ex (if (= (setq clr (cdr (assoc 62 (entget ent)))) nil) 
					(vla-get-color (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) cly)) clr)) 
;---------------------------------------------------------------------------
	(prompt "chon vung: ")
	(setq ss2 (ssget))
	(if ss2 
		(progn
			(setq ds_ss (ss2ent ss2))
			(foreach k ds_ss
				(setq lay_k (cdr (assoc 8 (entget k))))
				(setq clr_k (if (= (setq clr1 (cdr (assoc 62 (entget k)))) nil) 
					(vla-get-color (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) lay_k)) clr1))
			;-------------------------------------------------------------------------------
				(if (= clr_k clr_ex)
					(setq ds_ss_new (append (list k) ds_ss_new))
				)
			)
			(setq lst2 (ssadd))
			(foreach name ds_ss_new (ssadd name lst2))
			(sssetfirst nil lst2)
		)
	);end if ss2
);end pron
);end if ent
(princ)
)










lệnh ha2


<<

Filename: 438442_ha_ha2.lsp
Tác giả: Biet ve CAD
Bài viết gốc: 438454
Tên lệnh: ha ha1 ha3 ha2 ha4
Về vấn đề lisp chọn đối tượng theo màu
19 phút trước, ngokiet đã nói:

Lisp của mình chỉ lọc theo thuột...

>>
19 phút trước, ngokiet đã nói:

Lisp của mình chỉ lọc theo thuột tính color của autocad.

 Bình thường thì lọc object này thường chỉ bật 1 layer nên mình nghĩ ko cần nhiều.

Nhưng theo bác ấy thì mình nghĩ lọc theo màu thể hiện chứ không phải màu thuột tính.

Nghĩa là 

- Nếu chọn obj màu x thì chọn tất cả obj màu x và obj màu bylayer có layer màu x.

- Nếu chọn obj mau bylayer thì chọn tất cả obj màu bylayer có layer cùng màu obj và obj có màu là màu của layer obj mẫu.

Nhưng cái này mình thấy ko cần thiết lắm.

Mạn phép lấy lisp các bạn đã post ( đặc biệt là của bạn @nhoclangbat ) sửa lại theo ý của chủ thớt

Lisp sẽ có 4 tùy chọn ( đáp ứng mọi nhu cầu luôn ^^). Lênh là HA

1. theo bylayer : miễn là color là bylayer thì sẽ chọn

2. theo màu của layer: layer màu gì sẽ chọn theo màu đó và chỉ các đối tượng là bylayer

3. theo màu của đối tượng, ko tính đối tượng có màu bylayer

4. theo màu đang hiển thị: cứ là màu này là chọn tất

(Defun c:ha ( )
(setq ansbvc (cond (ansbvc) ("HA4")))
(initget "HA1 HA2 HA3 HA4")
(setq ansbvc (cond ((getkword (strcat "\nChon mau theo <" ansbvc ">"))) (ansbvc)))
  

                                                            (if (= ansbvc "HA1") (progn (c:HA1)))
                                                            (if (= ansbvc "HA2") (progn (c:HA2)))
                                                            (if (= ansbvc "HA3") (progn (c:HA3)))
                                                            (if (= ansbvc "HA4") (progn (c:HA4)))

  (princ)
)
(defun c:ha1(/ )  (sssetfirst nil (ssget (list (cons 62 256)))))
(defun c:ha3 ( / lst1 lst2 clr cly ss2 ds_ent ds_ent2 ds_ent3 mau mau2 mau_lay_goc ds_ent2_1 ds_ent5 ds_ent4)
(setq ds_layer (K:dsbg "layer"))
(setq ent (car (entsel "\nDoi tuong mau :")))
(if ent
	(progn
		(setq clr (cdr (assoc 62 (entget ent))))
		(setq cly (cdr (assoc 8 (entget ent))))
		(if clr
			(progn
			    (prompt "chon vung: ")
				(setq lst1 (acet-ss-to-list (ssget (list (cons 62 clr)))))
				(setq lst2 (ssadd))
				(foreach name lst1 (ssadd name lst2))
				(sssetfirst nil lst2)
			)
			(progn
				(setq mau_lay_goc (vla-get-color (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) cly)))
;----------------------------------------------------------------------------------------------------------------------
				(prompt "chon vung: ")
				(setq ss2 (ssget))
				(if ss2 
						(progn
							(setq ds_ent (ss2ent ss2)) 
;(setq ds_lay_chon (mapcar '(lambda (x) (cdr (assoc 8 (entget x)))) ds_ent))
							(foreach k ds_ent
								(setq mau (cdr (assoc 62 (entget k ))))
								(if (= mau nil) (setq ds_ent2 (append (list k) ds_ent2))   (setq ds_ent2_1 (append (list k) ds_ent2_1))  ) 
							)
;--------------------
							(foreach k ds_ent2 
								(setq mau2 (vla-get-color (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) (cdr (assoc 8 (entget k )))  )))
								(if (= mau2  mau_lay_goc) (setq ds_ent3 (append (list k) ds_ent3)))
							)
;---------------------------------------------------------------
							(foreach k ds_ent2_1 (setq mau4 (cdr (assoc 62 (entget k ))))
								(if (= mau4 mau_lay_goc) (setq ds_ent4 (append (list k) ds_ent4)))
							)
;----------------------------------------------------------
							(setq ds_ent5 (append ds_ent3 ds_ent4))	
;------------------------------------------------------------
							(setq lst2 (ssadd))
							(foreach name ds_ent5 (ssadd name lst2))
							(sssetfirst nil lst2)
						)
				)			
			);end progn clr
		); end if clr
	);end progn ent
)	
(princ)
			
)

 
;1- ham lay ten cac phan tu trong 1 tab
(defun K:dsbg (table / lst phu)
(tblnext table t)
(while (setq phu (tblnext table nil))
(setq lst (cons (cdr (assoc 2 phu)) lst))
)
)
;=========================================
;==================
(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:ha2 ( / lst1 lst2 clr cly ss2 ds_ent ds_ent2 ds_ent3 mau mau2 mau_lay_goc ds_ent2_1 ds_ent5 ds_ent4 ds_ss_new clr_ex lay_k ds_ss clr_k)
(setq ent (car (entsel "\nDoi tuong mau :")))
(if ent
(progn
	(setq cly (cdr (assoc 8 (entget ent))))
	(setq clr_ex (vla-get-color (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) cly))) 
;---------------------------------------------------------------------------
	(prompt "chon vung: ")
	(setq ss2 (ssget))
	(if ss2 
		(progn
			(setq ds_ss (ss2ent ss2))
			(foreach k ds_ss
				(setq lay_k (cdr (assoc 8 (entget k))))
				(setq clr_k (vla-get-color (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) lay_k)))
;-------------------------------------------------------------------------------
				(if (= clr_k clr_ex)
					(setq ds_ss_new (append (list k) ds_ss_new))
				)
			)
			(setq lst2 (ssadd))
			(foreach name ds_ss_new (ssadd name lst2))
			(sssetfirst nil lst2)
		)
	);end if ss2
);end pron
);end if ent
(princ)
)
(defun c:ha4 ( / lst1 lst2 clr cly ss2 ds_ent ds_ent2 ds_ent3 mau mau2 mau_lay_goc ds_ent2_1 ds_ent5 ds_ent4 ds_ss_new clr_ex lay_k ds_ss clr_k)
(setq ent (car (entsel "\nDoi tuong mau :")))
(if ent
(progn
	(setq cly (cdr (assoc 8 (entget ent))))
	(setq clr_ex (if (= (setq clr (cdr (assoc 62 (entget ent)))) nil) 
					(vla-get-color (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) cly)) clr)) 
;---------------------------------------------------------------------------
	(prompt "chon vung: ")
	(setq ss2 (ssget))
	(if ss2 
		(progn
			(setq ds_ss (ss2ent ss2))
			(foreach k ds_ss
				(setq lay_k (cdr (assoc 8 (entget k))))
				(setq clr_k (if (= (setq clr1 (cdr (assoc 62 (entget k)))) nil) 
					(vla-get-color (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) lay_k)) clr1))
;-------------------------------------------------------------------------------
				(if (= clr_k clr_ex)
					(setq ds_ss_new (append (list k) ds_ss_new))
				)
			)
			(setq lst2 (ssadd))
			(foreach name ds_ss_new (ssadd name lst2))
			(sssetfirst nil lst2)
		)
	);end if ss2
);end pron
);end if ent
(princ)
)
(princ)

 


<<

Filename: 438454_ha_ha1_ha3_ha2_ha4.lsp
Tác giả: ngokiet
Bài viết gốc: 438470
Tên lệnh: sscolor
Về vấn đề lisp chọn đối tượng theo màu
1 giờ trước, Biet ve CAD đã nói:

Đang siêu sayan cấp 3, cố...

>>
1 giờ trước, Biet ve CAD đã nói:

Đang siêu sayan cấp 3, cố phát lên cấp 4, bạn nào có time cho lên cấp 5  là chọn được nhiều màu mẫu cùng lúc nữa ^^

Hình như Lisp của bạn các màu truecolor không thực hiện đúng vì truecolor nó cũng có trả về màu gần đúng là (assoc 62)

Truecolor là cad nó bổ sung sau nên nó thêm ở code 420 nhưng vì tương thích với lisp cũ nên vẫn có màu gần đúng ở code 62.

Mình thích lọc ở ssget cho có vẽ trực quan hơn nên mình bổ sung lisp này

(defun c:sscolor(/ lays objm y x420 x62 lays)
  (princ "\nSelect obj mau:")
  (or (setq objm (acet-ss-to-list (ssget))) (exit))
  (initget "A B")
  (if (eq (getkword "Chon kieu ") "B")
    (progn
      (foreach x objm
	(cond ((setq y (cdr(assoc 420 (setq x (entget x)))))
	       (or (member y x420) (setq x420 (cons y x420))))
	      ((setq y (cdr(assoc 62 x)))
	       (or (member y x62) (setq x62 (cons y x62))))
	      ((setq y (cdr(assoc 420 (setq x (entget (tblobjname "Layer" (cdr(assoc 8 x))))))))
	       (or (member y x420) (setq x420 (cons y x420))))
	      ((setq y (cdr(assoc 62 x)))
	       (or (member y x62) (setq x62 (cons y x62))))))
      (vlax-for x (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
	(setq x (entget(vlax-vla-object->ename x)))
	(if (or (member (cdr (assoc 420 x)) x420) (member (cdr (assoc 62 x)) x62))
	  (setq Lays (if lays (strcat lays "," (cdr(assoc 2 x))) (cdr(assoc 2 x))))))
      (sssetfirst nil (ssget
			(append '((-4 . "<OR"))
				(mapcar '(lambda(a) (cons 62 a)) x62)
				(mapcar '(lambda(a) (cons 420 a)) x420)
				(if lays
				  (list '(-4 . "<AND") (cons 8 lays) '(62 . 256) '(-4 . "AND>")))
				'((-4 . "OR>"))))))
    (progn
      (foreach x objm
	(cond ((setq y (cdr(assoc 420 (setq x (entget x)))))
	       (or (member y x420) (setq x420 (cons y x420))))
	      ((setq y (cond ((cdr(assoc 62 x))) (256)))
	       (or (member y x62) (setq x62 (cons y x62))))))
      (sssetfirst nil (ssget (append '((-4 . "<OR"))
				     (mapcar '(lambda(a) (cons 62 a)) x62)
				     (mapcar '(lambda(a) (cons 420 a)) x420)
				     '((-4 . "OR>")))))))
  (princ))

- Chọn mẫu có thể nhiều mẫu được.

- Màu truecolor vẫn chọn đúng.

Có 2 kiểu lọc theo mình nói ở trên.


<<

Filename: 438470_sscolor.lsp
Tác giả: an_bmt
Bài viết gốc: 398987
Tên lệnh: laykt stext sdim
Lisp tạo các Layer cho trước trong một bản vẽ mới

 

 

Vấn đề của bạn đã được đề cập đến trong diễn đàn rồi bạn à, bạn làm theo cách này cũng...

>>

 

 

Vấn đề của bạn đã được đề cập đến trong diễn đàn rồi bạn à, bạn làm theo cách này cũng được:

 

;;; Khoi tao Layer ;;;

(defun newlay(a b c d) 

(if (not (tblsearch "layer" a)) (command "-layer" "n" a "c" b a "l" c a "lw" d a "")

(command "-layer" "s" a "c" b a "l" c a "lw" d a "")))

;;; Sau do cu viet theo nhu cau: (newlay "name" color "laytype" lineweight), Vi du:

(defun C:laykt()

(newlay "KT-TRUC" 2 "CENTER2" 0.13)

(newlay "KT-BAO" 2 "CONTINUOUS" 0.30)

.....................................................

(prompt "\nBao cao da khoi tao he thong LAYER can thiet\n"))

 

;;; Khoi Textstyle ;;;

(command "style" "stylename" "fontname" "height" "width factor" "" "" "" "")

;;; Vi du:

(defun C:stext()

(command "style" "Standard" "simplex.shx,bigfont.shx" "0" "0.75" "" "" "" "")

.............................................................................

(prompt "\nBao cao da khoi tao to hop template TEXT STYLE can thiet\n"))

 

;;; Khoi Dimstyle ;;;

(defun C:sdim()

(C:stext)

(setvar "DIMBLK" "_Open")

(setvar "DIMLDRBLK" "_Open")

(setvar "DIMCLRD" 0)

(setvar "DIMCLRE" 0)

(setvar "DIMCLRT" 0)

(setvar "DIMCEN" 0)

(setvar "DIMDLI" 7)

(setvar "DIMEXO" 1)

(setvar "DIMEXE" 1)

(setvar "DIMSCALE" 50)

(setvar "DIMTXSTY" "Standard")

(setvar "DIMDSEP" ".")

(setvar "DIMALTD" 0)

(setvar "DIMTMOVE" 2)

(setvar "DIMAUNIT" 1)

(setvar "DIMTXT" 3.5)

(setvar "DIMADEC" 3)

(setvar "DIMTIX" 1)

(setvar "DIMASZ" 2)

(setvar "DIMDEC" 0)

(setvar "DIMGAP" 1)

(setvar "DIMLFAC" 0.4) (command "-dimstyle" "s" "KT-50-20")

(setvar "DIMLFAC" 2) (command "-dimstyle" "s" "KT-50-100")

(setvar "DIMLFAC" 0.2) (command "-dimstyle" "s" "KT-50-10")

(setvar "DIMLFAC" 0.6) (command "-dimstyle" "s" "KT-50-30")

(setvar "DIMLFAC" 1) (command "-dimstyle" "s" "KT-50")

(prompt "\nBao cao da khoi tao to hop template DIMMENSION STYLE can thiet\n"))

 

;;; Cac bien he thong ban tu nghien cuu nhe! ;;;
Goodluck!

 

 

 

 

Vấn đề của bạn đã được đề cập đến trong diễn đàn rồi bạn à, bạn làm theo cách này cũng được:

 

;;; Khoi tao Layer ;;;

(defun newlay(a b c d) 

(if (not (tblsearch "layer" a)) (command "-layer" "n" a "c" b a "l" c a "lw" d a "")

(command "-layer" "s" a "c" b a "l" c a "lw" d a "")))

;;; Sau do cu viet theo nhu cau: (newlay "name" color "laytype" lineweight), Vi du:

(defun C:laykt()

(newlay "KT-TRUC" 2 "CENTER2" 0.13)

(newlay "KT-BAO" 2 "CONTINUOUS" 0.30)

.....................................................

(prompt "\nBao cao da khoi tao he thong LAYER can thiet\n"))

 

;;; Khoi Textstyle ;;;

(command "style" "stylename" "fontname" "height" "width factor" "" "" "" "")

;;; Vi du:

(defun C:stext()

(command "style" "Standard" "simplex.shx,bigfont.shx" "0" "0.75" "" "" "" "")

.............................................................................

(prompt "\nBao cao da khoi tao to hop template TEXT STYLE can thiet\n"))

 

;;; Khoi Dimstyle ;;;

(defun C:sdim()

(C:stext)

(setvar "DIMBLK" "_Open")

(setvar "DIMLDRBLK" "_Open")

(setvar "DIMCLRD" 0)

(setvar "DIMCLRE" 0)

(setvar "DIMCLRT" 0)

(setvar "DIMCEN" 0)

(setvar "DIMDLI" 7)

(setvar "DIMEXO" 1)

(setvar "DIMEXE" 1)

(setvar "DIMSCALE" 50)

(setvar "DIMTXSTY" "Standard")

(setvar "DIMDSEP" ".")

(setvar "DIMALTD" 0)

(setvar "DIMTMOVE" 2)

(setvar "DIMAUNIT" 1)

(setvar "DIMTXT" 3.5)

(setvar "DIMADEC" 3)

(setvar "DIMTIX" 1)

(setvar "DIMASZ" 2)

(setvar "DIMDEC" 0)

(setvar "DIMGAP" 1)

(setvar "DIMLFAC" 0.4) (command "-dimstyle" "s" "KT-50-20")

(setvar "DIMLFAC" 2) (command "-dimstyle" "s" "KT-50-100")

(setvar "DIMLFAC" 0.2) (command "-dimstyle" "s" "KT-50-10")

(setvar "DIMLFAC" 0.6) (command "-dimstyle" "s" "KT-50-30")

(setvar "DIMLFAC" 1) (command "-dimstyle" "s" "KT-50")

(prompt "\nBao cao da khoi tao to hop template DIMMENSION STYLE can thiet\n"))

 

;;; Cac bien he thong ban tu nghien cuu nhe! ;;;
Goodluck!

 

(DEFUN C:Mtd()

(setvar "cmdecho" 0)

(setvar "DIMARCSYM" 1)

(setvar "DIMASZ" 150)

(setvar "DIMBLK1" "_ArchTick")

(setvar "DIMBLK2" "_ArchTick")

(setvar "DIMCEN" 200)

(setvar "DIMDEC" 0)

(setvar "DIMDLE" 100)

(setvar "DIMDLI" 50)

(setvar "DIMEXE" 100)

(setvar "DIMEXO" 6)

(setvar "DIMFXL" 0)

(setvar "DIMGAP" 100)

(setvar "DIMSCALE" 1)

(setvar "DIMTAD" 1)

(setvar "DIMTDEC" 0)

(setvar "DIMTMOVE" 2)

(setvar "DIMTXSTY" "Standard")

(setvar "DIMTXT" 225)

(setvar "DIMLFAC" 1) (command "-dimstyle" "s" "An.civil 1-100")

(setvar "DIMLFAC" 0.5) (command "-dimstyle" "s" "An.civil 1-50")

(setvar "DIMLFAC" 0.25) (command "-dimstyle" "s" "An.civil 1-25")

(setvar "DIMLFAC" 0.20) (command "-dimstyle" "s" "An.civil 1-20")

(setvar "DIMLFAC" 0.10) (command "-dimstyle" "s" "An.civil 1-10")

(setvar "DIMLFAC" 0.05) (command "-dimstyle" "s" "An.civil 1-5")

(prompt "\nBao cao da khoi tao to hop template DIMMENSION STYLE can thiet\n"))

.............................................................................


<<

Filename: 398987_laykt_stext_sdim.lsp
Tác giả: nhoclangbat
Bài viết gốc: 438513
Tên lệnh: kkk
Lisp vẽ line từ điểm đến đối tượng cho trước

- lâu rùi có mót đc anh nào cái hàm phù hợp mong mún của bạn, bạn test thử, line vẽ theo layer hiện hành nha ^^, cuối giờ làm biếng hihi

(defun c:KKK(/ ent ss ds_ip ds_text )
(setq ent (car (entsel "\nChon pline cho truoc: ")))
(alert "chon text")
(setq ss (ssget '((0 . "*text"))))
(if (and ss ent)
	(progn
		(setq ds_text (ss2ent ss))
		(setq ds_ip (mapcar '(lambda (x) (cdr...
>>

- lâu rùi có mót đc anh nào cái hàm phù hợp mong mún của bạn, bạn test thử, line vẽ theo layer hiện hành nha ^^, cuối giờ làm biếng hihi

(defun c:KKK(/ ent ss ds_ip ds_text )
(setq ent (car (entsel "\nChon pline cho truoc: ")))
(alert "chon text")
(setq ss (ssget '((0 . "*text"))))
(if (and ss ent)
	(progn
		(setq ds_text (ss2ent ss))
		(setq ds_ip (mapcar '(lambda (x) (cdr (assoc 10 (entget x)))) ds_text))
		(foreach k ds_ip (lpp2c k ent))
	)
)
(princ)
)	

(defun LPP2C (p1 c / p2);;;Line from Point p1 Perpendicular To Curve c
(vl-load-com)
(setq p2 (vlax-curve-getClosestPointTo c p1 T))
(entmake (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2)))
)
;==================
(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)
;===================

 


<<

Filename: 438513_kkk.lsp

Trang 295/330

295