Jump to content
InfoFile
Tác giả: thehost31
Bài viết gốc: 233290
Tên lệnh: ktcot col
10- LTRUC : lệnh chèn cột vào lưới trục (như Revit)

Của bạn đây. Thêm hacth và vẽ khác đi cho các trục biên. Do có tính đến trường hợp trục nghêng nên hơi nhức đầu :). nhưng chắc thực tế thì không có trường hợp trục nghiêng. Cách dùng như cũ nhé. Code mình hơi dài, luộm thuộm do trình độ còn kém nhắm.

 

(defun Str_Split(Root_string separate / Sep_len Olist temp_str si stri)
(setq Sep_len (strlen separate)
Olist '()
temp_str ""
si...

>>

Của bạn đây. Thêm hacth và vẽ khác đi cho các trục biên. Do có tính đến trường hợp trục nghêng nên hơi nhức đầu :). nhưng chắc thực tế thì không có trường hợp trục nghiêng. Cách dùng như cũ nhé. Code mình hơi dài, luộm thuộm do trình độ còn kém nhắm.

 

(defun Str_Split(Root_string separate / Sep_len Olist temp_str si stri)
(setq Sep_len (strlen separate)
Olist '()
temp_str ""
si 1
)
(while (<= si (strlen Root_string))
(setq stri (substr Root_string si Sep_len))
(if (= stri separate)
(setq Olist (append Olist (list temp_str))
temp_str ""
si (+ si Sep_len -1)
)
(setq temp_str (strcat temp_str (substr Root_string si 1)))
)
(setq si (1+ si))
)
(setq Olist (append Olist (list temp_str)))
)
;==============================================================
(defun Get-intesect(ent1 ent2 Extend / obj1 obj2 inter Out Cnt)
(vl-load-com)
(setq obj1 (vlax-ename->vla-object ent1)
obj2 (vlax-ename->vla-object ent2)
)
(if Extend
(setq inter (vlax-variant-value (vla-IntersectWith obj1 obj2 acExtendBoth)))
(setq inter (vlax-variant-value (vla-IntersectWith obj1 obj2 acExtendNone)))
)
(if (/= (vlax-safearray-get-u-bound inter 1) -1)
(setq inter (vlax-safearray->list inter))
(setq inter nil)
)
(if inter
(progn
(setq Cnt (fix (/ (length inter) 3)) Out nil)
(repeat Cnt (setq Out (append Out (list (list (car inter) (cadr inter) (caddr inter)))) inter (cdddr inter)))
)
(setq Out nil)
)
Out
)
;==============================================================
(defun C:ktcot(/ ktc_string)
(setq ktc_string (getstring "\nKích th\U+01B0\U+1EDBc c\U+1ED9t: "))
(setq #KT_list (STR_SPLIT ktc_string "x")
#KT_list (mapcar 'atof #KT_list)
)
(setq check nil)
(if (/= (length #KT_list) 2)
(setq check T)
(if (OR (<= (car #KT_list) 0.0) (<= (cadr #KT_list) 0.0))
(setq check T)
)
)
(if check
(progn (princ "\nVui lòng nh\U+1EADp l\U+1EA1i.") (C:ktcot))
)
(princ)
(princ)
)
;==============================================================
(defun Add_Hatch(poly Htype / mspace)
(vl-load-com)
(setq mspace (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-Acad-Object))))
(setq hatch (vla-AddHatch mspace acHatchPatternTypePreDefined Htype :vlax-True))
(vlax-invoke hatch 'AppendOuterLoop (list poly))
(vla-evaluate hatch)
)
;==============================================================
(defun Draw_colunm(Glist / ngang doc ptt1 ptt2 p1 p2 p3 p4 mspace ptlist tmp poly)
(setq ngang (car #KT_list)
doc (cadr #KT_list)
)
(setq mode (car Glist)
Ang (cadr Glist)
pt (caddr Glist)
)
(cond
((= mode 1)
(setq p1 pt
p2 (polar p1 Ang doc)
p3 (polar p2 (+ Ang (* 0.5 pi)) ngang)
p4 (polar p1 (+ Ang (* 0.5 pi)) ngang)
)
)
((= mode 2)
(setq p1 pt
p2 (polar p1 Ang doc)
p3 (polar p2 (- Ang (* 0.5 pi)) ngang)
p4 (polar p1 (- Ang (* 0.5 pi)) ngang)
)
)
((= mode 3)
(setq p1 (polar pt (+ Ang (* 0.5 pi)) (* 0.5 ngang))
p4 (polar pt (- Ang (* 0.5 pi)) (* 0.5 ngang))
p2 (polar p1 Ang doc)
p3 (polar p4 Ang doc)
)
)
((= mode 4)
(setq p1 (polar pt (- Ang pi) (* 0.5 doc))
p4 (polar pt Ang (* 0.5 doc))
p2 (polar p1 (+ Ang (* 0.5 pi)) ngang)
p3 (polar p4 (+ Ang (* 0.5 pi)) ngang)
)
)
((= mode 5)
(setq p1 (polar pt (- Ang pi) (* 0.5 doc))
p4 (polar pt Ang (* 0.5 doc))
p2 (polar p1 (- Ang (* 0.5 pi)) ngang)
p3 (polar p4 (- Ang (* 0.5 pi)) ngang)
)
)
((= mode 6)
(setq p1 pt
p2 (polar p1 (- Ang pi) doc)
p3 (polar p2 (+ Ang (* 0.5 pi)) ngang)
p4 (polar p1 (+ Ang (* 0.5 pi)) ngang)
)
)
((= mode 7)
(setq p1 pt
p2 (polar p1 (- Ang pi) doc)
p3 (polar p2 (- Ang (* 0.5 pi)) ngang)
p4 (polar p1 (- Ang (* 0.5 pi)) ngang)
)
)
((= mode 8)
(setq p1 (polar pt (- Ang (* 0.5 pi)) (* 0.5 ngang))
p4 (polar pt (+ Ang (* 0.5 pi)) (* 0.5 ngang))
p2 (polar p1 (- Ang pi) doc)
p3 (polar p4 (- Ang pi) doc)
)
)
((= mode 9)
(setq ptt1 (polar pt Ang (* 0.5 doc))
p1 (polar ptt1 (+ Ang (* 0.5 pi)) (* 0.5 ngang))
p2 (polar ptt1 (- Ang (* 0.5 pi)) (* 0.5 ngang))
ptt2 (polar pt (- Ang pi) (* 0.5 doc))
p3 (polar ptt2 (- Ang (* 0.5 pi)) (* 0.5 ngang))
p4 (polar ptt2 (+ Ang (* 0.5 pi)) (* 0.5 ngang))
)
)
)
(setq mspace (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
(setq ptlist (apply 'append (list p1 p2 p3 p4 p1)))
(if (= (rem (length ptlist) 3) 0)
(progn
(setq tmp (vlax-make-safearray vlax-vbDouble (cons 0 (- (length ptlist) 1))))
(vlax-safearray-fill tmp ptlist)
(setq poly (vla-addPolyline mspace tmp))
(ADD_HATCH poly "Solid")
)
)
)
;==============================================================
(defun Cal_A(P1 P2 / x1 y1 x2 y2)
(setq x1 (car P1)
y1 (cadr P1)
x2 (car P2)
y2 (cadr P2)
)
(if (= (- x2 x1) 0.0)
y1
(/ (- y2 y1) (- x2 x1))
)
)
;==============================================================
(defun Cal_B(P1 P2 / x1 y1 x2 y2)
(setq x1 (car P1)
y1 (cadr P1)
x2 (car P2)
y2 (cadr P2)
)
(if (= (- x2 x1) 0.0)
x1
(/ (- (* x2 y1) (* x1 y2)) (- x2 x1))
)
)
;==============================================================
(defun Sort_Line(Lename_list / temp_list)
(setq temp_list (mapcar '(lambda (x) (list (Cal_B (cdr (assoc 10 (entget x))) (cdr (assoc 11 (entget x)))) x)) Lename_list))
(setq temp_list (vl-sort temp_list '(lambda (e1 e2) (> (car e1) (car e2)))))
(mapcar '(lambda (x) (cadr x)) temp_list)
)
;==============================================================
(defun c:col(/ ssgrid Lename_list si temp_list luoi1 A1 luoi2 A Lename ss1 ss2
min1 max1 min2 max2 pp1 pp2 goc Gp_list l1i l2j mode giao)
(if (not #KT_list) (C:KTCOT))
(setq ssgrid (ssget '((0 . "LINE"))))
(setq Lename_list '()
si 0
)
(while (< si (sslength ssgrid))
(setq Lename_list (append Lename_list (list (ssname ssgrid si))))
(setq si (1+ si))
)
(setq temp_list (mapcar '(lambda (x) (list (Cal_A (cdr (assoc 10 (entget x))) (cdr (assoc 11 (entget x)))) x)) Lename_list))
(setq luoi1 (list (cadr (nth 0 temp_list)))
A1 (car (nth 0 temp_list))
luoi2 '()
si 1
)
(while (< si (length temp_list))
(setq A (car (nth si temp_list))
Lename (cadr (nth si temp_list))
)
(if (eq (rtos (- A A1) 2 2) "0.00")
(setq luoi1 (append luoi1 (list Lename)))
(setq luoi2 (append luoi2 (list Lename)))
)
(setq si (1+ si))
)

(setq luoi1 (Sort_line luoi1)
luoi2 (Sort_line luoi2)
)
(setq ss1 (ssadd) ss1 (mapcar '(lambda (x) (ssadd x ss1)) luoi1))
(setq ss2 (ssadd) ss2 (mapcar '(lambda (x) (ssadd x ss2)) luoi2))
(setq
min1 (car luoi1)
max1 (car (reverse luoi1))
min2 (car luoi2)
max2 (car (reverse luoi2))
pp1 (car (GET-INTESECT min1 min2 nil))
pp2 (car (GET-INTESECT max1 min2 nil))
goc (angle pp1 pp2)
si 0
Gp_list '()
)
(if (> (car (cdr (assoc 10 (entget min2)))) (car (cdr (assoc 10 (entget max2)))))
(setq luoi2 (reverse luoi2)
min2 (car luoi2)
max2 (car (reverse luoi2))
pp1 (car (GET-INTESECT min1 min2 nil))
pp2 (car (GET-INTESECT max1 min2 nil))
goc (angle pp1 pp2)
)
)
(while (< si (length luoi1))
(setq l1i (nth si luoi1) sj 0)
(while (< sj (length luoi2))
(setq l2j (nth sj luoi2))
(if (eq l1i min1)
(if (eq l2j min2)
(setq mode 1)
(if (eq l2j max2)
(setq mode 2)
(setq mode 3)
)
)
(if (eq l1i max1)
(if (eq l2j min2)
(setq mode 6)
(if (eq l2j max2)
(setq mode 7)
(setq mode 8)
)
)
(if (eq l2j min2)
(setq mode 4)
(if (eq l2j max2)
(setq mode 5)
(setq mode 9)
)
)
)
)
(setq giao (car (GET-INTESECT l1i l2j nil)))
(setq Gp_list (append Gp_list (list (list mode goc giao))))
(setq sj (1+ sj))
)
(setq si (1+ si))
)
(setq si 0)
(while (< si (length Gp_list))
(DRAW_COLUNM (nth si Gp_list))
(setq si (1+ si))
)
(princ)
(princ)
)


<<

Filename: 233290_ktcot_col.lsp
Tác giả: KangKung
Bài viết gốc: 233302
Tên lệnh: cmb
chuyển các đối tượng trong block về cùng 1 layer

bác kang cho mình hỏi , mình chỉ muốn chuyển 1 số block được chọn trong bản vẽ thui chứ không muốn chuyển hết các block và các màu đều chuyển về by layer của block đó thì làm thế nào ? thanks bác nhìu

Không muốn chuyển hết mà chỉ muốn chuyển một số block thì bạn dùng Lisp này xem...

>>

bác kang cho mình hỏi , mình chỉ muốn chuyển 1 số block được chọn trong bản vẽ thui chứ không muốn chuyển hết các block và các màu đều chuyển về by layer của block đó thì làm thế nào ? thanks bác nhìu

Không muốn chuyển hết mà chỉ muốn chuyển một số block thì bạn dùng Lisp này xem sao. 

Cách dùng: Lệnh CMB, sau đó chọn những Block cần chuyển.

;========LISP DOI MAU DOI TUONG TRONG BLOCK==========
;===============KANGKUNG 28/04/2013==================
(defun C:CMB( / i taphop lst blocklist)
  (vl-load-com)
  (command "UNDO" "BE")
  (princ "\n Chon Block can chuyen mau: ")
  (setq taphop(ssget '((0 . "INSERT"))))
  (setq i 0 lst(list))
  (while (< i (sslength taphop))
    (setq lst(append lst (list (cdr(assoc 2 (entget(ssname taphop i)))))))
    (setq i (1+ i)))
  (setq blocklist (list))
  (vlax-for for-item (vla-get-blocks(vla-get-activedocument(vlax-get-acad-object)))
    (if (/= (vl-position (vla-get-name for-item) lst) nil)
      (setq blocklist (append blocklist (list for-item)))
      )
    )
  (foreach block blocklist
    (vlax-for aa block
      (vla-put-color aa 256)
      )
    )
  (command "REGEN")
  (command "UNDO" "END")
  (princ)
  )
(princ "\n               KangKung - 28/04/2013\n")
(princ "\n           Nhap CMB de chay chuong trinh\n")

<<

Filename: 233302_cmb.lsp
Tác giả: thehost31
Bài viết gốc: 233306
Tên lệnh: cblay
chuyển các đối tượng trong block về cùng 1 layer

Cái này không biết đúng ý bạn chưa? tớ không dùng các hàm mở rộng của Vlisp. Và có tác dụng cho cả các block lồng nhau bao nhiêu lần cũng được. Cái này chỉ cần dùng đệ quy cho các sub entity nếu kiểm tra dxf 0 là INSERT.

 

(defun c:cblay(/ ssb blist si bi Dtype i)
(prompt "\nCh\U+1ECDn \U+0111\U+1ED1i t\U+01B0\U+1EE3ng Block c\U+1EA7n chuy\U+1EC3n layer:")
(setq ssb (ssget '((0 . "INSERT"))))
(setq blist '()...

>>

Cái này không biết đúng ý bạn chưa? tớ không dùng các hàm mở rộng của Vlisp. Và có tác dụng cho cả các block lồng nhau bao nhiêu lần cũng được. Cái này chỉ cần dùng đệ quy cho các sub entity nếu kiểm tra dxf 0 là INSERT.

 

(defun c:cblay(/ ssb blist si bi Dtype i)
(prompt "\nCh\U+1ECDn \U+0111\U+1ED1i t\U+01B0\U+1EE3ng Block c\U+1EA7n chuy\U+1EC3n layer:")
(setq ssb (ssget '((0 . "INSERT"))))
(setq blist '() si 0)
(while (< si (sslength ssb))
(setq blist (append blist (list (list (cdr (assoc 2 (entget (ssname ssb si)))) (ssname ssb si)))))
(setq si (1+ si))
)
(setq Dtype '())
(while blist
(setq Dtype (append Dtype (list (car blist))))
(setq blist (vl-remove-if '(lambda (x) (= (car x) (car (car blist)))) blist))
)
(setq i 0)
(while (< i (length Dtype))
(setq bi (cadr (nth i Dtype)))
(ChangeSubLayer bi)
(setq i (1+ i))
)
(command "regen" ^C^C)
(princ)
(princ)
)
;=======================================================
(defun ChangeSubLayer (Ent / EntLst Layer Ename EntLst SubEnt SubEntLst SubLayer)
(setq EntLst (entget Ent))
(if (equal "INSERT" (cdr (assoc 0 EntLst)))
(progn
(setq Layer (cdr (assoc 8 EntLst)))
(setq Ename (tblobjname "block" (cdr (assoc 2 EntLst))))
(setq EntLst (entget Ename))
(setq SubEnt (entnext Ename))
(while SubEnt
(setq SubEntLst (entget SubEnt))
(setq SubLayer (cdr (assoc 8 SubEntLst)))
(if (/= Layer SubLayer)
(progn
(setq SubEntLst (subst (cons 8 Layer) (cons 8 SubLayer) SubEntLst))
(entmod SubEntLst)
)
)
(if (= (cdr (assoc 0 (entget SubEnt))) "INSERT")
(ChangeSubLayer SubEnt)
)
(setq SubEnt (entnext SubEnt))
)
)
)
(princ)
)


<<

Filename: 233306_cblay.lsp
Tác giả: dothanhdatvtchd
Bài viết gốc: 220108
Tên lệnh: ll lgt lc ln lh l%2F lmh
Lisp link chiều dài đối tượng đến text

Em muốn nhờ các bác sửa giùm lisp "LL" _ link chiều dài đối tượng đến text.
Yêu cầu:
1. Sau khi chọn đối tượng cần tính chiều dài thì hiện thông báo hỏi: "Nhập số cần cộng thêm" để mình nhập vào, Sau đó chọn text đích. text đích sẽ hiển thị kết quả là chiều dài của đối tượng + số đã nhập.
Khi chiều dài đối tượng thay đổi, text đích thay đổi...
>>
Em muốn nhờ các bác sửa giùm lisp "LL" _ link chiều dài đối tượng đến text.
Yêu cầu:
1. Sau khi chọn đối tượng cần tính chiều dài thì hiện thông báo hỏi: "Nhập số cần cộng thêm" để mình nhập vào, Sau đó chọn text đích. text đích sẽ hiển thị kết quả là chiều dài của đối tượng + số đã nhập.
Khi chiều dài đối tượng thay đổi, text đích thay đổi theo.
2. (yêu cầu thêm, không liên quan đến yêu cầu 1, bác nào giúp em được thì tốt) Lisp này chỉ link chiều dài 1 đối tượng được chọn chứ không thể chọn nhiều đối tượng để tính tổng chiều dài, các bác cho em hỏi có thể link tổng chiều dài các đối tượng đã chọn đến text được không, khi 1 đối tượng thay đổi thì tất nhiên tổng chiều dài thay đổi và text cũng tự thay đổi theo.
Cảm ơn các bác nhiều
Lisp: http://www.cadviet.c...ln_lh_l_lmh.lsp

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=40442&pid=76557&st=0&#entry76557
;;;====================================================================


========================
;;;-------------------LINK GIA TRI CUA DOI TUONG NAY DEN DOI TUONG TEXT KHAC (>=cad2006)-------------------
;;;=============================================================================


===============
(vl-load-com)
;;;----------------------------------------
;;;LINK CHIEU DAI
(defun C:LL (/ obn Tkq)
(START_PG)
(setq obn (vlax-ename->vla-object (car (entsel "\nChon doi tuong nguon")))
obd (vlax-ename->vla-object (car (nentsel "\nChon text ghi chieu dai")))
ltr (I_INT0 "\n Nhap chu so lam tron" ltr)
hso (I_REAL "\n Nhap he so nhan" hso)
Tkq (strcat "%<\\AcObjProp Object(%<\\_ObjId "
(rtos (vla-get-objectid obn) 2 0)">%).Length \\f \"%lu2"
"%pr" (rtos ltr 2 0) "%ct8" "\">%"
)
;ida (strcat "%<\\AcObjProp.16.2 Object(%<\\_ObjId "
;(rtos (vla-get-objectid obn) 2 0) ">%).Length \\f \"%lu2%pr2%ct8\">%")
;ew (vlax-vla-object->ename (vla-objectidtoobject (vla-get-activedocument (vlax-get-acad-object))
;(vla-get-ownerid obd)))
)
(vla-put-textstring obd Tkq)
;(redraw ew 3)
;(entupd ew)
;(vla-update obw)
(vl-cmdf "regen")
(END_PG)
(princ)
)
;;;----------------------------------------
;;;LINK GIA TRI
(defun C:LGT (/ obn Tkq)
(START_PG)
(setq obn (vlax-ename->vla-object (car (nentsel "\nChon doi tuong nguon")))
obd (vlax-ename->vla-object (car (nentsel "\nChon text dich")))
Tkq (strcat "%<\\AcObjProp Object(%<\\_ObjId "
(rtos (vla-get-objectid obn) 2 0)
">%).TextString>%"
)
)
(vla-put-textstring obd Tkq)
(vla-update obd)
(vl-cmdf "regen")
(END_PG)
(princ)
)
;;;----------------------------------------
;;;LINK TONG
(defun C:LC (/ obn Lob Tgt)
(START_PG)
(setq ltr (I_INT0 "\n Nhap chu so lam tron" ltr)
Tgt "%<\\AcExpr (0")
(foreach obn (setq Lob (ES_ENT_LMP "\nChon cac Gia tri can tinh tong/ENTER de ket thuc chon..."))
(setq Tgt (strcat Tgt "+"
"%<\\AcObjProp Object(%<\\_ObjId "
(rtos (vla-get-objectid (vlax-ename->vla-object obn)) 2 0)
">%).TextString>%"
)
)
)
(setq Tgt (strcat Tgt ") \\f \"%lu2%pr" (itoa ltr) "\">%"))
(EX_VALUE_T_P_L Tgt (car Lob))
(vl-cmdf "regen")
(END_PG)
(princ)
)
;;;----------------------------------------
;;;LINK TICH
(defun C:LN (/ Tgt obn Lob)
(START_PG)
(setq ltr (I_INT0 "\n Nhap chu so lam tron" ltr)
Tgt "%<\\AcExpr (1")
(foreach obn (setq Lob (ES_ENT_LMP "\nChon cac Gia tri can tinh tich/ENTER de ket thuc chon..."))
(setq Tgt (strcat Tgt "*"
"%<\\AcObjProp Object(%<\\_ObjId "
(rtos (vla-get-objectid (vlax-ename->vla-object obn)) 2 0)
">%).TextString>%"
)
)
)
(setq Tgt (strcat Tgt ") \\f \"%lu2%pr" (itoa ltr) "\">%"))
(EX_VALUE_T_P_L Tgt (car Lob))
(vl-cmdf "regen")
(END_PG)
(princ)
)
;;;----------------------------------------
;;;LINK HIEU
(defun C:LH (/ Tgt ent1 ent2)
(START_PG)
(setq ltr (I_INT0 "\n Nhap chu so lam tron" ltr))
(while (null (setq ss1 (ES_TM&D "\n Chon so bi tru..."))))
(while (null (setq ss2 (ES_TM&D "\n Chon so tru..."))))
(setq ent1 (car (C_S2L ss1))
ent2 (car (C_S2L ss2))
)
(setq Tgt (strcat "%<\\AcExpr ("
"%<\\AcObjProp Object(%<\\_ObjId "
(rtos (vla-get-objectid (vlax-ename->vla-object ent1)) 2 0)
">%).TextString>%"
"-" "%<\\AcObjProp Object(%<\\_ObjId "
(rtos (vla-get-objectid (vlax-ename->vla-object ent2)) 2 0)
">%).TextString>%" ") \\f \"%lu2%pr" (itoa ltr) "\"" ">%"
)
)
(EX_VALUE_T_P_L Tgt ent1)
(vl-cmdf "regen")
(END_PG)
(princ)
)
;;;----------------------------------------
;;;LINK CHIA
(defun C:L/ (/ Tgt ent1 ent2)
(START_PG)
(setq ltr (I_INT0 "\n Nhap chu so lam tron" ltr))
(while (null (setq ss1 (ES_TM&D "\n Chon so BI CHIA..."))))
(while (null (setq ss2 (ES_TM&D "\n Chon so CHIA.."))))
(setq ent1 (car (C_S2L ss1))
ent2 (car (C_S2L ss2))
)
(setq Tgt (strcat "%<\\AcExpr ("
"%<\\AcObjProp Object(%<\\_ObjId "
(rtos (vla-get-objectid (vlax-ename->vla-object ent1)) 2 0)
">%).TextString>%" "/"
"%<\\AcObjProp Object(%<\\_ObjId "
(rtos (vla-get-objectid (vlax-ename->vla-object ent2)) 2 0)
">%).TextString>%" ") \\f \"%lu2%pr" (itoa ltr) "\"" ">%"
)
)
(EX_VALUE_T_P_L Tgt ent1)
(vl-cmdf "regen")
(END_PG)
(princ)
)
;;;----------------------------------------
;;;LINK TONG
(defun C:LMH (/ Lst1 Lst2 Lst3 Tgt dem pt1 ob Tj) ;;;Link Multi Hang
(START_PG)
(setq 42pan (I_KEY "\n Tinh Cong/Nhan/CHia <C/N/CH>" "C N CH" 42pan)
ltr (I_INT0 "\n Nhap chu so lam tron" ltr)
hso (I_REAL "\n Nhap he so nhan" hso)
Lst1 (OD_SSY_DES_L (C_S2L (ES_TM "\nChon cot thu nhat...")))
Lst2 (OD_SSY_DES_L (C_S2L (ES_TM "\nChon cot thu hai...")))
Lst3 (OD_SSY_DES_L (C_S2L (S_TM "\nChon cot ket qua/ENTER de xuat ke qua...")))
Tgt "%<\\AcExpr (0"
dem 0
)
(if (null Lst3)
(while (null (setq pt1 (getpoint "\n X dat cot: "))))
)
(if (/= (length Lst1) (length Lst2))
(progn
(alert "So hang cua 2 cot khong bang nhau. Chon lai")
(exit)
)
)
(repeat (length Lst1)
(setq ent1 (nth dem Lst1)
ent2 (nth dem Lst2)
)
(if Lst3
(setq ent3 (nth dem Lst3))
(setq ent3 nil)
)
(setq dem (1+ dem))
(cond ( (= 42pan "C")
(setq Tgt (CALC_LINK ent1 ent2 "+" ltr hso))
)
( (= 42pan "N")
(setq Tgt (CALC_LINK ent1 ent2 "*" ltr hso))
)
( (= 42pan "CH")
(setq Tgt (CALC_LINK ent1 ent2 "/" ltr hso))
)
)
(if (/= ent3 nil)
(progn
(setq ob (entget ent3))
(entmod (subst (cons 1 Tgt) (assoc 1 ob) ob))
)
(progn
(if (and (= (cadr (assoc 11 (entget ent1))) 0.0)
(= (caddr (assoc 11 (entget ent1))) 0.0)
)
(setq Tj 10)
(setq Tj 11)
)
(setq ent1 (entget ent1)
pt1 (list (car pt1) (caddr (assoc Tj ent1)))
)
(entmakex (list '(0 . "TEXT")
'(100 . "AcDbEntity")
(assoc 8 ent1)
'(100 . "AcDbText")
(cons Tj pt1)
(assoc 40 ent1)
(cons 1 Tgt)
(assoc 50 ent1)
(assoc 41 ent1)
(assoc 51 ent1)
(assoc 7 ent1)
(assoc 71 ent1)
(assoc 72 ent1)
'(100 . "AcDbText")
(assoc 73 ent1)
)
)
)
)
)
(vl-cmdf "regen")
(END_PG)
(princ)
)
;;;=============================================================================


===============
;;;---------------------------------PHEP TINH TOAN VOI LINK------------------------------------
;;;=============================================================================


===============
(defun CALC_LINK (ent1 ent2 ptinh ltr hso)
(strcat "%<\\AcExpr ("
"%<\\AcObjProp Object(%<\\_ObjId "
(rtos (vla-get-objectid (vlax-ename->vla-object ent1)) 2 0)
">%).TextString>%"
ptinh
"%<\\AcObjProp Object(%<\\_ObjId "
(rtos (vla-get-objectid (vlax-ename->vla-object ent2)) 2 0)
">%).TextString>%" ") \\f \"%lu2" "%pr" (itoa ltr)
"%ct8\"" ">%"
)
)

(defun OWNER_ENAME (obn)
(vlax-vla-object->ename
(vla-objectidtoobject
(vla-get-activedocument (vlax-get-acad-object))
(vla-get-ownerid
(vlax-ename->vla-object obn)
)
)
)
)
;;;HAM BAY LOI
(defun INIT ()
(setq OLD_ERROR *error*
*error* MYERROR
)
(command "Undo" "begin")
)
(defun MYERROR (errmsg)
(cond
((= errmsg "quit / exit abort")
(princ)
)
((/= errmsg "Function cancelled")
(princ (strcat "\n Co loi: " errmsg))
)
)
(setvar "osmode" OLD_OSMODE)
(setvar "AUTOSNAP" OLD_AUTOSNAP)
(setvar "ORTHOMODE" OLD_ORTHOMODE)
(setvar "DIMZIN" OLD_DIMZIN)
(setvar "clayer" OLD_CLAYER)
(setvar "CECOLOR" OLD_CECOLOR)
(setvar "cmdecho" 1)
(command "Undo" "end")
(DONE)
(prompt "\n Da Reset lai thiet lap ban dau")

)
(defun DONE ()
(if OLD_ERROR
(setq *error* OLD_ERROR)
)
)
;;;----------------------------------------------------------
;;;HAM LUU BAT DAU VA KET THUC CHUONG TRINH
(C:EXPRESSTOOLS)
(defun START_PG (/ ss)
(setq ss (ssget "I"))
(INIT)
(sssetfirst nil ss)
)
(defun END_PG ()
(DONE)
(RESTORE)
)
;;;----------------------------------------------------------
;;;HAM LUU VA TRA LAI CAC THONG SO BAN DAU
(defun SAVE_MODE ()
(setvar "cmdecho" 0)
(command "Undo" "begin")
(command "UCS" "W")
(setq OLD_OSMODE (getvar "OSMODE")
OLD_CECOLOR (getvar "CECOLOR")
OLD_AUTOSNAP (getvar "AUTOSNAP")
OLD_ORTHOMODE (getvar "ORTHOMODE")
OLD_CLAYER (getvar "clayer")
OLD_DIMZIN (getvar "DIMZIN")
)
(setvar "DIMZIN" 0)
)
(defun RESTORE ()
(setvar "osmode" OLD_OSMODE)
(setvar "AUTOSNAP" OLD_AUTOSNAP)
(setvar "ORTHOMODE" OLD_ORTHOMODE)
(setvar "DIMZIN" OLD_DIMZIN)
(setvar "clayer" OLD_CLAYER)
(setvar "CECOLOR" OLD_CECOLOR)
(command "Undo" "end")
(setvar "cmdecho" 1)
(Grtext -1 "Copyright by Nataca - 0983.715.333")
)
;;;------------------------------------------
;;;NHAP GIA TRI LA SO NGUYEN ( BAO GOM CA SO 0)
(defun I_INT0 (dongnhac Tso)
(if (null Tso)
(progn
(initget (+ 1 4))
(getint (strcat dongnhac " <?>:"))
)
(progn
(cond
((progn
(initget 4)
(getint (strcat dongnhac " < " (itoa Tso) " >:"))
)
)
(T Tso)
)
)
)
)
;;;NHAP GIA TRI LA SO THUC
(defun I_REAL (dongnhac Tso / Tso1)
(if (null Tso)
(progn
(initget (+ 1 2))
(setq Tso (getdist (strcat dongnhac " <?>:")))
(princ (strcat "\nGia tri vua nhap la: " (rtos Tso 2 5)))
Tso
)
(progn
(cond
((progn
(initget (+ 2))
(setq Tso1 (getdist (strcat dongnhac " < " (rtos Tso 2 5) " >:")))
(if Tso1
(progn
(princ (strcat "\nGia tri vua nhap la: " (rtos Tso1 2 5)))
(setq Tso Tso1)
)
)
)
)
(T Tso)
)
)
)
)
;;;------------------------------------------
;;;CHON LIEN TIEP NHIEU DOI TUONG THEO PHUONG PHAP PICK KEM DONG NHAC (BAT BUOC CHON)
(defun ES_ENT_LMP (dongnhac / Lsel sel mouse ew) ;;;LMP = List Multi Pick
(prompt dongnhac)
(while (/= (car mouse) 2)
(setq mouse (grread 0 15 2))
(if (= (car mouse) 3)
(if (setq sel (car (nentselp (cadr mouse))))
(progn
(setq Lsel (append Lsel (list sel)))
(princ (strcat "\n" (itoa (length Lsel))
" doi tuong duoc pick chon/ENTER ke ket thuc chon"))
)
(princ "\nChon chua dung!")
)
)
)
Lsel
)
;;;------------------------------------------
;;;XUAT/EDIT KET QUA VOI TEXT MAU BANG CACH PICK DIEM (EDIT CA ATTRIBUTE, DUNG CHO LINK GIA TRI)
(defun EX_VALUE_T_P_L (Tkq Tmau / mouse sel pt1 ob kq1 Elst Tj caoText oldTsize oldTstyle)
;;;Real+interge
(prompt "\n Chon text chua kq / An enter de viet text kq...")
(while (and (/= (car mouse) 2) (null sel))
(setq mouse (grread 0 15 2))
(if (= (car mouse) 3)
(if (null (setq sel (car (nentselp (cadr mouse)))))
(princ "\nChon chua dung! Chon lai...")
)
)
)
(if (/= sel nil)
(progn
(setq ob (entget sel))
(entmod (subst (cons 1 Tkq) (assoc 1 ob) ob))
)
(progn
(while (null (setq pt1 (getpoint "\n Diem dat text: "))))
(if Tmau
(progn
(if (and (= (cadr (assoc 11 (entget Tmau))) 0.0)
(= (caddr (assoc 11 (entget Tmau))) 0.0)
)
(setq Tj 10)
(setq Tj 11)
)
(setq Tmau (entget Tmau))
(entmakex (list '(0 . "TEXT")
'(100 . "AcDbEntity")
(assoc 8 Tmau)
'(100 . "AcDbText")
(cons Tj pt1)
(assoc 40 Tmau)
(cons 1 Tkq)
(assoc 50 Tmau)
(assoc 41 Tmau)
(assoc 51 Tmau)
(assoc 7 Tmau)
(assoc 71 Tmau)
(assoc 72 Tmau)
'(100 . "AcDbText")
(assoc 73 Tmau)
)
)
)
)
)
)
)

;;;------------------------------------------
;;;CHON TEXT VA DIMENSION KEM DONG NHAC (BAT BUOC CHON)
(defun ES_TM&D (dongnhac / ss)
(while (and(not (prompt dongnhac))
(not (or (setq ss (ssget "I" '((0 . "*TEXT,DIMENSION"))))
(setq ss (ssget '((0 . "*TEXT,DIMENSION"))))
)
)
)
)
ss
)
;;;CHUYEN BIEU DIEN TAP HOP DOI TUONG DUOI DANG LIST CHUA ENAME CUA CAC DOI TUONG
(defun C_S2L (ss)
(if ss
(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
nil
)
)
;;;------------------------------------------
;;;NHAP KEY VAO
(defun I_KEY (dongnhac key Text)
(if (null Text)
(progn
(initget 1 key)
(getkword (strcat dongnhac " :"))
)
(progn
(cond
((progn
(initget key)
(getkword (strcat dongnhac " < " Text " >:"))
)
)
(T Text)
)
)
)
)
(defun OD_SSY_DES_L (Lst)
(setq lst (vl-sort lst '(lambda (e1 e2)
(>
(caddr (assoc
(if (and (= (cadr (assoc 11 (entget e1))) 0.0)
(= (caddr (assoc 11 (entget e1))) 0.0)
)
10
11
)
(entget e1)
)
)
(caddr (assoc
(if (and (= (cadr (assoc 11 (entget e2))) 0.0)
(= (caddr (assoc 11 (entget e2))) 0.0)
)
10
11
)
(entget e2)
)
)
)
)
)
)
)
;;;------------------------------------------
;;;CHON TEXT, MTEXT KEM DONG NHAC (BAT BUOC CHON)
(defun ES_TM (dongnhac / ss)
(while (and (not (prompt dongnhac))
(not (or (setq ss (ssget "I" '((0 . "*TEXT"))))
(setq ss (ssget '((0 . "*TEXT"))))
)
)
)
)
ss
)
;;;CHON TEXT, MTEXT KEM DONG NHAC
(defun S_TM (dongnhac / ss)
(prompt dongnhac)
(if (null (setq ss (ssget "I" '((0 . "*TEXT")))))
(setq ss (ssget '((0 . "*TEXT"))))
)
ss
)

<<

Filename: 220108_ll_lgt_lc_ln_lh_l%2F_lmh.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 55090
Tên lệnh: ido
Viết Lisp theo yêu cầu

Chào bạn nguyenkhoadung98,
Rất xin lỗi vì vẫn chưa làm được theo đúng yêu cầu của bạn. Hiện tại, mặc dầu đã cố gắng nhưng mình vẫn chưa giải quyết được triệt để theo đúng yêu cầu của bạn. Mình mới chỉ giải quyết được việc để cho block chèn không bị chổng tu, và các text nằm song song với tiếp tuyến, sắp xếp theo đúng thứ tự bạn muốn từ trái qua phải không phụ...
>>

Chào bạn nguyenkhoadung98,
Rất xin lỗi vì vẫn chưa làm được theo đúng yêu cầu của bạn. Hiện tại, mặc dầu đã cố gắng nhưng mình vẫn chưa giải quyết được triệt để theo đúng yêu cầu của bạn. Mình mới chỉ giải quyết được việc để cho block chèn không bị chổng tu, và các text nằm song song với tiếp tuyến, sắp xếp theo đúng thứ tự bạn muốn từ trái qua phải không phụ thuộc vào loại đường và cách vẽ. Còn vấn đề vị trí tương đối của text so với block chèn tưởng là ngon mà mình vẫn không giải quyết được. Lý do là việc chèn text vào rất khác với việc chèn block cột. Cái góc xoay của Text không hoàn toàn đồng nhất với cái góc chèn block bạn ạ.
Hơn nữa do text mẫu của bạn đã bị căn chỉnh cả về điểm chèn lẫn font gốc nên mình chưa tìm ra được cách lấy chuẩn để căn text bạn ạ.
Hiện tại mình chấp nhận vị trí đặt text cao hơn điểm chèn 6 và lệch trái so với điểm chèn block 3 bạn nhé.
Một vấn đề nữa là cái lisp này có sự khác biệt với các lisp trước do mình sử dụng gợi ý của bác ndtnv, mình đưa việc chọn điểm chèn bắt đầu vào và các block sẽ được chèn bắt đầu từ điểm này trở đi bạn nhé. Điểm chèn này sẽ được đánh thứ tự là T2/L1-2B bạn ạ và tăng dần. Trong trường hợp bạn muốn điểm bắt đấu này là mút của đường chuẩn thì bạn không được chèn trước block cũng như text vào đó và phải chấp nhận không có block mang số T2/L1-1A. Khi đó cái block và text chuẩn này bạn phải lấy từ một vị trí khác trên bản vẽ. Nếu bạn muốn điểm chèn đâu tiên được đánh số là T2/L1-1A thì cũng đơn giản, chỉ cần sửa lại một chút ở hai đoạn code lấy giá trị t4 và t5 mà thôi bạn ạ.
Hy vọng các bác cao thủ khác trên diễn đàn sẽ góp ý hoàn thiện ơn cái lisp này của mình. Mong bạn thông cảm.
Lisp đây bạn, nhớ lệnh chạy là ido


Chúc bạn vui.
<<

Filename: 55090_ido.lsp
Tác giả: khaosatheco
Bài viết gốc: 233366
Tên lệnh: mtll
Lisp tạo viewport từ khung chọn bên model.

Chào cả nhà

Sau mấy công trình đã sử dụng lisp của bác KangKung mình thấy có 1 vài yêu cầu nhờ bác KangKung và các bác trên diễn đàn chỉnh sửa, bổ sung:

1. Sau khi chạy lisp mtll các VIEWPORT được tạo tự xoay sao cho Polyline định hướng nằm theo phương ngang.

2. Điền lý trình đầu và cuối đoạn giáp lai (như hình vẽ).

3. Điền lý trình đoạn tuyến vào khung tên.

>>

Chào cả nhà

Sau mấy công trình đã sử dụng lisp của bác KangKung mình thấy có 1 vài yêu cầu nhờ bác KangKung và các bác trên diễn đàn chỉnh sửa, bổ sung:

1. Sau khi chạy lisp mtll các VIEWPORT được tạo tự xoay sao cho Polyline định hướng nằm theo phương ngang.

2. Điền lý trình đầu và cuối đoạn giáp lai (như hình vẽ).

3. Điền lý trình đoạn tuyến vào khung tên.

;========LISP TAO VIEWPORT TREN LAYOUT BANG CACH CHON O MODEL========
;=========================REV4ii=====================================
(defun C:mtll( / os lst khung X_min Y_min X_max Y_max X index taphop tyle)
(command "-layer" "m" "khung" "c" 3 "khung" "")
  (command "UNDO" "BE")
  (setq os(getvar "OSMODE"))
  (setvar "OSMODE" 0)
  (setq taphop(ssget ))
   (setq Tyle (getreal (strcat "\n Ty le 1/ <1000>: ")))
   (if (= Tyle nil) (setq Tyle 1000))
  (setq xref(getstring "\n Ban co muon chen file khung ten hay khong? <Y/N>:"))
  (if (= (strcase xref) "Y")
    (progn
      (if (not Path)
	(setq Path(getvar "dwgprefix")))
      (setq xrefFile(getfiled "Chon File khung ten" Path "dwg" 2))
      (setq Path xrefFile)))
(setq xref1(getstring "\n Ban co muon chen bang ky hieu dia vat khong? <Y/N>:"))
  (if (= (strcase xref1) "Y")
    (progn
      (if (not Path)
	(setq Path1(getvar "dwgprefix")))
      (setq xrefFile1(getfiled "Chon File ky hieu" Path "dwg" 2))
      (setq Path1 xrefFile1
)))
  (setq soluong (sslength taphop))
  (setq index 0)
  (setq i 0)
  (setq ten (getstring "\n Nhap ten layout:"))
  (command "LAYOUT" "N" ten)
  (command "LAYOUT" "S" ten)
  (command "ERASE" "ALL" "")
  (command "MODEL")
  (setq X 0)
  (command "ZOOM" "E")
  (while (< index soluong)
    (setq khung(ssname taphop index))
    (setq lst(acet-geom-vertex-list khung))
    (setq X_min 1000000000
      Y_min 1000000000
      X_max -1000000000
      Y_max -1000000000)
    (foreach a lst
      (if (< (car a) X_min) (setq X_min (car a)))
      (if (< (cadr a) Y_min) (setq Y_min (cadr a)))
      (if (> (car a) X_max) (setq X_max (car a)))
      (if (> (cadr a) Y_max) (setq Y_max (cadr a)))
      )
    (command "LAYOUT" "S" ten)
    (command "ZOOM" "W" (list X_min Y_min) (list X_max Y_max))
    (command "PLINE")
    (foreach a lst
      (command a))
    (command "C")
    (command "MOVE" (entlast) "" (list X_min Y_min) (list X 0))
    (command "ZOOM" "W" (list 0 0) (list (+ X 100) 0))
    (command "SCALE" (entlast) "" (list X 0) (/ 1000 tyle))
    (command "MVIEW" "O" (entlast))
    (if (= (strcase xref) "Y")
      (command "xref" "A" xrefFile (list (- X 50) -50) "" "" ""))
    (command "SCALE" (entlast) "" (list (- X 50) -50) 1)
 (if (= (strcase xref1) "Y")
      (command "xref" "A" xrefFile1 (list (- X 40) 200) "" "" ""))
    (command "SCALE" (entlast) "" (list (- X 40) 200) 1)
    (command "MSPACE")
    (command "ZOOM" (list X_min Y_min) (list X_max Y_max))
    (command "PSPACE")
(if (= (strcase xref) "Y")    
    (command "TEXT" "J" "MR" (list (+ X 318) -43.85) 1.5 "0" "1/" ""))
(if (= (strcase xref) "Y")
    (command "TEXT" "J" "ML" (list (+ X 318.5) -43.85) 1.5 "0" (rtos tyle 2 0) ""))
    (command "MVIEW" "L" "on" (entlast) "")
    (setq X(+ X 380))
    (command "ZOOM" "W" (list 0 0) (list (+ X 100) 0))
    (setq index (+ index 1))
    )
  (command "MODEL")
  (command "UNDO" "END")
  (setvar "OSMODE" os)
  (princ)
  )

 

http://www.cadviet.com/upfiles/3/25684_file_bv_mau.dwg

http://www.cadviet.com/upfiles/3/25684_bangkyhieu_1.dwg

http://www.cadviet.com/upfiles/3/25684_khung_ten_1.dwg


<<

Filename: 233366_mtll.lsp
Tác giả: KangKung
Bài viết gốc: 233354
Tên lệnh: text2excel t2e
(Nhờ chỉnh sửa) Lisp chuyển cao độ ra file text

Lisp này xuất điểm từ CAD ra Excel luôn

;=======LISP XUAT DIEM DO CAO RA EXCEL=============
;=============KANGKUNG 29/04/2013==================
(defun C:Text2Excel( / taphop i xlApp xlCells Row TEXT InsertPoint String)
  (vl-load-com)
  (setq taphop(ssget '((0 . "TEXT"))))
  (if (/= taphop nil)
    (progn
      (setq i 0)
      (setq xlApp  (vlax-get-or-create-object...
>>

Lisp này xuất điểm từ CAD ra Excel luôn

;=======LISP XUAT DIEM DO CAO RA EXCEL=============
;=============KANGKUNG 29/04/2013==================
(defun C:Text2Excel( / taphop i xlApp xlCells Row TEXT InsertPoint String)
  (vl-load-com)
  (setq taphop(ssget '((0 . "TEXT"))))
  (if (/= taphop nil)
    (progn
      (setq i 0)
      (setq xlApp  (vlax-get-or-create-object "Excel.Application")
	xlCells(vlax-get-property(vlax-get-property(vlax-get-property(vlax-invoke-method(vlax-get-property xlApp 'Workbooks) 'Add) 'Sheets)'Item 1)'Cells)
	Row 1)
      (while (< i (sslength taphop))
	(setq TEXT (entget (ssname taphop i)))
	(if (= (read (cdr(assoc 1 TEXT))) (atof (cdr(assoc 1 TEXT))))
	  (progn
	    (if (= (+ (cdr(assoc 72 TEXT)) (cdr(assoc 73 TEXT))) 0)
	      (setq InsertPoint(cdr(assoc 10 TEXT)))
	      (setq InsertPoint(cdr(assoc 11 TEXT)))
	      )
	    (setq String(cdr(assoc 1 TEXT))) (vlax-put-property xlCells 'Item row 1 (itoa Row)) (vlax-put-property xlCells 'Item row 2 (rtos (car InsertPoint) 2 3))
	    (vlax-put-property xlCells 'Item row 3 (rtos (cadr InsertPoint) 2 3)) (vlax-put-property xlCells 'Item row 4 (rtos (caddr InsertPoint) 2 3))
	    (vlax-put-property xlCells 'Item row 5 String) (setq Row (1+ Row))))
	(setq i (1+ i)))
      (vlax-put-property xlApp 'Visible :vlax-true)))
  (princ)
  )
(defun C:T2E() (C:Text2Excel))
(princ "\n                     KangKung - 29/04/2013\n")
(princ "\n           Nhap T2E hoac Text2Excel de chay chuong trinh\n")

<<

Filename: 233354_text2excel_t2e.lsp
Tác giả: KangKung
Bài viết gốc: 233367
Tên lệnh: eg
p8L5S6 The Constitution gives every American the inalienable right to make a damn fool of himself..

Tặng bạn cái Lisp phá hết các đối tượng là Group trong bản vẽ.

(defun C:EG(/ group i kk)
  (setq group (dictsearch (namedobjdict) "ACAD_GROUP") i 1)
  (while (setq kk (nth i group))
    (if  (= (car kk) 3) (entdel (cdr (nth (+ i 1) group))))
    (setq i (+ 1 i)))
  (princ))

Filename: 233367_eg.lsp
Tác giả: Snowman
Bài viết gốc: 38561
Tên lệnh: cit
Viết Lisp theo yêu cầu

Yêu cầu của bạn có thể đáp ứng được nhưng đòi hỏi trình độ... ISO cao, cần fải có thời gian để viết một "soft" nho nhỏ mới dáp dứng đầy đủ được.
Tôi chỉ có đoạn code đánh số tăng dần trong đó số nằm giữa một text, giữ nguyên x ký tự phía trước và y ký tự phía sau.
Lệnh CIT, bạn hãy làm theo thông báo từ dòng lệnh, chú ý đếm chính xác số ký tự...
>>

Yêu cầu của bạn có thể đáp ứng được nhưng đòi hỏi trình độ... ISO cao, cần fải có thời gian để viết một "soft" nho nhỏ mới dáp dứng đầy đủ được.
Tôi chỉ có đoạn code đánh số tăng dần trong đó số nằm giữa một text, giữ nguyên x ký tự phía trước và y ký tự phía sau.
Lệnh CIT, bạn hãy làm theo thông báo từ dòng lệnh, chú ý đếm chính xác số ký tự cần giữ lại fía trước và sau text.
Chọn các text tiếp theo để điền số mới (ko thể chọn hàng loạt được)

<<

Filename: 38561_cit.lsp
Tác giả: thehost31
Bài viết gốc: 233448
Tên lệnh: a2xl
[Nhờ chỉnh sửa] Lisp tính diện tích bằng Pick Điểm

Chỉnh sửa lại tí nửa theo ý bạn anhemtracdia

 

Sau khi Pick điểm xác định vùng tính diện tích. Nếu muốn chọn text chứa tên của vùng thì chọn text hoặc mtext. Nếu muốn dùng tên tự động thì chuột phải hoặc enter để tiếp. Tên tự động có dạng Si.

 

;; free lisp from cadviet.com
;;; this lisp was downloaded from

>>

Chỉnh sửa lại tí nửa theo ý bạn anhemtracdia

 

Sau khi Pick điểm xác định vùng tính diện tích. Nếu muốn chọn text chứa tên của vùng thì chọn text hoặc mtext. Nếu muốn dùng tên tự động thì chuột phải hoặc enter để tiếp. Tên tự động có dạng Si.

 

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/70735-nho-chinh-sua-lisp-tinh-dien-tich-bang-pick-diem/
(defun Add_Hatch (poly Htype / mspace)
(vl-load-com)
(setq mspace (vla-get-ModelSpace
(vla-get-ActiveDocument (vlax-get-Acad-Object))
)
)
(setq hatch (vla-AddHatch
mspace
acHatchPatternTypePreDefined
Htype
:vlax-True
)
)
(vlax-invoke hatch 'AppendOuterLoop (list poly))
(vla-evaluate hatch)
)
;==============================================================
(defun MCText (pt string ht / mspace thetext tent alpoint)
(vl-load-com)
(setq mspace (vla-get-modelspace
(vla-get-activedocument (vlax-get-acad-object))
)
)
(setq thetext (vla-AddText mspace string (vlax-3d-point pt) ht))
(setq tent (entget (vlax-vla-object->ename thetext)))
(setq alpoint (cdr (assoc 10 tent)))
(setq tent (subst (cons 73 2) (assoc 73 tent) tent))
(setq tent (subst (cons 72 1) (assoc 72 tent) tent))
(setq tent (subst (cons 11 alpoint) (assoc 11 tent) tent))
(entmod tent)
thetext
)
;==============================================================
(defun MLText (pt string ht / mspace thetext tent alpoint)
(vl-load-com)
(setq mspace (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
(setq thetext (vla-AddText mspace string (vlax-3d-point pt) ht))
(setq tent (entget (vlax-vla-object->ename thetext)))
(setq alpoint (cdr (assoc 10 tent)))
(setq tent (subst (cons 73 2) (assoc 73 tent) tent))
(setq tent (subst (cons 72 0) (assoc 72 tent) tent))
(setq tent (subst (cons 11 alpoint) (assoc 11 tent) tent))
(entmod tent)
thetext
)
;==============================================================
(defun obj2plist (obj-ename / en timp timl pli)
(if (= (cdr (assoc 0 (entget obj-ename))) "LINE")
(progn
(setq timp (list
(cdr (assoc 10 (entget obj-ename)))
(cdr (assoc 11 (entget obj-ename)))
)
)
)
)
(if (= (cdr (assoc 0 (entget obj-ename))) "POLYLINE")
(progn
(setq en obj-ename)
(while (/= (cdr (assoc 0 (entget en))) "SEQEND")
(if (= (cdr (assoc 0 (entget en))) "VERTEX")
(setq timp (append timp (list (cdr (assoc 10 (entget en))))))
)
(setq en (entnext en))
)
)
)
(if (= (cdr (assoc 0 (entget obj-ename))) "LWPOLYLINE")
(progn
(setq timl (entget obj-ename))
(setq pli 0)
(while (< pli (length timl))
(if (= (car (nth pli timl)) 10)
(setq timp (append timp (list (cdr (nth pli timl)))))
)
(setq pli (1+ pli))
)
)
)
timp
)


;==============================================================
(defun c:A2xl (/ *error* vl ov xlApp xlCells Row pt eLast dtich plist
pgiua)
(vl-load-com)
(defun *error* (msg)
(ObjRel (list xlApp xlCells))
(and ov (mapcar 'setvar vl ov))
(if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
(princ (strcat "\n** Error: " msg " **"))
)
(princ)
)
(setq vl '("CMDECHO" "OSMODE")
ov (mapcar 'getvar vl)
)
(setq xlApp (vlax-get-or-create-object "Excel.Application")
xlCells (vlax-get-property
(vlax-get-property
(vlax-get-property
(vlax-invoke-method
(vlax-get-property xlApp 'Workbooks)
'Add
)
'Sheets
)
'Item
1
)
'Cells
)
Row 1
dem 1
)
(while (setq pt (getpoint "\nPick Area: "))
(mapcar 'setvar vl '(0 0))
(setq eLast (entlast))
(vl-cmdf "_.-boundary" "_a" "_i" "_n" "" "" pt "")
(if (not (eq elast (setq ent (entlast))))
(progn
(setq vitri (car (entsel "\nSelect Area Name text: ")))
(if vitri
(setq vitri (cdr (assoc 1 (entget vitri))))
(setq vitri (strcat "S" (rtos dem 2 0)) dem (1+ dem))
)
(vlax-put-property
xlCells
'Item
row
1
vitri
)
(vlax-put-property
xlCells
'Item
row
2
(setq dtich (rtos (vlax-get-property
(vlax-ename->vla-object ent)
'Area
)
)
)
)
(ADD_HATCH (vlax-ename->vla-object ent) "ANSI31")
(setq plist (OBJ2PLIST ent))
(setq
Pgiua (list
(/ (apply '+ (mapcar '(lambda (x) (car x)) plist))
(length plist)
)
(/ (apply '+ (mapcar '(lambda (x) (cadr x)) plist))
(length plist)
)
)
)
(setq Pstt (polar pgiua (* 0.5 pi) 1.5))
(setq Parea (polar pgiua (* -0.5 pi) 1.5))
(MLText Pstt vitri 1.5)
(MLText Parea dtich 1.5)
(entdel ent)
(setq Row (1+ Row))
)
)
(mapcar 'setvar vl ov)
)
(vlax-put-property xlApp 'Visible :vlax-true)
(ObjRel (list xlApp xlCells))
(gc)
(gc)
(mapcar 'setvar vl ov)
(princ)
)
;==============================================================
(defun ObjRel (lst)
(mapcar
(function
(lambda (x)
(if (and (eq (type x) 'VLA-OBJECT)
(not (vlax-object-released-p x))
)
(vl-catch-all-apply
'vlax-release-object
(list x)
)
)
)
)
lst
)
)

 

Chúc thành công!


<<

Filename: 233448_a2xl.lsp
Tác giả: KangKung
Bài viết gốc: 233632
Tên lệnh: test
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Topic này đông quá, KK góp vui tí bằng một yêu cầu đã cũ của ThuyLinh, đó là yêu cầu chuyển số nguyên trong chuỗi sang số thực. 

Hôm trước KK viết Lisp chuyển Text từ CAD sang Excel có được bác Hà tư vấn cho hàm distof dùng thấy hay nên đã viết lại Lisp theo yêu cầu của ThuyLinh theo 1 hướng khác đơn giản và ngắn gọn hơn nhiều. Lisp cũng đã xử lý được tất cả các...

>>

Topic này đông quá, KK góp vui tí bằng một yêu cầu đã cũ của ThuyLinh, đó là yêu cầu chuyển số nguyên trong chuỗi sang số thực. 

Hôm trước KK viết Lisp chuyển Text từ CAD sang Excel có được bác Hà tư vấn cho hàm distof dùng thấy hay nên đã viết lại Lisp theo yêu cầu của ThuyLinh theo 1 hướng khác đơn giản và ngắn gọn hơn nhiều. Lisp cũng đã xử lý được tất cả các trường hợp từ đơn giản đến phức tạp mà không cần phải chia ra trường hợp trong chuỗi có e (E) hay không có e (E). Một số chuỗi như "1...................2" thì Lisp cũng làm tốt.

Mời các bác trên diễn đàn bắt lỗi của Lisp này. Ai tìm ra lỗi sẽ có Like ngay. 

(defun C:Test( / i j a b c)
  (setq a(getstring T "\n Nhap chuoi: " ))
  (setq i 1 a1 "")
  (while (<= i (strlen a))
    (setq j(- (strlen a) i -1))
    (while (> j 0)
      (setq b(substr a i j))
      (if (and (= (vl-string-search "+" b) nil) (= (vl-string-search "-" b) nil) (= (vl-string-search " " b) nil))
	(if (setq c(distof b))
	  (setq a1(strcat a1 (substr a 1 (- i 1)) (rtos c 2 1))
		a(substr a (+ j i))
		i 1 j 0)))
      (setq j(- j 1)))
    (setq i(1+ i)))
  (setq a1(strcat a1 a))
  (princ a1)
  (princ)
  )

<<

Filename: 233632_test.lsp
Tác giả: minhtu2004
Bài viết gốc: 233635
Tên lệnh: bcount
Lisp Bcount của cad

-Hiện tại mình dùng lệnh Bcount của cad để thống kê Block, mình đã tìm trên diễn đàn có rất nhiều lisp thông kê Block nhưng hok phù hợp với yêu cầu của mình. Nên nhờ mọi người chỉnh dùm lisp Bcount của cad vì mình dùng thấy rất nhanh chỉ cần đánh lện Bcount và enter 2 lần hoặc chọn vùng là nó thống kê cho mình. Bây giờ mình chỉ muốn những cái thống kê chèn vào 1 table khi mình chọn 1...

>>

-Hiện tại mình dùng lệnh Bcount của cad để thống kê Block, mình đã tìm trên diễn đàn có rất nhiều lisp thông kê Block nhưng hok phù hợp với yêu cầu của mình. Nên nhờ mọi người chỉnh dùm lisp Bcount của cad vì mình dùng thấy rất nhanh chỉ cần đánh lện Bcount và enter 2 lần hoặc chọn vùng là nó thống kê cho mình. Bây giờ mình chỉ muốn những cái thống kê chèn vào 1 table khi mình chọn 1 điểm tạo table và bảng đó như sau:

(defun c:Bcount ( / ss flt a n lst)

(acet-error-init
(list nil T)
);acet-error-init

;build a filter of valid block names
(setq lst (acet-table-name-list (list "block" 1 4 16))) ;exclude anonymous and xref blocks
(setq n 0)
(repeat (length lst)
(setq a (nth n lst)
a (cons 2 a)
flt (cons a flt)
);setq
(setq n (+ n 1));setq
);repeat

(setq flt (append '((0 . "INSERT")
(-4 . " )
flt
'((-4 . "OR>"))
);append
);setq
(acet-ss-clear-prev)
(princ "\nPress Enter to select all or...")

(if (setq ss (ssget))
(setq ss (ssget "_p" flt))
(setq ss (ssget "_x" flt))
);if
(if ss
(bns_count ss)
(princ "\nNo valid objects selected.")
);if

(acet-error-restore)
);defun c:count

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun bns_count ( ss / bna lst na e1 n a mx )


;get a list of all unique block names
(setq mx 1)
(setq n 0)
(repeat (sslength ss)
(setq na (ssname ss n)
e1 (entget na)
bna (cdr (assoc 2 e1))
mx (max mx (strlen bna))
);setq
(if (not (assoc bna lst))
(setq lst (cons (cons bna 1) lst))
(setq a (cdr (assoc bna lst))
a (+ a 1)
lst (subst (cons bna a) (assoc bna lst) lst)
);setq
);if
(setq n (+ n 1));setq
);repeat

(if lst
(progn
(setq mx (+ mx 5));setq
(princ (bns_count_format "Block" "Count" mx))
(setq a "\n")
(while (< (strlen a) (+ mx 7))
;; (setq a (strcat a "-"))
(setq a (acet-str-format "%1-" a))
);while
(princ a)
);progn then print header
);if
(setq n 0)
(repeat (length lst)
(setq a (nth n lst));setq
(princ (bns_count_format (car a) (itoa (cdr a)) mx))
(setq n (+ n 1));setq
);repeat
);defun bns_count

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun bns_count_format ( a b mx / )

(while (<= (strlen a) mx)
;; (setq a (strcat a "."))
(setq a (acet-str-format "%1." a))
);while
;; (setq a (strcat "\n" a)
(setq a (acet-str-format "\n%1%2" ab)
);defun bns_count_format


(princ)

 

Sao chèn hình cái Bảng table hok dc. Cái có dòng tiêu đề là Bảng thông kê và tiếp theo xuống dòng là 2 cột Block và Count, cuối cùng là chèn thống kê vào.


<<

Filename: 233635_bcount.lsp
Tác giả: KangKung
Bài viết gốc: 233667
Tên lệnh: test
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

OK Thanks bác Tue_NV lần nữa. Code mới sửa đây: 

(defun C:Test( / i j a b c)
  (setq a(getstring T "\n Nhap chuoi: " ))
  (setq i 1 a1 "")
  (while (<= i (strlen a))
    (setq j(- (strlen a) i -1))
    (while (> j 0)
      (setq b(substr a i j))
      (if (and (= (vl-string-search "+" b) nil) (= (vl-string-search "-" b) nil) (= (vl-string-search "/" b) nil) (= (vl-string-search " " b) nil))
	(if (setq c(distof b))
	  (setq a1(strcat a1...
>>

OK Thanks bác Tue_NV lần nữa. Code mới sửa đây: 

(defun C:Test( / i j a b c)
  (setq a(getstring T "\n Nhap chuoi: " ))
  (setq i 1 a1 "")
  (while (<= i (strlen a))
    (setq j(- (strlen a) i -1))
    (while (> j 0)
      (setq b(substr a i j))
      (if (and (= (vl-string-search "+" b) nil) (= (vl-string-search "-" b) nil) (= (vl-string-search "/" b) nil) (= (vl-string-search " " b) nil))
	(if (setq c(distof b))
	  (setq a1(strcat a1 (substr a 1 (- i 1)) (rtos c 2 1))
		a(substr a (+ j i))
		i 1 j 0)))
      (setq j(- j 1)))
    (setq i(1+ i)))
  (setq a1(strcat a1 a))
  (princ a1)
  (princ)
  )

PS: Thanks bác Tue nhưng bấm nhầm vào bác Hà rồi. Mai sẽ Like bù bác Tue phát nữa nhé. Hôm nay hết quyền like rồi


<<

Filename: 233667_test.lsp
Tác giả: Tue_NV
Bài viết gốc: 108796
Tên lệnh: linkd
Viết lisp theo yêu cầu [phần 2]

Dựa vào code của anh gia_bach, Tue_NV chỉnh lại 1 chút cho phù hợp với yêu cầu của bạn vtd_xd.
Banj vtd_xd thử nhé :

Filename: 108796_linkd.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 233803
Tên lệnh: ha
Lệnh offset đặc biệt

Lisp ofset liên tục khi nhập vào khoảng cách.

 

;Doan Van Ha - CADViet.com - Ngay 04/05/2013
;Chuc nang: Offset lien tuc theo string nhap vao. VD: str = "10,2@20,50" => Offest: 10, 30, 50, 100.
(defun C:HA(/ lst ent)
 (vl-load-com)
 (setq str (getstring "\Nhap bieu thuc gia tri offset:...
>>

Lisp ofset liên tục khi nhập vào khoảng cách.

 

;Doan Van Ha - CADViet.com - Ngay 04/05/2013
;Chuc nang: Offset lien tuc theo string nhap vao. VD: str = "10,2@20,50" => Offest: 10, 30, 50, 100.
(defun C:HA(/ lst ent)
 (vl-load-com)
 (setq str (getstring "\Nhap bieu thuc gia tri offset: "))
 (setq lst (apply 'append (mapcar '(lambda(x) (HA:str->lst x "@")) (LM:str->lst str ","))))
 (while (setq ent (car (entsel "\nChon doi tuong de offset: ")))
  (foreach dis lst
   (vla-offset (vlax-ename->vla-object ent) dis)
   (setq ent (entlast))))
 (princ))
(defun LM:str->lst (str del / pos)
 (if (setq pos (vl-string-search del str))
  (cons (substr str 1 pos) (LM:str->lst (substr str (+ pos 1 (strlen del))) del))
  (list str)))
(defun HA:str->lst (str del / lst1)
 (setq lst (LM:str->lst str del))
 (if (= (length lst) 1)
  (mapcar 'atof lst)
  (repeat (atoi (car lst))
   (setq lst1 (cons (atof (cadr lst)) lst1)))))

<<

Filename: 233803_ha.lsp
Tác giả: anhemTracdia
Bài viết gốc: 233787
Tên lệnh: a2xl
Tác giả: Tue_NV
Bài viết gốc: 233812
Tên lệnh: olt
Lệnh offset đặc biệt

(defun C:dof(/ lstDis obj)
(setq lstDIS '(9 10 -15))
(while (setq obj (car (entsel "\nSelect object:")))
(foreach dis lstDIS
(vla-offset (vlax-ename->vla-object obj) dis)
)
)
(princ)
)

Code này mình sưu tầm được nó cho phép Off như trên. Nhưng chưa hiện thị nhập giá trị từ bàn phím và xử lý có...

>>

(defun C:dof(/ lstDis obj)
(setq lstDIS '(9 10 -15))
(while (setq obj (car (entsel "\nSelect object:")))
(foreach dis lstDIS
(vla-offset (vlax-ename->vla-object obj) dis)
)
)
(princ)
)

Code này mình sưu tầm được nó cho phép Off như trên. Nhưng chưa hiện thị nhập giá trị từ bàn phím và xử lý có khoảng cách @

 

Thêm 1 đoạn code nữa :

 

 
(defun c:olt(/ str)
  (vl-load-com)
  (defun Str_Split(str sym / lst i)
  ;write by Tue_NV
  (while (setq i (vl-string-search sym str 0))
    (setq lst (append lst (list (substr str 1 i)))
      i (+ i 1 (strlen sym))  str (substr str i (strlen str) ) )
  )
 (append lst (list (substr str 1 (strlen str))))
)
  (setq str (getstring "Chuoi Offset \"#,#@#,#\"  : "))
  (setq dt (car(entsel "\ndoi tuong can offset :")))
(foreach y
    (apply 'append
       (mapcar '(lambda(x / a lst) 
  (if (wcmatch x "*#`@#*")
    (progn (setq a (last (STR_SPLIT x "@"))) (Repeat (atoi x) (setq lst (append lst (list a)))) ) (list x) ))
(STR_SPLIT str ",")) )  
    (vla-offset (vlax-ename->vla-object dt) (atof y))
    (setq dt (entlast))
)
)

<<

Filename: 233812_olt.lsp
Tác giả: Tue_NV
Bài viết gốc: 233818
Tên lệnh: olt
Lệnh offset đặc biệt

Cám ơn bác nhiều. Nhưng có lẽ cần phải bổ sung thêm tính năng Pick chọn hướng offset. (nghĩa là pick chọn điểm về 1 phía của đối tượng chọn)

 Đây ban

 
(defun c:olt(/ st dt str lst-num)
  (setvar "cmdecho" 0)
  (vl-load-com)
  (defun Str_Split(str sym / lst...
>>

Cám ơn bác nhiều. Nhưng có lẽ cần phải bổ sung thêm tính năng Pick chọn hướng offset. (nghĩa là pick chọn điểm về 1 phía của đối tượng chọn)

 Đây ban

 
(defun c:olt(/ st dt str lst-num)
  (setvar "cmdecho" 0)
  (vl-load-com)
  (defun Str_Split(str sym / lst i)
  ;write by Tue_NV
  (while (setq i (vl-string-search sym str 0))
    (setq lst (append lst (list (substr str 1 i)))
      i (+ i 1 (strlen sym))  str (substr str i (strlen str) ) )
  )
 (append lst (list (substr str 1 (strlen str))))
)
  (setq str (getstring "Chuoi Offset \"#,#@#,#\"  : "))
  (setq dt (car(entsel "\ndoi tuong can offset :")) pt (getpoint "\nHuong Offset :")) 
(Repeat (length (setq lst-num (reverse 
       (apply 'append
        (mapcar '(lambda(x / a lst) 
     (if (wcmatch x "*#`@#*")
          (progn (setq a (atof (last (STR_SPLIT x "@")))) (Repeat (atoi x) (setq lst (append lst (list a)))) ) (list (atof x)) ))
(STR_SPLIT str ",")) ) )  ) )  
     (command "offset" (apply '+ lst-num) dt "_non" pt "e")
     (setq lst-num (cdr lst-num))
)
(princ)
)

<<

Filename: 233818_olt.lsp
Tác giả: Tue_NV
Bài viết gốc: 83467
Tên lệnh: mulro
Viết lisp theo yêu cầu [phần 2]
Chào PhiPhi . Bạn thử Code này xem nhé :
1. Lisp này quay các đối tượng nằm trong đường tròn và giao với đường tròn 1 góc ang tại tâm đường tròn Cỉcle, chấp nhận đối tượng là Block có 1 vòng tròn ở ngoài như bản vẽ mà Phiphi đã upload
2. Việc nhập góc theo 1 trong 2 dạng:
a. Chọn Line -> Lúc này Lisp sẽ hiện sáng vòng tròn và yêu cầu bạn chọn...
>>
Chào PhiPhi . Bạn thử Code này xem nhé :
1. Lisp này quay các đối tượng nằm trong đường tròn và giao với đường tròn 1 góc ang tại tâm đường tròn Cỉcle, chấp nhận đối tượng là Block có 1 vòng tròn ở ngoài như bản vẽ mà Phiphi đã upload
2. Việc nhập góc theo 1 trong 2 dạng:
a. Chọn Line -> Lúc này Lisp sẽ hiện sáng vòng tròn và yêu cầu bạn chọn Line để quay đối tượng theo phương và hướng của Line và góc của Line hợp với trục OX bao giờ cũng nhỏ hơn 180 độ. Nếu bạn không muốn nhập góc dạng a thì nhấn Enter để nhập góc dạng b
b. Nhập góc theo cách nhập từ bàn phím hoặc pick điểm. Lúc này Lisp sẽ tự động chọn tâm đường tròn, dây tóc chuột tại tâm đường tròn, hiện sáng vòng tròn và bạn nhập góc từ bàn phím hoặc pick điểm

Lisp ưu tiên nhập góc theo dạng a theo ý của PhiPhi và Tue_NV cũng thấy nó hiệu quả. Phi phi sử dụng thử nhé :

@Bác PhamThanhBinh : Khi viết Lisp, em chỉ quan tâm đến hiệu quả của việc sử dụng Lisp -> làm sao để sử dụng cho nó có hiệu quả nhất, việc nhập số liệu sao cho trực quan nhất, chứ không quan tâm đến độ dài, ngắn, đơn giản hay phức tạp của code. Em chắc rằng bác cũng đồng ý với ý kiến của em vì từ trước đến giờ bác viết khá nhiều code mà không quan tâm đến hiệu quả code là điều vô lý, còn việc bác có quan tâm đến độ dài, ngắn, đơn giản hay phức tạp của code thì em không biết ạ.
:(
<<

Filename: 83467_mulro.lsp
Tác giả: Tue_NV
Bài viết gốc: 83631
Tên lệnh: mulro
Viết lisp theo yêu cầu [phần 2]

Chào anh giabach
Lisp này Tue_NV viết theo ý của anh :
Lisp quay các đối tượng nằm trong đường tròn hoặc giao với đường tròn

Việc lấy góc theo như ý của anh gia_bach ở trên. User có thể enter để thực hiện việc nhập góc từ bàn phím hoặc pick điểm

Filename: 83631_mulro.lsp

Trang 128/304

128