Jump to content
InfoFile
Tác giả: whatcholingon
Bài viết gốc: 393669
Tên lệnh: od oc oca
[Yêu Cầu] Nhờ Viết Lisp Copy Tăng Số Cải Tiến

Trường hợp 2 thì bạn dùng lisp này, dùng lệnh OC ( tác giả như trên)   ( LỆNH OC DÙNG ĐƯỢC CHO CẢ 2 TRƯỜNG HỢP LUN)

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=51710

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=34029
;; free lisp from...
>>

Trường hợp 2 thì bạn dùng lisp này, dùng lệnh OC ( tác giả như trên)   ( LỆNH OC DÙNG ĐƯỢC CHO CẢ 2 TRƯỜNG HỢP LUN)

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=51710

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=34029
;; free lisp from cadviet.com

;;;**********************************************
;;;CHUONG TRINH DANH SO THU TU VA COPY TANG DAN
;;;1. Lenh OD: danh so thu tu, tuy chon so bat dau (begin) va so gia (increment) tuy y
;;;2. Lenh OC: copy tang dan tu mot so thu tu co san
;;;3. Lenh oCA: copy tang dan voi doi tuong Attribute Block
;;;Chuong trinh chap nhan cac dinh dang bang so, chu, so va chu ket hop:
;;;1, 2... A, B..., A1, A2..., AB-01, AB-02..., AB-01-C1, AB-01-C2...
;;;Cac chu gioi han trong khoang tu A den Z. Cac so khong han che
;;;Copyright by ssg - www.cadviet.com - December 2008
;;;**********************************************


;;;-------------------------------------------------
(defun etype (e) ;;;Entity Type
(cdr (assoc 0 (entget e)))
)
;;;-------------------------------------------------
(defun wtxt (txt p / sty d h) ;;;Write txt on graphic screen, defaul setting
(setq
    sty (getvar "textstyle")
    d (tblsearch "style" sty)
    h (cdr (assoc 40 d))
)
(if (= h 0) (setq h (cdr (assoc 42 d))))
(entmake
    (list (cons 0 "TEXT") (cons 7 sty) (cons 1 txt) (cons 10 p) (cons 40 h) (assoc 41 d))
)
)
;;;-------------------------------------------------
(defun incN (n dn / n2 i n1) ;;;Increase number n
(setq
    n2 (itoa (+ dn (atoi n)))
    i (- (strlen n) (strlen n2))
)
(if (> i 0) (setq n1 (substr n 1 i)) (setq n1 ""))
(strcat n1 n2)
)
;;;-------------------------------------------------
(defun incC (c / i c1 c2) ;;;Increase character c
(setq
    i (strlen c)
    c1 (substr c 1 (- i 1))
    c2 (chr (1+ (ascii (substr c i 1))))
)
(if (or (= c2 "{") (= c2 "["))
    (progn (command "erase" (entlast) "") (alert "Over character!") (exit))
    (strcat c1 c2)
)
)
;;;============================
(defun C:OD( / cn dn c n p) ;;;Make OrDinal number with any format
(setq
    cn (getstring "\nBegin at <1>: " T)
    dn (getint "\nIncrement <1>: ")
)
(if (not dn) (setq dn 1))
(if (= cn "") (setq cn "1"))
(setq c (vl-string-right-trim "0 1 2 3 4 5 6 7 8 9" cn))
(setq n (vl-string-subst "" c cn))
(if (/= n "") (setq mode 1) (setq mode 0))
(while (setq p (getpoint "\nBase point <exit>: "))
    (wtxt cn p)
    (if (= n "") 
        (setq cn (incC cn))
        (setq cn (strcat c (incN (vl-string-subst "" c cn) dn)))        
    )
)
(princ)
)
;;;============================
(defun C:OC( / e dn p1 cn c n p2 dat) ;;;Make Ordinal number. Copy from template
(command "undo" "be")
(setq
    e (car (entsel "\nSelect template text:"))
    dn (getint "\nIncrement <1>: ")
    p1 (getpoint "\nBase point:")
    cn (cdr (assoc 1 (entget e)))
    k (strlen cn)
    i (getint "\n Nhap so ky tu can giu trong suffix: ")
    cn0 (substr cn 1 (- k i))
    cn1 (substr cn (1+ (- k i)))
)
(if (not dn) (setq dn 1))
(if (= cn "") (setq cn "1"))
(setq
    c (vl-string-right-trim "0 1 2 3 4 5 6 7 8 9" cn0)
    n (vl-string-subst "" c cn0)
)
(while (setq p2 (getpoint p1 "\nNew point <exit>: "))
    (command "copy" e "" p1 p2)
    (if (= n "") 
        (setq cn0 (incC cn0))
        (setq cn0 (strcat c (incN (vl-string-subst "" c cn0) dn)))        
    )
    (setq
        dat (entget (entlast))
        dat (subst (cons 1 (strcat cn0 cn1)) (assoc 1 dat) dat)
    )
    (entmod dat)    
)
(command "undo" "e")
(princ)
)
;;;============================
(defun C:oCA( / e e0 dn p1 cn c n p2 dat) ;;;Make Ordinal number. Copy from Atttribute block
(setq
    e0 (car (entsel "\nSelect attribute block:"))
    e (entnext e0)
)
(if (/= (etype e) "ATTRIB") (progn (alert "Object is not a Attribute Block!") (exit)))
(setq
    dn (getint "\nIncrement <1>: ")
    p1 (getpoint "\nBase point:")
    cn (cdr (assoc 1 (entget e)))
)
(if (not dn) (setq dn 1))
(if (= cn "") (setq cn "1"))
(setq
    c (vl-string-right-trim "0 1 2 3 4 5 6 7 8 9" cn)
    n (vl-string-subst "" c cn)
)
(while (setq p2 (getpoint p1 "\nNew point <exit>: "))
    (command "copy" e0 "" p1 p2)
    (if (= n "") 
        (setq cn (incC cn))
        (setq cn (strcat c (incN (vl-string-subst "" c cn) dn)))        
    )
    (setq
        dat (entget (entnext (entlast)))
        dat (subst (cons 1 cn) (assoc 1 dat) dat)
    )
    (entmod dat)
    (command "regen")
)
(princ)
)
;;;============================



<<

Filename: 393669_od_oc_oca.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 393875
Tên lệnh: tt%C2%A0
Hiệu Chỉnh Đường Dùng Lệnh Le

Thank bác! nhưng bí quá em mới dùng command.

+ Lsp ở dưới có lẽ đạt được cả Y/c 2 và 3 (do chưa hiểu lắm về ý đồ của chủ thớt trong Y/c 3).

+ Yêu cầu Leader phải có 2 đoạn gấp khúc trở lên (2 Segment).

+ Có 1 leader mẫu trước và dùng kiểu offset như lsp trước.

+ Các Segment trước (về phía mũi tên) có chung cùng khoảng cách offset, Segment cuối cùng có khoảng cách...

>>

Thank bác! nhưng bí quá em mới dùng command.

+ Lsp ở dưới có lẽ đạt được cả Y/c 2 và 3 (do chưa hiểu lắm về ý đồ của chủ thớt trong Y/c 3).

+ Yêu cầu Leader phải có 2 đoạn gấp khúc trở lên (2 Segment).

+ Có 1 leader mẫu trước và dùng kiểu offset như lsp trước.

+ Các Segment trước (về phía mũi tên) có chung cùng khoảng cách offset, Segment cuối cùng có khoảng cách khác.

(defun c:tt  (/ AT:Offset LWPoly ang1 ang2 clr dis dis2 ele ent epe ept i lma lpl lsp nepe nept nle npl obj ole opl pee pt1 pte sll)
 (defun AT:Offset  (O D P / _pt p1 p2 c D g)
  (setq _pt (lambda (s) (vlax-curve-getPointAtDist O (s (vlax-curve-getDistAtPoint O p1) 0.00001))))
  (if (and (setq p1 (vlax-curve-getclosestpointtoprojection O (trans P 1 0) '(0 0 1)))
           (or (setq p2 (setq c (_pt +))) (setq p2 (_pt -)))
           (if (minusp (- (* (- (car p2) (car p1)) (- (cadr (trans P 1 0)) (cadr p1)))
                          (* (- (cadr p2) (cadr p1)) (- (car (trans P 1 0)) (car p1)))))
            (if (vl-position (vla-get-objectname O) '("AcDbLine" "AcDbXline"))
             (setq D (- (abs D)))
             (setq D (abs D)))
            (if (vl-position (vla-get-objectname O) '("AcDbLine" "AcDbXline"))
             (setq D (abs D))
             (setq D (- (abs D)))))
           (or c (setq D (- D)))
           (not (vl-catch-all-error-p (setq g (vl-catch-all-apply 'vla-offset (list O D))))))
   (car (vlax-safearray->list (vlax-variant-value g)))))
 (defun LWPoly  (lst)
  (entmakex (append (list (cons 0 "LWPOLYLINE")
                          (cons 100 "AcDbEntity")
                          (cons 100 "AcDbPolyline")
                          (cons 90 (length lst))
                          (cons 70 0))
                    (mapcar (function (lambda (p) p)) lst))))
 (princ "\nSelect a Leader...!")
 (if (setq ele (ssget "_+.:E:S" '((0 . "LEADER"))))
  (progn (setq ent (ssname ele 0)
               ole (vlax-ename->vla-object ent)
               clr (vla-get-DimensionLineColor ole)
               lsp (vl-remove-if-not '(lambda (x) (member (car x) '(10))) (entget ent))
               pte (cdr (last lsp))
               lma (vl-remove-if '(lambda (x) (member (car x) '(-1 5 10))) (entget ent)))
         (if (> (length lsp) 2)
          (progn (setq opl (LWPoly lsp)
                       obj (vlax-ename->vla-object opl))
                 (vla-put-color obj clr)
                 (if (and (setq dis (getdist "\nOffset distance: "))
                          (or (setq dis2 (getreal (strcat "\nOffset Distance last Segment <" (rtos (* dis 1.5)) ">: ")))
                              (setq dis2 (* dis 1.5)))
                          (setq sll (getint "\nNumber of Leader:"))
                          (setq pt1 (getpoint "\nSelect side to offset to: ")))
                  (progn (setq i 1)
                         (repeat sll
                          (if (AT:Offset obj (* dis i) pt1)
                           (progn (setq npl  (entlast)
                                        lpl  (vl-remove-if-not '(lambda (x) (member (car x) '(10))) (entget npl))
                                        epe  (cdr (nth (- (length lsp) 2) lpl))
                                        pee  (cdr (nth (- (length lsp) 3) lpl))
                                        ept  (cdr (last lpl))
                                        ang1 (angle epe ept)
                                        ang2 (angle pte ept))
                                  (and (setq nept (polar pte (angle pte ept) (* dis2 i))
                                             nepe (inters pee epe nept (polar nept ang1 (distance ept epe)) nil))
                                       (setq lpl (append (reverse (cddr (reverse lpl))) (list (cons 10 nepe) (cons 10 nept))))
                                       (setq nle (vlax-ename->vla-object (entmakex (append lma lpl)))))
                                  (if nle
                                   (progn nle
                                          (vla-put-arrowheadsize nle (vla-get-arrowheadsize ole))
                                          (vla-put-DimensionLineColor nle clr)))
                                  (entdel npl)))
                          (setq i (1+ i)))))
                 (vla-erase obj))
          (Acet-ui-message "Lisp chi thuc hien voi Line-Leader co so Segment > 1!" "Thong bao!" (+ 0 16 768)))))
 (princ))

<<

Filename: 393875_tt%C2%A0.lsp
Tác giả: ketxu
Bài viết gốc: 393983
Tên lệnh: mc
Chuyển Dtext Thành Mtext Và Setp Justify Cho Mtext Vừa Chuyển

Quick code.
- Đánh dấu entlast e cuối cùng trước khi thực hiện lệnh txt2mtxt
- Sau khi thực hiện lệnh txt2mtxt thì tìm tất cả các entity mới sinh bằng hàm _getNews (entnext từ e đến hết)

- Put align point của Mtext mới thành 5 (Middle center)
- À mình sửa dòng command để biến tất cả thành 1 Mtext, nếu bạn thích biến từng text một thì giữ nguyên dòng command nhé

>>

Quick code.
- Đánh dấu entlast e cuối cùng trước khi thực hiện lệnh txt2mtxt
- Sau khi thực hiện lệnh txt2mtxt thì tìm tất cả các entity mới sinh bằng hàm _getNews (entnext từ e đến hết)

- Put align point của Mtext mới thành 5 (Middle center)
- À mình sửa dòng command để biến tất cả thành 1 Mtext, nếu bạn thích biến từng text một thì giữ nguyên dòng command nhé

(defun c:mc(/ ss e _getNews)
	;Quick collect after e :
	(defun _getNews (e / l)
		(cond (e (while (setq e (entnext e))(setq l (cons e l)))))
	)
	(setq ss (ssget '((0 . "*TEXT"))) e (entlast))   
    (command "_txt2mtxt" ss "")	
	(foreach e (mapcar 'vlax-ename->vla-object  (_getNews e))
		(vla-put-AttachmentPoint e 5)
	)
)

<<

Filename: 393983_mc.lsp
Tác giả: Tue_NV
Bài viết gốc: 394049
Tên lệnh: mc
Chuyển Dtext Thành Mtext Và Setp Justify Cho Mtext Vừa Chuyển

Thêm cách dùng JUSTIFYTEXT

(defun c:mc()
    (setq ss (ssget '((0 . "TEXT"))))
    (foreach en (acet-ss-to-list ss)
        (command "_txt2mtxt" en "" "JUSTIFYTEXT" "L" "" "MC")
        )
)

Filename: 394049_mc.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 394138
Tên lệnh: tt%C2%A0
[Yêu Cầu] Lisp Scale Theo Đối Tượng Mẫu

Bạn thử cái này xem: (scale 1 lúc nhiều khung - Chọn vào block, không cần chọn vào cạnh)

(defun c:tt  (/ bk1 bkx bp2 ds1 dsx i lp1 lp2 obj ss)
 (and (setq bk1 (car (entsel "\nChon mau: ")))
      (princ "\nChon blks scale:")
      (setq ss (ssget '((0 . "INSERT"))))
      (setq lp1 (acet-ent-geomextents...
>>

Bạn thử cái này xem: (scale 1 lúc nhiều khung - Chọn vào block, không cần chọn vào cạnh)

(defun c:tt  (/ bk1 bkx bp2 ds1 dsx i lp1 lp2 obj ss)
 (and (setq bk1 (car (entsel "\nChon mau: ")))
      (princ "\nChon blks scale:")
      (setq ss (ssget '((0 . "INSERT"))))
      (setq lp1 (acet-ent-geomextents bk1)
            ds1 (distance (car lp1) (list (caar lp1) (cadadr lp1))))
      (repeat (setq i (sslength ss))
       (setq bkx (ssname ss (setq i (1- i)))
             lp2 (acet-ent-geomextents bkx)
             dsx (distance (car lp2) (list (caar lp2) (cadadr lp2)))
             obj (vlax-ename->vla-object bkx)
             bp2 (vla-get-insertionpoint obj))
       (vla-ScaleEntity obj bp2 (/ ds1 dsx))))
 (princ))

<<

Filename: 394138_tt%C2%A0.lsp
Tác giả: mrphuocvie
Bài viết gốc: 394139
Tên lệnh: shiage tagdw
Lỗi Do Thiếu Font Hay Lỗi Do Lisp

Chào cadviet.com,

Em có sửa đoạn code để làm công việc riêng của mình, song nó có nảy ra 1 vấn đề là BỊ LỖI FONT.

Em đã trình bày vấn đề này trong file .dwg, nhờ mọi người xem qua và chỉ em cách giải quyết.

Vấn đề ở đây em thấy kỳ lạ là: Nếu vì bị thiếu font thì trong mọi lúc nó sẽ không hiển thị được (Bản vẽ tiếng Nhật), nhưng ở đây, text sẽ bị lỗi font...

>>

Chào cadviet.com,

Em có sửa đoạn code để làm công việc riêng của mình, song nó có nảy ra 1 vấn đề là BỊ LỖI FONT.

Em đã trình bày vấn đề này trong file .dwg, nhờ mọi người xem qua và chỉ em cách giải quyết.

Vấn đề ở đây em thấy kỳ lạ là: Nếu vì bị thiếu font thì trong mọi lúc nó sẽ không hiển thị được (Bản vẽ tiếng Nhật), nhưng ở đây, text sẽ bị lỗi font trong quá trình thực hiện lệnh. Để dễ hiểu mọi người hãy run lệnh đó giúp em.

Cảm ơn!132006_01_1.png

;GetAtt
	(defun GetAtt (obj)
		(mapcar '(lambda (att) (cons (vla-get-TagString att) (vla-get-TextString att))) (vlax-invoke obj 'GetAttributes)))
;SetAtt
	(defun SetAtt (obj lst / attval)
		(mapcar '(lambda (att) (if (setq attval (cdr (assoc (vla-get-TagString att) lst))) (vla-put-TextString att attval))) (vlax-invoke obj 'GetAttributes))
		(vla-update obj))
;tao ham con
	(defun Asign_Att (tag_txt tag_Att / txt_i Att_i lst lst1 lst2 lst3)
		(setq txt_i (cdr (assoc 1 (entget (car (entsel (strcat "\nSelect text for " tag_txt ": ")))))))
		(setq Att_i tag_Att)
		(foreach obj objlst
			(setq lst (GetAtt obj))
			(foreach lst1 lst
				(if (= (strcase (car lst1)) (strcase Att_i))
					(setq lst2 (cons (car lst1) txt_i))
					(setq lst2 lst1))
				(setq lst3 (cons lst2 lst3)))
			(SetAtt obj lst3)))
;Main code SHIAGE
(defun C:SHIAGE ()
	(vl-load-com)
	(princ "\nSelect DynamicBlock '0-Shiage_Obayashi': ")
	(setq ss (ssget (list (cons 0 "insert"))))
	(setq objlst (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))))
	;Thay the text_0i cho Att_0i-----------------------------------------------------
	(Asign_Att "室 名" "S01")
	(Asign_Att "CH=" "S02")
	(Asign_Att "FL" "S03")
	(Asign_Att "天井 仕上" "S04")
	(Asign_Att "天井 下地" "S05")
	(Asign_Att "廻縁" "S06")
	(Asign_Att "壁 仕上" "S07")
	(Asign_Att "壁 下地" "S08")
	(Asign_Att "巾木" "S09")
	(Asign_Att "床 仕上" "S10")
	(Asign_Att "床 下地" "S11")
	(Asign_Att "備考_1" "S12")
	(Asign_Att "備考_2" "S13")
	(Asign_Att "(巾木)H=" "S14")
	(Asign_Att "準" "S15")
	(princ)
)
;Main code TAG_D&W
(defun C:TAGDW ()
	(vl-load-com)
	(princ "\nSelect DynamicBlock '0-Tag_DW_Obayashi': ")
	(setq ss (ssget (list (cons 0 "insert"))))
	(setq objlst (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))))
	;Thay the text_0i cho Att_0i-----------------------------------------------------
	(Asign_Att "建具符号(Name)" "D01")
	(Asign_Att "建具番号(Type)" "D02")
	(Asign_Att "W=" "D03")
	(Asign_Att "H=" "D04")
	(Asign_Att "h=" "D05")
	(Asign_Att "電気錠(E)" "D06")
	(Asign_Att "防火性能" "D07")
	(Asign_Att "建具特記(SAT, PAT)" "D08")
	(princ)
) 

File .dwg

http://www.cadviet.com/upfiles/5/132006_02.dwg


<<

Filename: 394139_shiage_tagdw.lsp
Tác giả: pphung183
Bài viết gốc: 378590
Tên lệnh: dcd
Nhờ Xem Giúp Lips Điền Cao Độ Tk

Trước đây em đang dùng lips này nó vẫn chạy tốt không biết đợt này thế nào nó lại báo lỗi
Lips này nó điền cao độ đường pline đã có cao độ 
Error:Automation Error. No database; error: An error has occurred inside the 
*error* functionbad argument type: fixnump: "BYLAYER"
. Sẵn đây anh chị xem...

>>

Trước đây em đang dùng lips này nó vẫn chạy tốt không biết đợt này thế nào nó lại báo lỗi
Lips này nó điền cao độ đường pline đã có cao độ 
Error:Automation Error. No database; error: An error has occurred inside the 
*error* functionbad argument type: fixnump: "BYLAYER"
. Sẵn đây anh chị xem giúp. Nếu các bác ngại xem thìị viết giùm lips xuất cao độ của đường Pline. Đường này bản thân nó đã có cao độ, bây giờ em muốn nó xuất ra cao độ ngay trên đường pline đó. em gởi kèm bản vẽ và lips trước đây.
http://www.mediafire.com/download/mmwimfg9beraytl/san+nen1.rar
http://www.mediafire.com/download/hl8my7xnci0hl04/dcd.lsp

Một cách viết khác :) :

(defun c:dcd (/ doc ms a p) (vl-load-com)
(setq doc (vla-get-activedocument (vlax-get-acad-object)) 
ms (vla-get-modelspace doc))
(if (ssget (list (cons 0 "*POLYLINE"))) 
(vlax-map-collection (vla-get-ActiveSelectionset doc) '(lambda (obj)
(foreach x (acet-geom-vertex-list (vlax-vla-object->ename obj))
(vla-put-Alignment (setq a (vla-addtext ms (rtos (last x) 2 2)
(setq p (vlax-3d-point (list (car x) (cadr x)))) 1.)) 10)
(vla-put-TextAlignmentPoint a p) )))))

Cad bạn phải có Express Tools!


<<

Filename: 378590_dcd.lsp
Tác giả: mrphuocvie
Bài viết gốc: 394382
Tên lệnh: 2dw
Lisp Dim Kích Thước Tường (Style Janpan)

Chào Cadviet.com,

Do nhu cầu công việc  Dim 1 bộ kích thước tường nên em đã tự mày mò viết nhưng kết quả không như  ý. Nay nhờ mọi người hỗ trợ hoàn thành và phát triển lisp giúp em.

Để hiểu thêm nội dung, cho em được đính kèm file .dwg.

https://app.box.com/files/0/f/0/1/f_55303025730

Chân thành cảm...

>>

Chào Cadviet.com,

Do nhu cầu công việc  Dim 1 bộ kích thước tường nên em đã tự mày mò viết nhưng kết quả không như  ý. Nay nhờ mọi người hỗ trợ hoàn thành và phát triển lisp giúp em.

Để hiểu thêm nội dung, cho em được đính kèm file .dwg.

https://app.box.com/files/0/f/0/1/f_55303025730

Chân thành cảm ơn và chúc sức khỏe mọi người!

;20160301-DIM WALL
(defun C:2DW (/ file ssl c cbert i)
	;Ten layer centerline, LGS, Finish_01
	(setq lay_cen "Grid")
	(setq lay_LGS "LGS")
	(setq lay_fn1 "Finish_01")
	;Chon cac line cau tao tuong va set thoc tinh
	(setq 	ssl (ssget '((0 . "LINE"))))
	;Chon diem dat dim
	(setq 	pd0 (getpoint "\nSelect point to put dimension: ")
			xd0 (car pd0)
			yd0 (cadr pd0))
	(setq dis_d	(getdist "\nEnter distance between dimension: ")); Gan giong nhu dimbaseline
	;Xet tuong dang nam phuong x hay phuong y
	(setq
		pt1_0 (cdr (assoc 10 (entget (ssname ssl 0))))	;diem dau
		x1_0 (car pt1_0)
		y1_0 (cadr pt1_0)
		pte_0 (cdr (assoc 11 (entget (ssname ssl 0))))	;diem cuoi
		xe_0 (car pte_0)
		ye_0 (cadr pte_0)
	)
	(if (= x1_0 xe_0)
		(setq ori "Ver");phuong dung
		(if (= y1_0 ye_0)
			(setq ori "Hor")
			exit));phuong ngang, neu khong la phuong ngang thi thoat
	;Xet hai phuong
	(if (= ori "Ver")
		;NEU TUONG THEO PHUONG VERTICAL
		(progn
			(setq pd1 (list xd0 (- yd0 dis_d)))
			(setq i 0)
			;Xac dinh thong tin centerline
			(repeat (sslength ssl)
				(setq
					lay_li (cdr (assoc 8 (entget (ssname ssl i))))	;ten layer
					pt1i (cdr (assoc 10 (entget (ssname ssl i))))	;diem dau
					ptei (cdr (assoc 11 (entget (ssname ssl i))))	;diem cuoi
					i (1+ i))
				;Neu la truc thi lay thuoc tinh
				(if (= lay_li lay_cen)
					(progn
						(setq 
							pt1_cen pt1i
							x1_cen (car pt1_cen)
							y1_cen (cadr pt1_cen)
						)
					)
				)
			);Neu hay hon la dung cau truc lap den khi thay layer "lay_cen" thi dung, nhung hien tai chua biet cach
			;Lay thuoc tinh cac line LGS va Finish_01
			(setq i 0)
			(repeat (sslength ssl)
				(setq
					lay_li (cdr (assoc 8 (entget (ssname ssl i))))	;ten layer
					pt1i (cdr (assoc 10 (entget (ssname ssl i))))	;diem dau
					i (1+ i))
				(progn
					(if (= lay_li lay_LGS)
						(progn
							(setq 
								pt1_LGS pt1i
								x1_LGS (car pt1_LGS)
								y1_LGS (cadr pt1_LGS)
							)
							;LGS NAM BEN TRAI HAY BEN PHAI TAM TUONG
							(if (< x1_LGS x1_cen)
								(setq pt_LGS_L pt1_LGS)
								(setq pt_LGS_R pt1_LGS)
							)
						);DK dung IF cap 1
						(progn
							(if (= lay_li lay_fn1)
								(progn
									(setq 
										pt1_fn1 pt1i
										x1_fn1 (car pt1_fn1)
										y1_fn1 (cadr pt1_fn1)
									)
									(if (< x1_fn1 x1_cen)
										(setq pt_fn1_L pt1_fn1)
										(setq pt_fn1_L pt1_fn1)
									)
								);DK dung IF cap 2
							);Ket thuc IF cap 2 nghia la ngoai ra thi khong xet	
						);DK sai IF cap 1
					);Ket thuc IF cap 2
				)		
			);Ket thu ham Repeat
			(setvar "osmode" 0); tat che do bat diem
			(command "dimlinear" pt_fn1_L pt1_cen pd0)
			(command "dimlinear" pt1_cen pt_fn1_R pd0)
			(command "dimlinear" pt_fn1_L pt_LGS_L pd1)
			(command "dimlinear" pt_LGS_L pt_LGS_R pd1)
			(command "dimlinear" pt_LGS_R pt_fn1_R pd1)

		);Ket thuc IF neu tuong theo phuong VERTICAL
		;NEU TUONG THEO PHUONG HORIZONTAL, nho cac cao thu viet tiep giup em ah!
		
	
	
	
	)
	(setvar "osmode" 4863); tat che do bat diem
	(Princ)
)

132006_160302_2dw.png


<<

Filename: 394382_2dw.lsp
Tác giả: taipham
Bài viết gốc: 394439
Tên lệnh: cco
Nhờ Sửa Lisp Copy Cộng Dồn Khoảng Cách
http://www.chesapeakebaypacking.com/buy-adapalene-gel-online.pdf buy differin cream 0.1 In a number of cases, the MDGs have already succeeded:  The number of people living on $1.25 a day, for example, was cut in half by 2010, according to the U.N. -- though most of that change was due to the massive economic transformation of China, and to a lesser extent, India.

Filename: 394439_cco.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 394452
Tên lệnh: cco%C2%A0
Nh? S?a Lisp Copy C?ng D?n Kho?ng Cách

Th? xem có ?úng ý b?n không nhé:

(defun c:cco  (/ oldos css ss p0 p1 p2 a e d)
 (defun css  (ss p0 p1 a)
  ((lambda (i / e obj o1 i)
    (while (setq e (ssname ss (setq i (1+ i))))
     (setq obj (vlax-ename->vla-object e))
     (setq o1 (vla-copy obj))
     (if p0
      (vla-move o1 (vlax-3d-point p0) (vlax-3d-point...
>>

Th? xem có ?úng ý b?n không nhé:

(defun c:cco  (/ oldos css ss p0 p1 p2 a e d)
 (defun css  (ss p0 p1 a)
  ((lambda (i / e obj o1 i)
    (while (setq e (ssname ss (setq i (1+ i))))
     (setq obj (vlax-ename->vla-object e))
     (setq o1 (vla-copy obj))
     (if p0
      (vla-move o1 (vlax-3d-point p0) (vlax-3d-point p1)))
     (vla-move o1 (vlax-3d-point p1) (vlax-3d-point (polar p1 a d))))) -1))
 (princ "\n Chon doi tuong can copy")
 (setq ss (ssget)
       p0 (getpoint "\n Chon diem chuan: ")
       p1 (getpoint p0 "\n Chon diem goc: ")
       p2 (getpoint p1 "\n Chon diem dinh huong copy: ")
       a  (angle p1 p2)
       e  (entlast))
 (or dis-copy-m (setq dis-copy-m 100))
 (while (not (eq (setq d (getdist (strcat "\n Nhap khoang cach can copy tiep theo  <" (rtos dis-copy-m)">: "))) 0))
  (if (not d)(setq d dis-copy-m)(setq dis-copy-m d))
  (css ss p0 p1 a)
  (setq ss (ssadd))
  (while (setq e (entnext e)) (setq ss (ssadd e ss)))
  (setq p0 nil
        e  (entlast)))
 (princ))

<<

Filename: 394452_cco%C2%A0.lsp
Tác giả: trinhhoanghieu090
Bài viết gốc: 333133
Tên lệnh: cpt
[Xin trợ giúp lisp] Gán nội dung từ text này sang text

Tặng bạn, mình mới viết hôm trước, lệnh CPT nhé:

(defun c:cpt ( / doithuoctinh cptext1 a b)

(defun doithuoctinh( ename dxfcode listvalue )
(entmod (subst (cons dxfcode listvalue) (assoc dxfcode (entget ename)) (entget ename)))
)
(defun cptext1 ( e_nguon e_dich / text_nguon)
    (setq    text_nguon (cdr(assoc 1 (entget e_nguon)))
    )
    (doithuoctinh e_dich 1 text_nguon)
)
    (prompt "Chon Text Nguon:")
    (while  ...
>>

Tặng bạn, mình mới viết hôm trước, lệnh CPT nhé:

(defun c:cpt ( / doithuoctinh cptext1 a b)

(defun doithuoctinh( ename dxfcode listvalue )
(entmod (subst (cons dxfcode listvalue) (assoc dxfcode (entget ename)) (entget ename)))
)
(defun cptext1 ( e_nguon e_dich / text_nguon)
    (setq    text_nguon (cdr(assoc 1 (entget e_nguon)))
    )
    (doithuoctinh e_dich 1 text_nguon)
)
    (prompt "Chon Text Nguon:")
    (while    (not
                (setq    a (ssget "_+.:E:S" '((0 . "TEXT,MTEXT"))) )
                )
        )
    (while
        (progn
            (setvar    'errno 0)
            (setq    b  (entsel "\nChon Text Dich:") )
        
            (cond
                ( (= (getvar 'errno) 7) (princ "\nBan Pick Truot, Hay Pick Lai ") )
                ( (and     b
                         (/= (cdr(assoc 0 (entget (car b)))) "TEXT")
                         (/= (cdr(assoc 0 (entget (car b)))) "MTEXT")
                        
                    )
                         (princ "\nBan Pick Nham, Hay Pick Lai ")
                )
                ( (and b
                       (OR
                        (= (cdr(assoc 0 (entget (car b)))) "TEXT")
                        (= (cdr(assoc 0 (entget (car b)))) "MTEXT")
                        )
                        (cptext1 (SSNAME a 0) (car b))
                    )
                )
                ( (not b) nil)
            )
        )
    )
)

<<

Filename: 333133_cpt.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 386329
Tên lệnh: xdtd
Lisp Xác Định Vị Trí Của Polyline

Cám ơn các bác quan tâm.

File đính kèmhttp://www.cadviet.com/upfiles/5/48467_vi_tri.dwg

Hề hề hề,

Bạn thử lisp dưới đây và lưu ý rằng nó chỉ đúng khi các polyline kín phải nằm hoàn toàn trên hoặc hoàn toàn...

>>

Cám ơn các bác quan tâm.

File đính kèmhttp://www.cadviet.com/upfiles/5/48467_vi_tri.dwg

Hề hề hề,

Bạn thử lisp dưới đây và lưu ý rằng nó chỉ đúng khi các polyline kín phải nằm hoàn toàn trên hoặc hoàn toàn dưới polyline chuẩn và thỏa các điều kiện như mình đã nói ở bài trước.

Nếu chưa đúng ý thì bạn có thể tự xem và sửa tiếp và bổ sung những điều bạn cần.

http://www.cadviet.com/upfiles/5/5194_xacdinhtrenduoi.lsp

 

Theo mình bạn nên thay (= a 0) bằng hàm (equal .....) sẽ tốt hơn bởi quá trình vẽ có thể có những sai số nhỏ mà mắt thường không nhận thấy được.

(defun c:xdtd (/ plk plc pls a ln)
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq plk (car (entsel "\n Chon pline kin"))
          plc (car (entsel "\n Chon pline chuan"))
          pls (acet-geom-vertex-list plk) 
          a 0 )
(while (and (= a 0) (setq p (car pls)))
    (command "xline" "v" p "")
    (setq ln (entlast)
              p1 (car (acet-geom-intersectwith ln plc 0))
             a (- (cadr p) (cadr p1))
             pls (cdr pls)  )
   (command "erase" ln "")
)
(if (> a 0)
    (alert "\n Polyline kin nam tren polyline chuan")
    (alert "\n Polyline kin nam duoi polyline chuan")
)
(setvar "osmode" oldos)
(princ)
)

<<

Filename: 386329_xdtd.lsp
Tác giả: mrphuocvie
Bài viết gốc: 394925
Tên lệnh: wv wh
Di Chuyển Dimension (Gần Giống Lệnh Dimspace)

Chào cadviet.com,

Hiện tại em đã viết được 2 đoạn lisp với mục đích là sắp xếp lại các dim theo tưng lớp (kiểu như lệnh DIMSPACE nhưng hiện tại chưa biết xét điều kiện để gom 2 đoạn lisp lại thành 1.

Với điều kiện là khi dim gốc có phương (của chữ số) là đứng thì dùng lệnh WV, ngang thì dùng lệnh WH, còn lại thì exit.

Nhờ mọi người giúp đỡ!

Cảm...

>>

Chào cadviet.com,

Hiện tại em đã viết được 2 đoạn lisp với mục đích là sắp xếp lại các dim theo tưng lớp (kiểu như lệnh DIMSPACE nhưng hiện tại chưa biết xét điều kiện để gom 2 đoạn lisp lại thành 1.

Với điều kiện là khi dim gốc có phương (của chữ số) là đứng thì dùng lệnh WV, ngang thì dùng lệnh WH, còn lại thì exit.

Nhờ mọi người giúp đỡ!

Cảm ơn.

(defun C:WV()
	(setvar "cmdecho" 0)	;Tat hien thi thong tin trong qua trinh chay LSP
	(setvar "osmode" 0)		;Tat che do bat diem
	(setq d_o (entsel "\nSelect orgin dimension TOP: "))
	(setq PT10 (cdr (assoc 10 (entget (car d_o))))
		xPT10 (car PT10)
		yPT10 (cadr PT10)
		dis 175)			;Thay doi gia tri cho nay
	(princ "Select dimension object: ")
	(setq ssd (ssget "_:L"'((0 . "DIMENSION"))))
	(setq i 0)
	;Bat dau vong lap
	(while (< i (sslength ssd))
		(progn
			(setq
				etname (ssname ssd i)
				ds (entget (ssname ssd i))
				PT10i (cdr (assoc 10 ds))
				xPT10i (car PT10i)
				yPT10i (cadr PT10i)
				PT10ii (list xPT10i (- yPT10 dis) 0)
				i (+ i 1))
			(command ".move" etname "" PT10i PT10ii)))
	(setvar "osmode" 4863)	;Bat che do bat diem
	(setvar "cmdecho" 1)
	(princ "\nCompleted command!")
)
;----------------
(defun C:WH()
	(setvar "cmdecho" 0)	;Tat hien thi thong tin trong qua trinh chay LSP
	(setvar "osmode" 0)		;Tat che do bat diem
	(setq PT10 (cdr (assoc 10 (entget (car (entsel "\nSelect orgin dimension LEFT: ")))))
		xPT10 (car PT10)
		yPT10 (cadr PT10)
		dis 175)			;Thay doi gia tri cho nay
	(princ "Select dimension object: ")
	(setq ssd (ssget "_:L"'((0 . "DIMENSION"))))
	(setq i 0)
	;Bat dau vong lap
	(while (< i (sslength ssd))
		(progn
			(setq
				etname (ssname ssd i)
				ds (entget (ssname ssd i))
				PT10i (cdr (assoc 10 ds))
				xPT10i (car PT10i)
				yPT10i (cadr PT10i)
				PT10ii (list (+ xPT10 dis) yPT10i 0)
				i (+ i 1))
			(command ".move" etname "" PT10i PT10ii)))
	(setvar "osmode" 4863)	;Bat che do bat diem
	(setvar "cmdecho" 1)
	(princ "\nCompleted command!")
)

<<

Filename: 394925_wv_wh.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 395141
Tên lệnh: tt%C2%A0
Xin Lips Chia Góc Thành Các Phần Bằng Nhau

Của bạn đây:

(defun c:tt  (/ Make-Line mid_point ang ang-i ang-org ang1 ang2 enl1 enl2 int len n ps1 ps2 ss1 ss2)
 (defun Make-Line (p1 p2) (entmakex (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2) (cons 62 3))))
 (defun mid_point (p1 p2) (mapcar '(lambda (a b) (* 0.5 (+ a b))) p1 p2))
 (if (and (princ "\nChon Line 1: ")
          (setq ss1 (ssget "_+.:E:S" '((0 ....
>>

Của bạn đây:

(defun c:tt  (/ Make-Line mid_point ang ang-i ang-org ang1 ang2 enl1 enl2 int len n ps1 ps2 ss1 ss2)
 (defun Make-Line (p1 p2) (entmakex (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2) (cons 62 3))))
 (defun mid_point (p1 p2) (mapcar '(lambda (a b) (* 0.5 (+ a b))) p1 p2))
 (if (and (princ "\nChon Line 1: ")
          (setq ss1 (ssget "_+.:E:S" '((0 . "LINE"))))
          (princ "\nChon Line 2: ")
          (setq ss2 (ssget "_+.:E:S" '((0 . "LINE")))))
  (progn (setq enl1 (entget (ssname ss1 0))
               enl2 (entget (ssname ss2 0))
               ps1  (list (cdr (assoc 10 enl1)) (cdr (assoc 11 enl1)))
               ps2  (list (cdr (assoc 10 enl2)) (cdr (assoc 11 enl2)))
               len  (* (+ (distance (car ps1) (cadr ps1)) (distance (car ps2) (cadr ps2))) 0.5))
         (if (setq int (inters (car ps1) (cadr ps1) (car ps2) (cadr ps2) nil))
          (progn (setq ang1 (angle int (mid_point (car ps1) (cadr ps1)))
                       ang2 (angle int (mid_point (car ps2) (cadr ps2)))
                       ang  (abs (- ang1 ang2)))
                 (if (> ang pi)
                  (progn (setq ang-org (max ang1 ang2)) (setq ang (- (* 2 pi) ang)))
                  (setq ang-org (min ang1 ang2)))
                 (or (> so_goc_can_chia 2) (setq so_goc_can_chia 2))
                 (initget 6)
                 (and (setq so_goc_can_chia (cond ((getint (strcat "\nSo luong goc can chia <" (itoa so_goc_can_chia) ">: ")))
                                                  (so_goc_can_chia)))
                      (> so_goc_can_chia 1)
                      (setq n so_goc_can_chia)
                      (setq ang-i (/ ang n))
                      (repeat (1- n) (Make-Line int (polar int (+ (* (setq n (1- n)) ang-i) ang-org) len))))))))
 (princ))

<<

Filename: 395141_tt%C2%A0.lsp
Tác giả: thangbkpro
Bài viết gốc: 115125
Tên lệnh: tkt
Viết lisp theo yêu cầu [phần 2]
Chào các bạn
Giúp mình nối 2 lip đếm text dưới đây thành một được không
1. Lip đếm text của bác gia_bach. sau khi đếm in ra table trong cad 1 cột loại text 1 cột là số lượng và 1 cột là số thứ tự

Giờ mình muốn nối thành một lip với thực hiện lệnh như sau:

select text và in ra file exel với 1 cột số thứ tự 1 cột loại text và 1 cột số lượng loại đó.
>>
Chào các bạn
Giúp mình nối 2 lip đếm text dưới đây thành một được không
1. Lip đếm text của bác gia_bach. sau khi đếm in ra table trong cad 1 cột loại text 1 cột là số lượng và 1 cột là số thứ tự

Giờ mình muốn nối thành một lip với thực hiện lệnh như sau:

select text và in ra file exel với 1 cột số thứ tự 1 cột loại text và 1 cột số lượng loại đó.

Ngoài ra mình còn muốn thống kê text vào file excel có sẵn trên ổ đĩa. Vì với một bản vẽ điện thì có rất nhiều tủ. Mình làm thống kê theo từng tủ nên tạo ra rất nhiều file exel. Nếu vẫn thống kê theo cách trên mà chỉ điền vào một file cell duy nhất tức là file exel đó đang làm đến row 17 sẽ điền tiếp vào row 18 thì tuyệt!
Many thanks!
<<

Filename: 115125_tkt.lsp
Tác giả: Superlong
Bài viết gốc: 395451
Tên lệnh: zv
[Nhờ Chỉnh Sửa] Lisp Diện Tích Xuất Kết Quả Nối Vs Text Được Chọn

 đây là lisp tính tổng diện tích mình tìm được trên forum và cải tiến lại nội dung lisp như sau : nhập cao độ text - nhập lý trình - nhập số thập phân - pick chọn các vùng cần tính diện tích - nhập số thứ tự của lần tính vì lisp này có vòng lặp .

nay mình muốn cải tiến công đoạn nhập lý trình bằng cách pick chọn text , mình dùng hàm ssget để chọn text rồi gán vào kết quả...
>>

 đây là lisp tính tổng diện tích mình tìm được trên forum và cải tiến lại nội dung lisp như sau : nhập cao độ text - nhập lý trình - nhập số thập phân - pick chọn các vùng cần tính diện tích - nhập số thứ tự của lần tính vì lisp này có vòng lặp .

nay mình muốn cải tiến công đoạn nhập lý trình bằng cách pick chọn text , mình dùng hàm ssget để chọn text rồi gán vào kết quả nhưng hệ thống báo lỗi không biết dùng hàm nào để lấy nội dung của text đây các bạn giúp mình với
VÀ mình muốn hỏi lệnh để tự gán số lớp tự động luôn đại loại nếu chưa nhập số lớp sẽ phải nhập lớp đầu tiên , khi vòng lặp thực hiện lại các bước sau thì sẽ tự + biến đó vs 1 số
đang tìm hiểu lisp và thực hành trên các lisp có sẳn của diễn đàn thấy thích quá mong là sớm được trả lời hihi

 

 

(Defun c:zv()

(setvar "cmdecho" 0)
(initget "Heso Do")
(if (not sc3) (setq sc3 2))
(setq sc1 (getreal (strcat "\n Cao text <")))
 (if (not sc1) (setq sc1 sc3) (setq sc3 sc1))
(setq sc9 (getreal (strcat "\n ly trinh <")))
(setq sc8 (strcat (rtos sc9 2 2))) 
        (if (not tp1) (setq tp1 2))
        (setq tp (getint (strcat "\n Nhap So chu so thap phan <" (itoa tp1) "> :")))
        (if (not tp) (setq tp tp1) (setq tp1 tp))
(while
(setq pt (getpoint "\n chon diem:"))
    (if (= pt "Heso")
    (progn
(setq am (getreal "\n loccoc259.co.cc : "))
(if (and (null am) (/= ac 0))
(setq am ac)
)
(setq pt (getpoint "\n Chon diem: "))
)
(setq ac am))
 
(if (or (= am 0) (null am)) (setq am 1))
(setq s 0)
(progn 
; (setq pt (getpoint "\n Chon diem: "))
     (while pt
(setq entold (cdr (assoc 5 (entget (entlast)))))
(command "boundary" pt "")
(setq entnew (cdr (assoc 5 (entget (entlast)))))
(if (/= entold entnew)    
(progn 
                        (setq entnew (entget (entlast)))
                        (if (assoc 62 entnew)
                          (setq entnew (subst (cons 62 (+ 3 (cdr (assoc 62 entnew)))) (assoc 62 entnew) entnew))
                          (setq entnew (append entnew (list (cons 62 (+ 3 (cdr (assoc 62 (tblsearch "layer" (cdr (assoc 8 
 
entnew))))))))))
                          )                          
                        (entmod entnew)
                        (Command "area" "o" (entlast))
(setq s (+ s (getvar "area")))
    (setq pt (getpoint "\n Chon diem: "))
(entdel (entlast))
        )
(progn
(princ "chon diem sai")
(setq pt (getpoint "\n Chon diem: "))
)
)
 )
 
            )
 
"(command "" "")"
 
(princ (* s am))
         (princ)
(command "insert" "D:\\Lisp CAD\\BLOCK.DWG" 0 "" "" "")
 
(setq sc4 (getreal (strcat "\n Nhap So Lop <")))
(setq sc5 (strcat (rtos sc4 2 0)))
(setq pt1 (getpoint "Chon vi tri ghi dien tich: "))
(setq dt1 (* s am 1 1))
(setq dt (/ dt1 1))
(setq dt (strcat (rtos dt 2 tp)))
 (command "INSERT" "DIENTICHL" pt1 sc1 sc1 "0" sc8 dt sc5))

)


<<

Filename: 395451_zv.lsp
Tác giả: hiepttr
Bài viết gốc: 395597
Tên lệnh: add
Đánh Dấu Điểm Trong Không Gian Cad 3D - Help....!

Hình như bạn đăng nhầm nơi (Đúng ra là phải y/c bên auto lisp)

Nhưng mình làm liều tí, đang rảnh :D

 

p/s: Trong code có sữ dụng hàm MakePoint của tác giả Thaistreetz, cảm ơn bác !

;;;lisp add point vao vi tri start & end point cua line
(defun c:ADD( / lst_va old ss point ename)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt...
>>

Hình như bạn đăng nhầm nơi (Đúng ra là phải y/c bên auto lisp)

Nhưng mình làm liều tí, đang rảnh :D

 

p/s: Trong code có sữ dụng hàm MakePoint của tác giả Thaistreetz, cảm ơn bác !

;;;lisp add point vao vi tri start & end point cua line
(defun c:ADD( / lst_va old ss point ename)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nChon (cac) line !")
(setq ss (ssget '((0 . "LINE"))))
(if ss
	(repeat (sslength ss)
		(setq point 
			(mapcar '(lambda (y) (cdr y)) 
					(vl-remove-if-not '(lambda (x) (or (= 10 (car x)) (= 11 (car x)))) (entget (setq ename (ssname ss 0))))
			) 
		)
		(mapcar '(lambda (z) (MakePoint z "Layer_add_point" 2)) point)
		(ssdel ename ss)
	)
	(princ "\nKhong chon duoc line nao !")
)
(mapcar 'setvar lst_va old)
(princ)
)
;;;================ make point
(defun MakePoint (point layer color)	
	(entmakex (list '(0 . "POINT")'(100 . "AcDbEntity")									
					(cons 8 (if Layer Layer (getvar "Clayer")))									
					(cons 62 (if Color Color 256))									
					'(100 . "AcDbPoint")(cons 10 point))))

<<

Filename: 395597_add.lsp
Tác giả: Superlong
Bài viết gốc: 395627
Tên lệnh: tdt
Nhờ Sửa Cách Tính Diện Tích Của Lisp (Từ Tạo Boundary Thành Hatch)

 

 

đây là lisp độ lại từ lisp của diễn đàn tính diện tích cho trắc ngang theo lớp có phân biệt lý trình  tuy nhiên cách tính diện tích của lisp này là tạo boundary mình muốn nhờ sửa lại cách tính diện tích = hatch  và giữ lại vùng hatch đó luôn để sau này tiện đối chiếu khối lượng với tư vấn giám sát vì nếu tính...
>>

 

 

đây là lisp độ lại từ lisp của diễn đàn tính diện tích cho trắc ngang theo lớp có phân biệt lý trình  tuy nhiên cách tính diện tích của lisp này là tạo boundary mình muốn nhờ sửa lại cách tính diện tích = hatch  và giữ lại vùng hatch đó luôn để sau này tiện đối chiếu khối lượng với tư vấn giám sát vì nếu tính theo cách tạo boundary nếu giữ lại các đường bao thì khi pick nhìu vùng thì nó tạo các đường bao độc lập sau này tư vấn nó kiểm tra phải cộng lại còn hatch nó đồng nhất kiểm tra tiện hơn
 

(Defun c:tdt()
(setvar "cmdecho" 0)
(initget "Heso Do")
(setq
cn (getstring "\nNh\U+1EADp th\U+1EE9 t\U+1EF1 l\U+1EDBp <1>: " T))
(if (not sc3) (setq sc3 2))
(setq sc1 (getreal (strcat "\nChi\U+1EC1u cao Text <")))
(if (not sc1) (setq sc1 sc3) (setq sc3 sc1))
(setq sc9 (cdr (assoc 1 (entget (car (entsel "\nChon Text Ly Trinh: "))))))
(if (not dn) (setq dn 1))
(if (= cn "") (setq cn "0"))
(setq c (vl-string-right-trim "0 1 2 3 4 5 6 7 8 9" cn))
(setq n (vl-string-subst "" c cn))

(while
(setq pt (getpoint "\n chon diem:"))
(if (= pt "Heso")
(progn
(setq am (getreal "\n loccoc259.co.cc : "))
(if (and (null am) (/= ac 0))
(setq am ac)
)
(setq pt (getpoint "\n Chon diem: "))
)
(setq ac am))

(if (or (= am 0) (null am)) (setq am 1))
(setq s 0)
(progn
; (setq pt (getpoint "\n Chon diem: "))
(while pt
(setq entold (cdr (assoc 5 (entget (entlast)))))
(command "BOUNDARY" pt "")
(setq entnew (cdr (assoc 5 (entget (entlast)))))
(if (/= entold entnew)
(progn
(setq entnew (entget (entlast)))
(if (assoc 62 entnew)
(setq entnew (subst (cons 62 (+ 3 (cdr (assoc 62 entnew)))) (assoc 62 entnew) entnew))
(setq entnew (append entnew (list (cons 62 (+ 3 (cdr (assoc 62 (tblsearch "layer" (cdr (assoc 8

entnew))))))))))
)
(entmod entnew)
(Command "area" "o" (entlast))
(setq s (+ s (getvar "area")))
(setq pt (getpoint "\n Chon diem: "))
(entdel (entlast))
)
(progn
(princ "chon diem sai")
(setq pt (getpoint "\n Chon diem: "))
)
)
)

)

"(command "" "")"

(princ (* s am))
(princ)
(if (not (tblsearch "block" "DIENTICHL"))
(progn (command "insert" "D:\\Lisp CAD\\BLOCK.dwg" 0 "" "" "")
(command "erase" (entlast) "")))
(setq p (getpoint "\n\U+0110i\U+1EC3m ch\U+00E8n : "))
(if (= n "")
(setq cn (incC cn))
(setq cn (strcat c (incN (vl-string-subst "" c cn) dn)))
)
(setq
dat (entget (entlast))
dat (subst (cons 1 cn) (assoc 1 dat) dat)
)
(setq dt1 (* s am 1 1))
(setq dt (/ dt1 1))
(setq dt (strcat (rtos dt 2 3)))
(command "INSERT" "DIENTICHL" p sc1 sc1 "0" sc9 cn dt)
)
)

)


<<

Filename: 395627_tdt.lsp
Tác giả: Superlong
Bài viết gốc: 395691
Tên lệnh: zx
chỉ giùm cách lấy điểm là các đỉnh của hình chữ nhật

 cám ơn bác doan van ha em thành công rồi

 

(defun DXF (code elist)
(cdr (assoc code elist))
)

(defun c:ZX(/ dt tenfile f lst lst2 i ls )
(if (not scale) (setq scale 1))
(setq sc1 (getreal (strcat "\n Cao text <"(rtos scale 2 0)">:")))
(if sc1 (setq scale sc1))
(setq sc9 (cdr (assoc 1 (entget (car (entsel "\nChon Text Ly Trinh : "))))))
(setq p (getpoint "\nChon tim trac ngang: "))
(setq TX (Car P))
(setq TY...

>>

 cám ơn bác doan van ha em thành công rồi

 

(defun DXF (code elist)
(cdr (assoc code elist))
)

(defun c:ZX(/ dt tenfile f lst lst2 i ls )
(if (not scale) (setq scale 1))
(setq sc1 (getreal (strcat "\n Cao text <"(rtos scale 2 0)">:")))
(if sc1 (setq scale sc1))
(setq sc9 (cdr (assoc 1 (entget (car (entsel "\nChon Text Ly Trinh : "))))))
(setq p (getpoint "\nChon tim trac ngang: "))
(setq TX (Car P))
(setq TY (Cadr P))
(setq ed (entget (car (entsel "\nChon cao do tim : "))))
(setq H0 (read (DXF 1 ed)))
(setq ATLAST (getvar "Attreq"))
(setq dt (ssget '((0 . "LWPOLYLINE")))
sdt (sslength dt)
i 0)

(repeat sdt
(setq dt1 (ssname dt i)
i (1+ i)
rec (acet-geom-vertex-list dt1))
(setq x1 (car (nth 0 Rec))
y1 (cadr (nth 0 Rec))
x2 (car (nth 1 Rec))
y2 (cadr (nth 1 Rec))
x3 (car (nth 2 Rec))
y3 (cadr (nth 2 Rec))
)
(setq kc1 (rtos (- x1 tx) 2 2))
(setq kc2 (rtos (- x3 tx) 2 2))
(setq kctim (rtos (- x2 tx) 2 2))
(setq cd1 (rtos (abs (+ (- y1 ty) H0)) 2 2))
(setq cdtim (rtos (abs (+ (- y2 ty) H0)) 2 2))
(setq cd2 (rtos (abs (+ (- y3 ty) H0)) 2 2))
(setvar "attreq" 1)

(if (not (tblsearch "block" "dimTN"))
(progn (command "insert" "D:\\Lisp CAD\\BLOCK.dwg" 0 "" "" "")
(command "erase" (entlast) "")))
(if (> kc1 KC2) (command "INSERT" "dimTN" (nth 2 rec) scale scale 0 sc9 CD2 KC2 cdtim kctim CD1 KC1))

(if (< kc1 KC2) (command "INSERT" "dimTN" (nth 0 rec) scale scale 0 sc9 CD1 KC1 cdtim kctim CD2 KC2))
))

bác cho em hỏi thêm có cách nào sắp xếp các phần tử trong danh sách được chọn theo thứ tự từ lớn tới nhỏ không VD sau khi chọn 5 pline và dùng cadr lọc ra 5 tung độ rồi thì sẽ sắp xếp 5 tung độ đó theo thứ tự từ lớn tới nhỏ để đặt tên từ y1-y5 chứ không phải theo thứ tự chọn


<<

Filename: 395691_zx.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 396190
Tên lệnh: tt%C2%A0
Lisp điền cao độ bị lỗi!!!

Bạn thử cái này xem:

(defun c:tt  (/ xuat_kq elv ent lsp lst-l lst-r lsw txt x y sep)
 (defun xuat_kq  (str lst / filename fn i)
  (setq i 1)
  (setq filename (strcat (getvar 'dwgprefix) (getvar 'dwgname) ".txt"))
  (or (findfile fileName) (progn (setq fn (open fileName "w")) (close fn)))
  (setq fn (open fileName "a"))
  (princ (strcat "\n" (write-line str fn)))
  (foreach x ...
>>

Bạn thử cái này xem:

(defun c:tt  (/ xuat_kq elv ent lsp lst-l lst-r lsw txt x y sep)
 (defun xuat_kq  (str lst / filename fn i)
  (setq i 1)
  (setq filename (strcat (getvar 'dwgprefix) (getvar 'dwgname) ".txt"))
  (or (findfile fileName) (progn (setq fn (open fileName "w")) (close fn)))
  (setq fn (open fileName "a"))
  (princ (strcat "\n" (write-line str fn)))
  (foreach x  lst
   (princ (strcat "\n" (write-line (strcat (itoa i) sep (car x) sep (cadr x)) fn)))
   (setq i (1+ i)))
  (close fn))
 (setq sep "\t")
 (while (and (setq ent (car (entsel "\nChon Pline trac ngang: ")))
             (wcmatch (cdr (assoc 0 (entget ent))) "*POLYLINE")
             (not (redraw ent 3))
             (setq txt (car (entsel "\nChon Text cao do tim duong: ")))
             (wcmatch (cdr (assoc 0 (entget txt))) "*TEXT")
             (not (redraw ent 4))
             (setq elv (distof (cdr (assoc 1 (entget txt))) 2)))
  (setq lsp (acet-geom-vertex-list ent))
  (foreach pt  lsp
   (setq x (car pt)
         y (+ (cadr pt) elv))
   (cond ((< x 0) (setq lst-l (cons (list (rtos (abs x) 2 2) (rtos y 2 2)) lst-l)))
         ((> x 0) (setq lst-r (cons (list (rtos x 2 2) (rtos y 2 2)) lst-r)))))
  (xuat_kq (strcat "\nSTT" sep "K.cach" sep "Cao do\nBen trai:") lst-l)
  (xuat_kq "Ben phai:" (reverse lst-r))
  (setq lst-l nil
        lst-r nil))
(and ent (redraw ent 4))
 (princ "\nLisp created By QuocManh04tt-CadViet.com!")
 (princ))

P/s:

1​. Lsp xuất ra file .txt nằm cùng thư mục với file .dwg hiện hành.

2. Muốn xuất file .csv thì tìm trong lsp thay ".txt" bằng ".csv", ngăn cách giữa STT, K.cach, caodo bằng dấu ";" thì thay dòng:  (setq sep "\t") bằng dòng này:  (setq sep ";").

3. => Copy sẽ tốt hơn download ...


<<

Filename: 396190_tt%C2%A0.lsp

Trang 202/330

202