Một dòng thì khó lắm bạn ạ :)

 

(defun c:hdim (/ ent dstyle )(setq ent (car (entsel "\n Pick dim :")) dstyle (cdr (assoc 3...
>>

Một dòng thì khó lắm bạn ạ :)

 

(defun c:hdim (/ ent dstyle )(setq ent (car (entsel "\n Pick dim :")) dstyle (cdr (assoc 3 (entget ent))))(command "DIMSTYLE" "R" dstyle)(setvar "DIMTXT" (getreal "\n Text Height :"))(command "DIMSTYLE" "S" dstyle "Y"))

 

P/S : với lại, ADMIN là bác chỉ ai vậy :|

hi ! Được rùi ạ ! Em cảm ơn bác KETXU Nhé, thì các bác viết lisp giúp e thì e gọi là ADMIN ạ ! hì.Em có j sai sót mong các bác bỏ qua nhé ! Thanks !

<<

Xin lỗi tôi sơ suất, SS2ENT là hàm thường dùng, nên có sẵn trong ACAD của tôi.

 

Lisp mới sau khi sửa lại như sau:

;; Bien toan cuc...
>>

Xin lỗi tôi sơ suất, SS2ENT là hàm thường dùng, nên có sẵn trong ACAD của tôi.

 

Lisp mới sau khi sửa lại như sau:

;; Bien toan cuc deltaH
(defun c:vmc ( / sel)
(defun ss2ent(ss / sodt index lstent)
 (setq
   sodt (cond
   (ss (sslength ss))
   (t 0)
 )
   index 0
 )
 (repeat sodt
   (setq ent (ssname ss index)
  index (1+ index)
  lstent (cons ent lstent)
   )
 )
 (reverse lstent)
)
(defun luuos ()
(setq
HOANH_OSMODE (getvar "OSMODE")
HOANH_AUTOSNAP (getvar "AUTOSNAP")
)
)
(defun traos ()
(if HOANH_OSMODE
(setvar "OSMODE" HOANH_OSMODE)
)
(if HOANH_AUTOSNAP
(setvar "AUTOSNAP" HOANH_AUTOSNAP)
)
)
(defun GiaoDT (ent1 ent2)
(setq ob1 (vlax-ename->vla-object ent1)
ob2 (vlax-ename->vla-object ent2)
)
(setq g (vlax-variant-value
(vla-IntersectWith ob1 ob2 acExtendNone)
)
)
(if (/= (vlax-safearray-get-u-bound g 1) -1)
(setq g (vlax-safearray->list g))
(setq g nil)
)
(if g
(progn
(setq kq nil
sd (fix (/ (length g) 3))
)
(repeat sd
(setq kq (append kq (list (list (car g) (cadr g) (caddr g))))
g (cdddr g)
)
)
kq
)
nil
)
)
(defun NhapdeltaH( / tmp)
(while (not tmp)
(setq tmp (getdist "\nVao khoang cach deltaH: "))
(if (not tmp)
(setq tmp deltaH)
)
)
(setq deltaH tmp)
)
;;;---------------------- Main --------------------------------
(princ "\nVMC © CADViet.com")
(if (not deltaH)
(NhapdeltaH)
)
(while (not sel)
(setq sel (entsel "\nVao line mat cat (hoac nhan Enter de nhap deltaH): ")
entl (car sel)
)
(if (not sel)
(NhapdeltaH)
)
)
(if (= "LINE" (cdr (assoc 0 (entget entl))))
(progn
(setq
p (cadr sel)
tt (entget entl)
p1 (cdr (assoc 10 tt))
p2 (cdr (assoc 11 tt))
)
(if (> (distance p p1)
(distance p p2)
)
(setq p p1
p1 p2
p2 p
)
)
(luuos)
(setvar "osmode" 0)
(command ".zoom" p1 p2)
(setq
sspl (ssget "F"
(LIST P1 P2)
'((-4 . "<OR")
(0 . "LWPOLYLINE")
(0 . "SPLINE")
(-4 . "OR>")
)
)
tappl (ss2ent sspl)
goc (+ (angle p1 p2) (/ pi 2.0))
index 0
tappn nil
)
(command ".zoom" "p")
(foreach entpl tappl
(if (setq tmp (giaodt entpl entl))
(setq
p (car tmp)
pn (polar p goc (* deltaH index))
index (1+ index)
tappn (append tappn (list pn))
)
)
)
(command ".pline")
(foreach pn tappn
(command pn)
)
(command "")
(traos)
)
)
(princ)
)

(vl-load-com)
(princ "\nVe mat cat tu binh do © CADViet.com 2007")
(princ "\nDung lenh VMC de bat dau!")
(princ)

-------------------------------------

Tôi đã copy chương trình vẽ mặt cắt từ binhg đồ và chạy trong Auto CAD nhưng kết quả chỉ cho một đường Pline, không thấy mặt cắt đâu cả. Kính mong Mr. Hoành chỉ giáo. Tôi thực sự cần chương trình này.

Xin cảm ơn

<<

 

Lisp sửa theo yêu cầu của bạn đây:

>>

 

Lisp sửa theo yêu cầu của bạn đây: http://www.cadviet.com/upfiles/3/71162_21lisp_gan_cao_do_cho_pline_va_ghi_ra_text_rev1.lsp

Ghóp ý thêm một chút nhé:

1. Trong bản vẽ thường cỡ chữ dùng để ghi chú đồng mức được cố định nên bạn chỉ nhập lần đầu thôi, còn từ lần thứ 2 trở đi thì không cần phải nhập nữa. Nếu cỡ chữ thay đổi liên tục (cái này hơi hiếm) thì bạn cho mình biết để sửa lại code.

2. Khi bạn chọn điểm chèn thì không nhất thiết phải chọn chính xác vị trí trên đường đồng mức cần ghi. Cứ chọn gần đó thôi và Lisp sẽ ghi Text vào đường đồng mức gần nhất với khoảng cách bằng 1/2 cao chữ. Và để tránh trường hợp chữ ngược chữ xuôi theo hướng đi của đường đồng mức thì mình đặt Text luôn luôn ở bên phải của đường đồng mức và xoay chữ sao cho không bị ngược trên bản vẽ chuẩn North Up.

3. Thêm 1 tính năng nữa đó là tự động tính bước nhảy của đường đồng mức giữa 2 lần nhập liên tiếp. Ví dụ lần đầu tiên bạn nhập cao độ đường đồng mức là 2, lần thứ hai là 4 thì từ lần thứ 3 trở đi Lisp sẽ tự động điền giá trị độ cao là 6, 8, 10 .... vào ô nhập. Đồng ý thì chỉ việc nhấn OK, không thì nhập giá trị khác. Tuy nhiên nếu bạn thao tác một cách có quy luật thì không phải mất công nhập số từ bàn phím nhiều lần.

;GAN CAO DO CHO DUONG DONG MUC VA GHI RA TEXT
;=======KANGKUNG 14/04/2013 - REV1===========
(defun C:kk( / i index pt pt1 pt2 taphop lst huong)
  (command "UNDO" "BE")
  (setq os(getvar "OSMODE"))
  (setvar "OSMODE" 0)
  (setq taphop (ssget '((0 . "POLYLINE,LWPOLYLINE"))))
  (if (and (/= docao nil) (= (length list_caodo) 2))
    (setq docao(read(lisped (rtos (+ (- (nth 1 list_caodo) (nth 0 list_caodo)) docao) 2 2))))
    (if (/= docao nil)
      (setq docao(read(lisped (rtos docao 2 2))))
      (setq docao(read(lisped "Nhap do cao duong dong muc vao day")))
      )
    )
  (if (< (length list_caodo) 2)
    (setq list_caodo(append list_caodo (list docao)))
    (setq list_caodo(append (list (nth 1 list_caodo)) (list docao)))
    )
  (if (= Height nil)
    (setq Height(read(lisped "Nhap cao chu vao day")))
    )
  (setq index 0)
  (while (< index (sslength taphop))
    (vla-put-elevation (vlax-ename->vla-object (ssname taphop index)) docao)
    (vla-put-color (vlax-ename->vla-object (ssname taphop index)) 2)
    (setq index (1+ index))
    )
  (while (setq pt(getpoint "\n Pick diem chen TEXT: " ))
    (huongtext)
    (entmake (list '(0 . "TEXT") (cons 10 pt2) (cons 40 Height) (cons 1 (rtos docao 2 2)) (cons 50 huong)))
    )
  (setvar "OSMODE" os)
  (command "UNDO" "END")
  (princ)
  )
(defun huongtext()
  (setq i 0)
  (setq lst(list))
  (while (< i (sslength taphop))
    (setq dt(ssname taphop i))
    (setq pt1(vlax-curve-getClosestPointTo dt pt))
    (if (and (<= pi (angle pt1 pt)) (<= (angle pt1 pt) (* 2 pi)))
      (setq pt2(polar pt1 (angle pt pt1) (/ Height 2)))
      (setq pt2(polar pt1 (angle pt1 pt) (/ Height 2)))
      )
    (if (= (vlax-curve-getDistAtPoint dt (vlax-curve-getClosestPointTo dt pt)) (vla-get-length (vlax-ename->vla-object dt)))
      (setq huong(angle ( vlax-curve-getPointAtDist dt (+ (vlax-curve-getDistAtPoint dt (vlax-curve-getClosestPointTo dt pt)) -0.001)) (vlax-curve-getClosestPointTo dt pt) ))
      (setq huong(angle (vlax-curve-getClosestPointTo dt pt) ( vlax-curve-getPointAtDist dt (+ (vlax-curve-getDistAtPoint dt (vlax-curve-getClosestPointTo dt pt)) 0.001))))
      )
    (if (and (> huong (/ pi 2)) (< huong (/ (* 3 pi) 2))) (setq huong(- huong pi)))
    (setq lst(append lst (list (list (distance pt pt1) huong pt2))))
    (setq i(1+ i))
    )
  (setq lst(vl-sort lst '(lambda (e1 e2) (< (car e1) (car e2)))))
  (setq huong(cadr(nth 0 lst)))
  (setq pt2(caddr(nth 0 lst)))
  )
(princ "\n              KangKung - 14/04/2013\n")
(princ "\n           Nhap KK de chay chuong trinh\n")

tuyệt vời. e cảm ơn bác kangkung rất rất nhiều nhé :) 

<<

Thanks ketxu đã quan tâm. Tôi muốn kết hợp tức là khi chạy lisp có thể áp dụng cho cả text nữa. Hiện tôi dùng lisp của bác Duy thì sau...

>>

Thanks ketxu đã quan tâm. Tôi muốn kết hợp tức là khi chạy lisp có thể áp dụng cho cả text nữa. Hiện tôi dùng lisp của bác Duy thì sau khi hỏi chọn điểm gốc thứ 2 là tôi không biết làm thế nào để chọn điểm thứ 2 sao cho điểm 1-2 song song với text (nếu text nằm nghiêng). Tuy nhiên sau khi tìm kiếm thì tôi đã có được lisp rot (cũng tìm trong cadviet) quay riêng cho text song song với 1 đuờng thẳng. Bác có thể giúp tôi lần nữa là ghép lisp rot với lisp ross của bác Duy để tôi chỉ dùng 1 lệnh và load 1 lisp thôi được k. Tôi đã thử làm mấy ngày hôm nay rồi mà k thực hiện được. Thanks bác nhiều.

(defun c:Rot(/ chon goc ts dem ten ) ;--------------Text rotate -----------------------
(prompt "\nChon doi tuong can quay: ")
(setq chon (ssget))
(if (= t (null chon)) (prompt "Ban chua chon doi tuong nao. Lenh ket thuc.")
(progn
(if (null goc) (setq goc 0)) 
(prompt "Nhap goc quay doi tuong  ") 
(princ "<")(princ (angtos goc)) (princ ">: ")
(setq goc (getangle))
(setq ts (sslength chon))
(setq dem 0)
(while (< dem ts)
(progn
(setq ten (entget (ssname chon dem)))
(setq ten (subst (cons 50 goc) (assoc 50 ten) ten )) 
(entmod ten)
(setq dem (+ 1 dem))
)
)
)
)
(princ) 
)

Góp vào để load 1 lần thì dể nhưng để thực hiện 1 lệnh thì hơi khó vì nguyên tắc làm việc của 2 lệnh hơi khác.

-lệnh ross thì chọn 1 nhóm đối tượng, 2 điểm cơ sở. 2 điểm song song và thực hiện quay cả nhóm đối tượng đó 1 lần 1 tâm quay.

-Lệnh rot thì chọn 1 nhóm đối tượng (không biết bạn post code đũ không chứ đúng ra đối tượng chọn phải giới hạn trong kiểu text thôi). chọn hai điểm song song và thực hiện quay từng đôí tượng tại điểm chèn của chính nó.

 

*Nếu muốn thì có thể chỉnh lisp ross như sau:

-Nếu đối tượng được chọn toàn bộ là text thì làm như rot, nếu có lẩn đối tượng khác thì thực hiện như ross. Được không?

<<

Với yêu cầu làm hàng loạt thì tốt nhất là hỏi thăm anh Lisp ^^

Ví dụ :

(defun C:test (/ item *doc*...
>>

Với yêu cầu làm hàng loạt thì tốt nhất là hỏi thăm anh Lisp ^^

Ví dụ :

(defun C:test (/ item *doc* after)
;Ketxu
(vl-load-com)
(setq after (getstring "\nHau to can them vao :")
 *doc* (vla-get-layouts(vla-get-activedocument (vlax-get-acad-object))))
(foreach lay(layoutlist)
(vla-put-name (setq item (vla-item *doc* lay)) (strcat (vla-get-name item) after))
)
 (princ)
)

Cảm ơn bạn nhé, mình sẽ load về dùng thử!

<<

Bạn dùng thử lisp này. Ssg đã post lên diễn đàn lâu lắm rồi. Riêng phần Att mới bổ sung theo gợi ý của bạn:

 

>>

Bạn dùng thử lisp này. Ssg đã post lên diễn đàn lâu lắm rồi. Riêng phần Att mới bổ sung theo gợi ý của bạn:

 

;;;**********************************************
;;;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 : "))
   (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
(setq
   e (car (entsel "\nSelect template text:"))
   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 : "))
   (command "copy" e "" p1 p2)
   (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)
   )
   (entmod dat)    
)
(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 : "))
   (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)
)
;;;============================

thank bạn vài phát! hay wa'

<<

 

Cái này xuất ra excel file csv thì ok, còn lập bảng kẻ line thì chỉ viết ra kết quả thôi.

(defun...
>>

 

Cái này xuất ra excel file csv thì ok, còn lập bảng kẻ line thì chỉ viết ra kết quả thôi.

(defun c:ton(/ B1 B2 B3 FILE LI N SS TM VT X)
(setq ss (ssget '((0 . "TEXT")))
li nil
file (open (strcat (getvar "dwgprefix") "1.csv") "a")
v0 (ssname ss 0)
n 0
dd (getpoint "\nVi tri dat bang:"))
 
(foreach v (mapcar '(lambda(x) (cdr (assoc 1 (entget x))))
(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(if (and (setq vt (vl-string-search "(" v)) (vl-string-search ")" v))
(progn
(setq b1 (substr v 1 (1- vt))
b2 (substr v (+ 2 vt))
b3 (vl-list->string (vl-remove-if '(lambda(x) (or (= 41 x) (<= 48 x 57))) (vl-string->list b2)))
)
(if (setq tm (assoc b1 li))
(setq li (subst (cons b1 (+ (cdr tm) (atof b2))) tm li))
(setq li (cons (cons b1 (atof b2)) li))
)
)
)
)
(foreach v li
(entmake (list (cons 0 "TEXT") (cons 10 dd) (cons 11 dd) (cons 40 (cdr (assoc 40 (entget v0)))) (cons 8 (cdr (assoc 8 (entget v0))))
(cons 41 (cdr (assoc 41 (entget v0)))) (cons 7 (cdr (assoc 7 (entget v0))))
(cons 72 (cdr (assoc 72 (entget v0)))) (cons 73 (cdr (assoc 73 (entget v0))))
(cons 1 (strcat (itoa (setq n (1+ n))) "\t\t\t" (car v) "\t\t\t" (strcase b3) "\t\t\t" (rtos (cdr v))))))
(write-line (strcat (itoa n) "," (car v) "," (strcase b3) "," (rtos (cdr v))) file)
(setq dd (polar dd (* 1.5 pi) (* 2 (cdr (assoc 40 (entget v0))))))
) 
(close file)
)

Nhờ mấy bác chỉnh sửa dùm lisp.

 

Tương tư như lips của Anh Tot77 nhưng phần khối lượng được phân biệt bằng dấu gạch chéo (thay vì trong ngoặc)

Vi dụ: các text, mtext như sau:

1P56(5m), 1P56(3m), 2P110+2P56(3m), 2P110+2P56(2m) thay bằng 1P56/5m, 1P56/3m, 2P110+2P56/3m, 2P110+2P56/2m.

 

E không biết lội mà mò kim đáy biển, thật rất khó. Nhờ mấy bác giúp dùm cho.

<<

Download lisp

Filename: 410435_ton.lsp

HÌ!! bạn thử cái này xem có vừa ý không nhé

(defun BatDau() (setq OldOs (getvar "osmode")) (setvar "osmode" 0))
(defun KetThuc() (setvar "osmode" OldOs))
(defun...
>>

HÌ!! bạn thử cái này xem có vừa ý không nhé

(defun BatDau() (setq OldOs (getvar "osmode")) (setvar "osmode" 0))
(defun KetThuc() (setvar "osmode" OldOs))
(defun c:sct (/ OldOs OldEcho tile en pt1 pt2 mid i Rec)
(setq i 0)
(princ "\nChon Doi tuong Scale tai tam:") 
(setq ss (ssget))
(setq tile (getreal "\nChon tile Scale:"))
(while (< i (sslength ss))
(setq en (ssname ss i))
(setq  Rec (acet-ent-geomextents en)
   pt1 (nth 0 Rec);lay dinh
   pt2 (nth 1 Rec);lay dinh 
   mid (acet-geom-midpoint pt1 pt2)
);setq
(BatDau)
(command "SCALE" en "" mid tile "")
(KetThuc)	

(setq i (1+ i))	 
);while
     (princ "\n...Done...")
(princ)
);defun

Tại cái TÂM của bạn nó khó xác định quá nên mình dùng cách này nhé!!!

Tiện đây mình hỏi luôn: cái Hàm acet-ent-geomextents tại sao nó vẫn thực hiện mà cứ báo lỗi nhỉ

Mình dùng hàm acet-ent-geomextents để xác định tâm.

Tốt nhất bạn Block từng đối tượng muốn scale vào để đc chính xác!!!

Dòng này của bạn thừa cái này (command "SCALE" en "" mid tile "")

Mình chạy không thấy báo lỗi của acet-ent-geomextents

<<

 

Cái này bổ sung thêm phần ghi kết quả vào 1 text có sẵn .

(defun c:tinh()  (vl-load-com)  (initget 1 "+ - * /") ...
>>

 

Cái này bổ sung thêm phần ghi kết quả vào 1 text có sẵn .

(defun c:tinh()  (vl-load-com)  (initget 1 "+ - * /")  (setq ptinh (getkword "Chon phep tinh <+ - * />: "))    (cond ((= ptinh "+")  ;;; cong	 (prompt "\nChon text de cong:")	 (setq ss (ssget '((0 . "TEXT")))	       kqua 0)	 (while (and ss (> (sslength ss) 0))	   (setq kqua (+ kqua (atof (cdr (assoc 1 (entget (setq ent (ssname ss 0))))))))	   (ssdel ent ss))	 (princ kqua))		((= ptinh "*")  ;;;nhan	 (prompt "\nChon text de nhan:")	 (setq ss (ssget '((0 . "TEXT")))	       kqua 1)	 (while (and ss (> (sslength ss) 0))	   (setq kqua (* kqua (atof (cdr (assoc 1 (entget (setq ent (ssname ss 0))))))))	   (ssdel ent ss))	 (princ kqua))	((= ptinh "-")  ;;;tru	 (setq sobitru (car (entsel "\nChon so bi tru:"))	       sotru (car (entsel "\nChon so tru:\n"))	       kqua (- (atof (cdr (assoc 1 (entget sobitru))))		     (atof (cdr (assoc 1 (entget sotru))))))	  	 (princ kqua))	((= ptinh "/")  ;;;chia	 (setq sobichia (car (entsel "\nChon so bi chia:"))	       sochia (car (entsel "\nChon so chia:\n"))	       kqua (/ (atof (cdr (assoc 1 (entget sobichia))))		     (atof (cdr (assoc 1 (entget sochia))))))	  	 (princ kqua))	  )    (if (not ssle) (setq ssle 0))  (setq obj (vlax-ename->vla-object (car (entsel "\nChon text de ghi ket qua:")))		ssle1 (getint (strcat "\nSo so le <" (itoa ssle) ">: ")))  (if ssle1 (setq ssle ssle1))  (vla-put-TextString obj (rtos kqua 2 ssle))    (princ)	       )

cái này chắc đã update lại kết quả sửa lisp rồi chứ mình thấy dùng ổn mà

thanks

<<

Theo chủ thớt thì là độ.phútgiây mà

 

(defun c:demo (/ e e1 e2 key #func)
(defun s2d (str / ret)
 (setq ret
...
>>

Theo chủ thớt thì là độ.phútgiây mà

 

(defun c:demo (/ e e1 e2 key #func)
(defun s2d (str / ret)
 (setq ret
 (vl-list->string
(vl-remove-if
 	'(lambda (x) (or (< x 48) (> x 57)))
 	(reverse (vl-string->list str))
)
 )
 )
 (angtof
(vl-list->string
 	(reverse
(vl-string->list
(strcat "\"" (substr ret 1 2) "'" (substr ret 3 2) "d" (substr ret 5))
   	)
 	)
)
 )
)
(defun format (value fm / lst mm ss)
(setq ss (vl-list->string (cdr (member 39 (vl-string->list value)))))
(if (= (strlen ss) 2) (setq value (strcat (substr value 1 (- (strlen value) 2)) "0" ss)))
(setq mm (vl-list->string (cdr (member 100 (vl-string->list value)))))
(if (= (strlen mm) 5) (setq value (strcat (substr value 1 (- (strlen value) 5)) "0" mm)))

 (setq lst '(("Space" . 32)
  	("dOt" . 46)
  	("Comma" . 44)
  	("dAsh" . 45)
 	)
 )
 (setq fm (cdr (assoc fm lst)))
 (cond
((member fm '(32 45))
(vl-list->string
 	(subst fm
 	100
 	(subst fm 39 (vl-remove 34 (vl-string->list value)))
 	)
))
((member fm '(44 46))
(vl-list->string
 	(subst fm
 	100
 	(vl-remove 39 (vl-remove 34 (vl-string->list value)))
 	)
))
(T value)
 )
)

(if (null func) (setq func +))
(if (null fm) (setq fm "Degress"))
(setq key T)
(while (not (member key '("-" "+" nil)))
(setq #func  (chr (cadr (reverse (vl-string->list (vl-princ-to-string func))))))
(initget "Degress Space dOt Comma dAsh + -")
(setq key (getkword (strcat "\nEnter an option <Default: "#func"/"fm">:")))
(cond
  ((member key '("-" "+")) (setq func (eval (read key))) nil)
  (T (setq fm key))
)
)

(while
 (and

(setq se1 (ssget '((0 . "TEXT"))))
(setq e2 (car (entsel (strcat "\nSelect Text 2 <Exit>:"))))
(setq e2 (s2d (cdr (assoc 1 (entget e2)))))
(setq p (Getpoint "\nInsert Column Point <exit>:"))
)
  (setq i 0)
   	(while (setq e1 (ssname se1 i))
    (setq p (list (car p) (caddr (assoc 10 (entget e1)))))
   (setq e1 (s2d (cdr (assoc 1 (setq e (entget e1))))))  
    	(setq e (subst (cons 10 p) (assoc 10 e) e))
    	(setq e (subst (cons 1  (format (angtos (func e2 e1) 1 4) fm)) (assoc 1 e) e))
    	(entmake e)
   (setq i (1+ i))
  )
 )
 (princ)
)

 

Bạn xem lại hộ mình với:

<<

Đây là đoạn code bao gồm cả 2 hàm MUL và SUM.

 

;;;-----------------------------------------
(defun CheckObj(e MyType) (equal (cdr (assoc 0 (entget e)))...
>>

Đây là đoạn code bao gồm cả 2 hàm MUL và SUM.

 

;;;-----------------------------------------
(defun CheckObj(e MyType) (equal (cdr (assoc 0 (entget e))) MyType))
;;;-----------------------------------------
(defun FilObj(ss1 MyType / ss2 i e)
(setq ss2 (ssadd) i 0)
(repeat (sslength ss1)
       (setq e (ssname ss1 i) i (1+ i))
       (if (CheckObj e MyType) (ssadd e ss2) )
)
(eval ss2)
)
;;;-----------------------------------------
(defun SelData( / OK)
(setq OK nil)
(while (not OK)
   (prompt "\tChon cac text can tinh:")
   (setq ss (FilObj (ssget) "TEXT"))
   (if (> (sslength ss) 0) (setq OK T) (princ "\nDoi tuong chon khong phai text"))
)
)
;;;-----------------------------------------
(defun WriteRes(kq / OK e data)
(setq OK nil)
(while (not OK)
   (setq e (car (entsel "\tChon text ghi ket qua:")))
   (if (CheckObj e "TEXT") (setq OK T) (princ "\nDoi tuong chon khong phai text"))
)
(entmod (subst (cons 1 (rtos kq)) (assoc 1 (setq data (entget e))) data))
(princ)
)
;;;-----------------------------------------
(defun C:MUL( / i m e ss)
(SelData) (setq i 0 m 1.0)
(repeat (sslength ss) (setq e (ssname ss i) i (1+ i) m (* m (atof (cdr (assoc 1 (entget e)))))))
(WriteRes m)
)
;;;-----------------------------------------
(defun C:SUM( / i s e ss)
(SelData) (setq i 0 s 0.0)
(repeat (sslength ss) (setq e (ssname ss i) i (1+ i) s (+ s (atof (cdr (assoc 1 (entget e)))))))
(WriteRes s)
)
;;;-----------------------------------------

 

Với người sử dụng, chẳng có gì khác hơn 2 đoạn mà ssg và bác Hoanh đã viết trên. Nhưng với lập trình viên lsp thì khác rất nhiều.

Hai điểm khác cơ bản là:

1) Tính cấu trúc của chương trình tốt hơn, dễ kiểm tra, sửa lỗi, phát triển thêm...

2) CheckObj, FilObj trở thành các defun dùng chung, có thể dùng cho các chương trình khác sau này, tiết kiệm khá nhiều công sức.

Đó cũng là một trong những lý do để ssg đề xuất với các bạn xây dựng CadViet Utility. Viết một đoạn code đáp ứng một yêu cầu cụ thể nào đó dễ hơn nhiều so với việc xây dựng một hệ thống. Nhưng các bạn thử hình dung, khi số lượng các chương trình lsp tương tự như trên tăng lên khá nhiều thì điều gì sẽ xảy ra? Chúng sẽ "đá" nhau, cái này sẽ vô hiệu hoá cái kia, có khi chẳng có cái nào dùng được, gây nên những lỗi không thể kiểm soát...

Rất mong được các bạn góp ý thêm.

Mình vừa bắt đầu làm quen với việc ứng dụng lisp. Đúng là rất tiện lợi. Cảm ơn mọi người đã chia sẻ kinh nghiệm.

<<

Đây bạn! Chú ý: vị trí và kích cỡ mũi tên tôi chỉ tạm thiết kế theo 1 tỉ lệ với chiều cao text, bạn có thể sửa lại theo...

>>

Đây bạn! Chú ý: vị trí và kích cỡ mũi tên tôi chỉ tạm thiết kế theo 1 tỉ lệ với chiều cao text, bạn có thể sửa lại theo ý mình.

;Doan Van Ha - CADViet.com - Ngay 31/12/2011
;Muc dich: Tinh va ghi do doc.
(defun C:HA( / ent1 ent2 ent3 ent4 obj cd pg goc h sty lop doc pg1 pg2 pt1 ptg pt2)
(BAT_DAU)
(setq ent1 (car (entsel "\nPick Text cao do diem dau: ")))
(setq ent2 (car (entsel "\nPick Text cao do diem cuoi: ")))
(setq ent3 (car (entsel "\nPick len 1 Text mau de lay thong tin Text: ")))
(setq ent4 (car (entsel "\nPick duong can ghi do doc: ")))
(or *stp* (setq *stp* 2))
(setq stp (getint (strcat "\nSo chu so thap phan <" (itoa *stp*) ">: ")))
(if (not stp) (setq stp *stp*) (setq *stp* stp))
(if (and ent1 ent2 ent3 ent4)
 (progn
  (setq obj (vlax-ename->vla-object ent4))
  (setq cd (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj)))
  (setq pg (vlax-curve-getPointAtDist obj (/ cd 2)))
  (setq goc (angle '(0 0 0) (vlax-curve-getFirstDeriv obj (vlax-curve-getParamAtPoint obj pg))))
  (setq h (cdr (assoc 40 (entget ent3))))
  (setq sty (cdr (assoc 7 (entget ent3))))
  (setq lop (cdr (assoc 8 (entget ent3))))
  (setq doc (/ (- (atof (cdr (assoc 1 (entget ent1)))) (atof (cdr (assoc 1 (entget ent2))))) cd))
  (setq pg1 (polar pg (+ goc (/ pi 2)) (* 1.5 h)))
  (setq pg2 (polar pg1 (+ goc (/ pi 2)) (* 1.5 h)))
  (setq pt1 (polar pg1 (+ goc pi) (* 3 h)) ptg (polar pt1 goc (* 5 h)) pt2 (polar ptg goc (* 1 h)))
  (acet-sysvar-set (list "osmode" 0 "cmdecho" 0))
  (command "pline" pt1 ptg "w" (* 0.2 h) 0 pt2 "")
  (command "text" "s" sty "j" "m" pg2 h (/ (* 180 goc) pi) (strcat (rtos doc 2 stp) "%"))
  (command "change" (entlast) "" "p" "la" lop "")))
(KET_THUC)
(princ))
(defun BAT_DAU()
(vl-load-com)
(setq AcDoc (vla-get-activeDocument (vlax-get-acad-object)))
(vla-StartUndoMark AcDoc)
(setq err *error* *error* KHI_LOI))
(defun KET_THUC()
(acet-sysvar-restore)
(vla-EndUndoMark AcDoc)
(setq *error* err))
(defun KHI_LOI(msg)
(acet-sysvar-restore)
(vla-EndUndoMark AcDoc)
(redraw)
(command "u")
(princ (strcat "\n" msg ", Reset System Variables\n"))
(setq *error* err))

Tue_NV có góp ý chút :

Dòng

(if (and ent1 ent2 ent3 ent4)

(progn

......

nên đưa lên trên để kiểm tra các biến ent1, ent2, ent3 và ent4 đồng thời kiểm tra cả biến stp luôn

(setq ent1 (car (entsel "\nPick Text cao do diem dau: ")))(setq ent2 (car (entsel "\nPick Text cao do diem cuoi: ")))(setq ent3 (car (entsel "\nPick len 1 Text mau de lay thong tin Text: ")))(setq ent4 (car (entsel "\nPick duong can ghi do doc: ")))(or *stp* (setq *stp* 2))(setq stp (getint (strcat "\nSo chu so thap phan <" (itoa *stp*) ">: ")))(if (not stp) (setq stp *stp*) (setq *stp* stp))

Nếu 1 trong các biến này không được nhập hoặc chọn thì lệnh sẽ không được thực thi.

Vậy sẽ hay hơn.

<<

 

mình đã sửa lại để chơi đuợc cả hàng lẫn cột đây. post lâu lắm rồi mới thấy có bạn ý kiến nên chắc cũng ít...

>>

 

mình đã sửa lại để chơi đuợc cả hàng lẫn cột đây. post lâu lắm rồi mới thấy có bạn ý kiến nên chắc cũng ít người có nhu cầu này nhỉ.

(defun c:srt (/ DXF MakeText HANG I LAP LSTKQ PT0 PTI SS1 SS2 SS3 SSN SSN3 TBS1 TBS2 TBS3)(defun DXF (code en)	(cdr (assoc code (entget en))))(defun entmod-en (code value en / RES)(setq RES (entget en '("*")))(entmod (subst (cons code value) (assoc code RES) RES)))(defun MakeText (point string Height Ang justify Style Layer Color xdata / Lst); Ang: Radial(setq Lst (list '(0 . "TEXT")(cons 8 (if Layer Layer (getvar "Clayer")))(cons 62 (if Color Color 256))(cons 10 point)(cons 40 Height)(cons 1 string)(if Ang (cons 50 Ang))(cons 7 (if Style Style (getvar "Textstyle")))(cons -3 (if xdata (list xdata) nil)))justify (strcase justify))(cond ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))((= justify "TL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))))((= justify "TC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))))((= justify "TR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))))	((= justify "ML") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))))((= justify "MC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))))((= justify "MR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))))((= justify "BL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))))((= justify "BC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))))((= justify "BR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1))))))(entmakex Lst));endmaketext(setq pheptinh (cond (pheptinh) ("Cong")))(initget "Cong Tru Nhan CHia")(setq pheptinh (cond ((getkword (strcat "\nchon phep tinh:  <" pheptinh ">: "))) (pheptinh)))(prompt "\nChon Hang-Cot so thu nhat..")(if (setq SS1 (ssget '((0 . "TEXT"))))(progn (prompt "Chon Hang-Cot so thu hai..")(if (setq SS2 (ssget '((0 . "TEXT"))))(progn(Setq TBS1 (ACET-GEOM-SS-EXTENTS-FAST SS1) SS1 (acet-ss-to-list SS1)TBS2 (ACET-GEOM-SS-EXTENTS-FAST SS2) SS2 (acet-ss-to-list SS2))(if (> (abs(- (car (car TBS1)) (car (cadr TBS1)))) (abs(- (cadr (car TBS1)) (cadr (cadr TBS1)))))(setq Hang TSS1 (vl-sort SS1 '(lambda (e1 e2) (< (cadr (assoc 10 (entget e1))) (cadr (assoc 10 (entget e2)))))))(setq Hang nilSS1 (vl-sort SS1 '(lambda (e1 e2) (> (caddr (assoc 10 (entget e1))) (caddr (assoc 10 (entget e2))))))))(if (> (abs(- (car (car TBS2)) (car (cadr TBS2)))) (abs(- (cadr (car TBS2)) (cadr (cadr TBS2)))))(setq SS2 (vl-sort SS2 '(lambda (e1 e2) (< (cadr (assoc 10 (entget e1))) (cadr (assoc 10 (entget e2)))))))(setq SS2 (vl-sort SS2 '(lambda (e1 e2) (> (caddr (assoc 10 (entget e1))) (caddr (assoc 10 (entget e2))))))))(if (> (length SS1) (length SS2)) (setq lap (length SS1) i 0) (setq lap (length SS2) i 0))(setq LstKQ '())(if (setq PT0 (getpoint (strcat "\nchon diem dat " (if Hang "hang" "cot") " ket qua. Enter de ghi va Hang-Cot text khac")))(progn (vl-cmdf "ucs" "w")(repeat lap(setq SSn (nth i SS1))(maketext(if (= hang nil)(setq PTi (list (car PT0) (cadr (DXF 10 SSn))))(setq PTi (list (car (DXF 10 SSn)) (cadr PT0))))(cond ((eq pheptinh "Cong")	(rtos (+ (atof (DXF 1 SSn)) (atof (DXF 1 (nth i SS2)))) 2 2))((eq pheptinh "Tru")	(rtos (- (atof (DXF 1 SSn)) (atof (DXF 1 (nth i SS2)))) 2 2))((eq pheptinh "Nhan")	(rtos (* (atof (DXF 1 SSn)) (atof (DXF 1 (nth i SS2)))) 2 2))((eq pheptinh "CHia")	(rtos (/ (atof (DXF 1 SSn)) (atof (DXF 1 (nth i SS2)))) 2 2)))(DXF 40 SSn) 0 "R"(DXF 7 SSn) (DXF 8 SSn) nil nil)(setq  i (1+ i)))(vl-cmdf "ucs" "p"))(progn(prompt "\nChon Hang hoac Cot text de ghi ket qua")(if (setq SS3 (ssget '((0 . "TEXT"))))(setq TBS3 (ACET-GEOM-SS-EXTENTS-FAST SS3)SS3 (acet-ss-to-list SS3))(EXIT))(if (> (abs(- (car (car TBS3)) (car (cadr TBS3)))) (abs(- (cadr (car TBS3)) (cadr (cadr TBS3)))))(setq SS3 (vl-sort SS3 '(lambda (e1 e2) (< (cadr (assoc 10 (entget e1))) (cadr (assoc 10 (entget e2)))))))(setq SS3 (vl-sort SS3 '(lambda (e1 e2) (> (caddr (assoc 10 (entget e1))) (caddr (assoc 10 (entget e2))))))))(vl-cmdf "undo" "begin")(repeat lap(setq SSn (nth i SS1))(if (setq SSn3 (nth i SS3))(entmod-en 1(cond ((eq pheptinh "Cong")	(rtos (+ (atof (DXF 1 SSn)) (atof (DXF 1 (nth i SS2)))) 2 2))((eq pheptinh "Tru")	(rtos (- (atof (DXF 1 SSn)) (atof (DXF 1 (nth i SS2)))) 2 2))((eq pheptinh "Nhan")	(rtos (* (atof (DXF 1 SSn)) (atof (DXF 1 (nth i SS2)))) 2 2))((eq pheptinh "CHia")	(rtos (/ (atof (DXF 1 SSn)) (atof (DXF 1 (nth i SS2)))) 2 2))) SSn3)(progn(alert (strcat "tap hop text khong du de ghi ket qua. Thieu "(rtos (- lap i) 2 0)" text"))(vl-cmdf "undo" "end")(EXIT)))(setq  i (1+ i)))(vl-cmdf "undo" "end")));if);progn)));if(princ));end

he hôm nay vẫn còn người sử dụng đó bác à

thanks bác

<<

Lệnh VTT (Vectơ Tịnh Tiến) trong lisp dưới đây sẽ giúp bạn.

 

Lệnh này sẽ tìm và vẽ một đoạn thẳng ngắn nhất nối đường thẳng với 1 đường cong...

>>

Lệnh VTT (Vectơ Tịnh Tiến) trong lisp dưới đây sẽ giúp bạn.

 

Lệnh này sẽ tìm và vẽ một đoạn thẳng ngắn nhất nối đường thẳng với 1 đường cong (chính là vector tịnh tiến). Công việc còn lại của bạn là dùng lệnh move.

 

(setq cv_dvd 1000)
(defun c:vtt( / dmin)  
 (setq entl (car (entsel "\nPick vao line: ")))
 (redraw entl 3)
 (setq
entsp (car (entsel "\nPick vao spline: "))
p1 (cdr (assoc 10 (entget entl)))
p2 (cdr (assoc 11 (entget entl)))
i 0.0
 )
 (redraw entl 4)
 (repeat (1+ cv_dvd)
   (setq
     m (/ i cv_dvd)
     p (mapcar '(lambda (s1 s2) (+ (* m s1) (* (- 1.0 m) s2))) p1 p2)
     pn (vlax-curve-getClosestPointTo (vlax-ename->vla-object entsp) p)
     d (distance p pn)
     i (+ i 1.0)
   )
   (if (or (not dmin)(< d dmin))
     (setq dmin d pluu pn pgoc p)
   )
 )
 (entmake (list (cons 0 "LINE") (cons 10 pluu)(cons 11 pgoc)))
 (princ)
)

 

Lisp trên tìm theo phương pháp dò, mặc định số điểm dò là 1000. Bạn có thể tăng độ chính xác bằng cách tăng số 1000 trong dòng lệnh (setq cv_dvd 1000) lên nhiều hơn nữa nhưng thời gian thực thi lệnh sẽ tăng lên.

Em vừa thử xong, vẫn không được.

Em Upload file: http://www.cadviet.com/upfiles/Ofixerop.dwg

Anh xem giúp em với!

<<

 

Yêu cầu khá là "mơ hồ", vui lòng gửi file Cad minh hoạ.

Gửi lại List Fix  lỗi tên block tiếng Việt  : 

>>

 

Yêu cầu khá là "mơ hồ", vui lòng gửi file Cad minh hoạ.

Gửi lại List Fix  lỗi tên block tiếng Việt  : 

(defun c:BlkQty (/ blk_id blk_len blk_name blks cur_var ent h header_lsp height i
		 ins j len0 lst_blk msp pt row ss str tblobj width width1 width2 x y)
;;  By : Gia Bach, gia_bach @  www.CadViet.com             ;;
(defun TxtWidth (val h msp / txt minp maxp)
  (setq	txt (vla-AddText msp val (vlax-3d-point '(0 0 0)) h))
  (vla-getBoundingBox txt 'minp 'maxp )
  (vla-Erase txt)
  (-(car(vlax-safearray->list maxp))(car(vlax-safearray->list minp)))  )

(defun GetOrCreateTableStyle (tbl_name / name namelst objtblsty objtblstydic tablst txtsty)
  (setq objTblStyDic (vla-item (vla-get-dictionaries *adoc) "ACAD_TABLESTYLE") )  
  (foreach itm (vlax-for itm objTblStyDic
		 (setq tabLst (append tabLst (list itm))))
    (if (not
	  (vl-catch-all-error-p
	    (setq name (vl-catch-all-apply 'vla-get-Name (list itm)))))
      (setq nameLst (append nameLst (list name)))  )  )
  (if (not (vl-position tbl_name nameLst))
    (vla-addobject objTblStyDic tbl_name "AcDbTableStyle"))
  (setq objTblSty (vla-item objTblStyDic tbl_name)
	TxtSty (variant-value (vla-getvariable *adoc "TextStyle")))
  (mapcar '(lambda (x)(vla-settextstyle objTblSty x TxtSty))
	      (list acTitleRow acHeaderRow acDataRow) )
  (vla-setvariable *adoc "CTableStyle" tbl_name) )
  
(defun GetObjectID (obj)
  (if (vl-string-search "64" (getenv "PROCESSOR_ARCHITECTURE"))
    (vlax-invoke-method
      (vla-get-Utility *adoc)
      'GetObjectIdString obj :vlax-false )
    (vla-get-Objectid obj)))  
;main
  (if (setq ss (ssget (list (cons 0 "INSERT"))))
    (progn
      (vl-load-com)
      (setq i -1 len0 8)
      (while (setq ent (ssname ss (setq i (1+ i))))
	(setq blk_name (vla-get-name (vlax-Ename->Vla-Object ent)))
	(if (> (setq blk_len (strlen blk_name)) len0)
	  (setq str blk_name len0 blk_len) )	
	(if (not (assoc blk_name lst_blk))
	  (setq lst_blk (cons (cons blk_name 1) lst_blk))
	  (setq lst_blk (subst (cons blk_name (1+ (cdr (assoc blk_name lst_blk))))
			       (assoc blk_name lst_blk) lst_blk)))	    )
      (setq lst_blk (vl-sort lst_blk '(lambda (x y) (< (car x) (car y)) ) ))
      (setq cur_var (mapcar 'getvar '("DYNMODE" "DYNPROMPT")))
      (mapcar 'setvar '("DYNMODE" "DYNPROMPT") '(1 1))
      (initget "Yes No")
      (setq ins (getkword "\nChen ki hieu Block  <yes> : ") )
      (or ins (setq ins "Yes"))
      (mapcar 'setvar '("DYNMODE" "DYNPROMPT") cur_var)      
      (or *h* (setq *h* (* (getvar "dimtxt")(getvar "dimscale"))))
      (initget 6)
      (setq h (getreal (strcat "\nChieu cao chu <" (rtos *h*) "> :")))      
      (if h (setq *h* h) (setq h *h*) )
      (setq *adoc (vla-get-ActiveDocument (vlax-get-acad-object))
	    msp (vla-get-modelspace *adoc)
	    blks (vla-get-blocks *adoc))      
      (setq width1 (* 2 (TxtWidth "STT" h msp))
	    width (* 2 (TxtWidth "So luong" h msp))
	    height (* 2 h))
      (if str
	(setq width2 (* 1.5 (TxtWidth (strcase str) h msp)))
	(setq width2 width))
      (if (> h 3)
	(setq width (* (fix (/ width 10))10)
	      width1 (* (fix (/ width1 10))10)
	      width2 (* (fix (/ width2 10))10)
	      height (* (fix (/ height 5))5)))
      (GetOrCreateTableStyle "CadViet")
      (setq pt (getpoint "\nDiem dat Bang :")
	    TblObj (vla-addtable msp (vlax-3d-point pt) (+ (length lst_blk) 2) 5 height width))
      (vla-put-regeneratetablesuppressed TblObj :vlax-true)
      (vla-SetColumnWidth TblObj 0 width1)
      (vla-SetColumnWidth TblObj 1 width2)
      (vla-put-vertcellmargin TblObj (* 0.75 h))
      (vla-put-horzcellmargin TblObj (* 0.75 h))
      (mapcar '(lambda (x)(vla-setTextHeight TblObj x h))
	      (list acTitleRow acHeaderRow acDataRow) )
      (mapcar '(lambda (x)(vla-setAlignment TblObj x 2))
	      (list acTitleRow acHeaderRow acDataRow))      
      (vl-catch-all-error-p (vl-catch-all-apply (function(lambda () (vla-MergeCells TblObj 0 0 0 3)) )))
      (vla-setText TblObj 0 0 "Bang thong ke")
      (setq j -1 header_lsp (list "STT" "Ten" "Don vi" "So luong" "Ky hieu")) 
      (repeat (length header_lsp)
	(vla-setText TblObj 1 (setq j (1+ j)) (nth j header_lsp)))
      (setq row 2 i 1)    
      (foreach pt lst_blk
	(setq blk_name (car pt) j -1 )
	(mapcar '(lambda (x)(vla-setText TblObj row (setq j (1+ j)) x))
		(list i blk_name "cai" (cdr pt)))
	(if (= ins "Yes")
	  (vlax-for blk blks
	    (if (= (vla-get-Name blk) blk_name)
	      (vla-SetBlockTableRecordId TblObj row 4 (GetObjectID blk) :vlax-true))) )
	(vla-SetCellAlignment TblObj row 1 7)
	(vla-SetCellAlignment TblObj row 3 9)
	(setq row (1+ row) i (1+ i))	)
      (vla-put-regeneratetablesuppressed TblObj :vlax-false)
      (vlax-release-object TblObj) )  )
  (princ))

Cảm ơn gia_bach đã quan tâm

Ý mình khi chọm điểm đặt bảng, font trong bảng thống kê là tiếng việt có dấu (style, font là Vni-helve)

Rất mong sự giúp đỡ của gia_bach.

<<

Download lisp

Filename: 339020_blkqty.lsp

@ttmt_jses:

Bạn dùng thử lisp đánh center mark cho hàng loạt đường tròn. Lệnh CTM:

;;;----------------------------------------------------
(defun ctm1(e / k d p0 r p1...
>>

@ttmt_jses:

Bạn dùng thử lisp đánh center mark cho hàng loạt đường tròn. Lệnh CTM:

;;;----------------------------------------------------
(defun ctm1(e / k d p0 r p1 p2 p3 p4)
(setq
   k 1.2
   d (entget e)
   p0 (cdr (assoc 10 d))
   r (cdr (assoc 40 d))
   p1 (polar p0 pi (* k r))
   p2 (polar p0 0 (* k r))
   p3 (polar p0 (* pi 0.5) (* k r))
   p4 (polar p0 (* pi 1.5) (* k r))
)
(command "line" p1 p2 "")
(command "line" p3 p4 "")
)
;;;----------------------------------------------------
(defun C:CTM( / ss oldos e)
(setq ss (ssget '((0 . "CIRCLE"))))
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(while (setq e (ssname ss 0))
   (ctm1 e)
   (ssdel e ss)
)
(setvar "osmode" oldos)
(princ)
)
;;;----------------------------------------------------

Đường center có chiều dài bằng 1.2 lần đường kính đường tròn. Muốn thay đổi thì sửa trị số 1.2 ở dòng thứ 3 trong code.

@Tue_NV: Cái "tại sao" bạn nêu mình biết rồi. Bạn làm thử nghiệm này:

1. Chọn Size của center mark (đặt là c), chọn Type "Line"

2. Vẽ các đường tròn có r trong khoảng 0 đến 2c, đánh center mark -> nhận xét

3. Thử nghiệm như trên với các đường tròn có r > 2c -> nhận xét và kết luận...

Đúng thật, Khi vẽ các đường tròn có r trong khoảng 0 đến 2c thì khi đánh center Mark cho được độ dài đường thẳng bằng giá trị 2c.

Còn khi vẽ các đường tròn có r > 2c thì khi đánh center Mark cho được độ dài đường thẳng bằng giá trị đường kính cộng với 2c

Sử dụng lệnh dimcenter không thể giải quyết triệt để vấn đề của bài toán.

 

Lisp của bác SSG hay lắm : chọn hàng loạt đường tròn, sử dụng chỉ một lệnh đánh hàng loạt Center Mark.

Cảm ơn bác SSG nhiều lắm

<<

To : khaosat2009

Bạn khảosát2009 thử xem cái này có đúng ý bạn không

Bạn chạy thử :

(defun c:RFT(/ data f h line pt pXY spc str ten val);Read File Txt
(vl-load-com)
(defun...
>>

To : khaosat2009

Bạn khảosát2009 thử xem cái này có đúng ý bạn không

Bạn chạy thử :

(defun c:RFT(/ data f h line pt pXY spc str ten val);Read File Txt
(vl-load-com)
(defun Split (Str Char / Lst pos)
(while (setq pos (vl-string-search Char Str))
(if (null Lst)
(setq Lst (list (substr Str 1 pos)))
(setq Lst (append Lst (list (read (substr Str 1 pos))))))
(setq Str (substr Str (+ pos 2)) ))
(setq Lst (append Lst (list (read Str)))))

(if (setq ten (getfiled "Chon File txt" (getvar "dwgprefix") "txt" 8))
(progn
(or (tblsearch "layer" "Point") (command "-layer" "n" "Point" "") )
(or (tblsearch "layer" "Sothutu") (command "-layer" "n" "Sothutu" "c" 3 "Sothutu" "") )
(or (tblsearch "layer" "Caodo") (command "-layer" "n" "Caodo" "c" 4 "Caodo" "") )
(setq spc (vla-get-ModelSpace (vla-get-ActiveDocument(vlax-get-Acad-Object))))
;(setq h 2)
(Setq h (getreal"\nChieu cao chu:"))
(if (= nil h)(setq h 2))
(setq kitu nil)
(initget "X Y")
(setq kitu (getkword "\nChon kieu xuat :"))
(cond
   ((= kitu "X") (setq kitu 0))
   ((= kitu "Y") (setq kitu 1))    
   )
(if (= nil kitu)(setq kitu 0))
;(* (getvar "dimtxt")(getvar "dimscale")))
(setq f (open (findfile ten) "r"))
(while (setq Line (read-line f))
(if (vl-string-search "\t" Line)
(progn
(setq data (split Line "\t" )
val (car data)
pt (cdr data))
(if (not(vl-catch-all-error-p (vl-catch-all-apply 'vlax-3d-point pt)))
(progn
;(setq pXY (list (car pt)(cadr pt)))
(if (= 0 kitu)
(setq pXY (list (car pt)(cadr pt)))
)
(if (= 1 kitu)
(setq pXY (list (cadr pt)(car pt)))
)
(vla-put-Layer (vla-addpoint spc (vlax-3d-point pXY)) "Point")
;kkkkkkkkkkkkk
(vla-put-Layer (setq str (vla-addtext spc val (vlax-3d-point pXY) h)) "Sothutu")
(vla-put-Alignment str 8)
(vla-put-TextAlignmentPoint str (vlax-3d-point pXY))
(vla-put-Layer (vla-addtext spc (caddr pt) (vlax-3d-point pXY) h) "Caodo") ))))) ))
(princ))

<<

Lisp tính tổng chiều dài của mọi đối tượng có thuộc tính chiều dài (line, pline, spline, arc, circle, ellipse). Lệnh TL:

 

>>

Lisp tính tổng chiều dài của mọi đối tượng có thuộc tính chiều dài (line, pline, spline, arc, circle, ellipse). Lệnh TL:

 

;;;--------------------------------------------------------------------
(defun Length1(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
;;;--------------------------------------------------------------------
(defun C:TL( / ss L e)
(setq
   ss (ssget  (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))
   L 0.0
)
(vl-load-com)
(while (setq e (ssname ss 0))
   (setq L (+ L (length1 e)))
   (ssdel e ss)
)
(alert (strcat "Total length = " (rtos L)))
)
;;;--------------------------------------------------------------------

Thanks U!

Có món này rùi mọi vic sẻ rất tiện lợi

MÌnh chờ mấy ngày nay mà hok thấy

cám ơn bạn lần nữa ngen, mà nó có tính dc các polyline hok vậy bạn

<<

Đây là lisp tôi sưu tầm và chỉnh sửa lại chút ít, có thể rải taluy cho các loại line, pline, spline, arc, circle ...

(Mới dừng ở việc vẽ taluy cho 1 đường, phần vẽ mái...

>>

Đây là lisp tôi sưu tầm và chỉnh sửa lại chút ít, có thể rải taluy cho các loại line, pline, spline, arc, circle ...

(Mới dừng ở việc vẽ taluy cho 1 đường, phần vẽ mái taluy giữa 2 đường tôi chưa sửa xong)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;vtl;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun nsl ()
 (if (/= scale nil)
   (progn
     (setq thongbao (strcat "Ty le ban ve ?, <1/" (itoa scale) ">:"))
     (if (not (setq scaletmp (getint thongbao)))
(setq scaletmp scale)
     )
   )
   (progn
     (setq thongbao "Ty le ban ve ? <1/1000>:")
     (if (not (setq scaletmp (getint thongbao)))
(setq scaletmp 1000)
     )
   )
 )

 (setq scale scaletmp)

 (setq Defaultdist (* (* scale 2) 0.002))
 (if (setq tg (getreal	(strcat	"\nKhoang cach ky hieu ta luy <"
			(rtos Defaultdist 2 2)
			">:"
		)
       )
     )
   (setq Defaultdist tg)
 )

 (setq	chieutaluy1
 1
sodoan 0
 )
)

(defun nsl1 ()

 (setq
   ktdoantaluy1 2
   tg		 (getreal (strcat "\nChieu dai doan ngan<"
			  (rtos ktdoantaluy1 2 2)
			  ">:"
		  )
	 )
 )
 (if tg
   (setq ktdoantaluy1 tg)
 )
 (setq
   ktdoantaluy2 6
   tg		 (getreal (strcat "\nChieu dai doan dai<"
			  (rtos ktdoantaluy2 2 2)
			  ">:"
		  )
	 )
 )
 (if tg
   (setq ktdoantaluy2 tg)
 )
 (setq
   khoangcachtl 2
   tg		 (getreal (strcat "\nKhoang cach giua cac doan<"
			  (rtos khoangcachtl 2 2)
			  ">:"
		  )
	 )
 )
 (if tg
   (setq khoangcachtl tg)
 )
 (setq
   sodoanngan 3
   tg	       (getint (strcat "\nSo doan ngan trong 1 doan dai<"
		       (rtos sodoanngan 2 0)
		       ">:"
	       )
       )
 )
 (if tg
   (setq sodoanngan tg)
 )

)


(Defun PlMake (Plist)			;  Create polyline entities
 (entmake '((0 . "POLYLINE")))
 (setq	n  (length Plist)
ic 0
 )
 (while (< ic n)
   (entmake (list (cons 0 "VERTEX") (cons 10 (nth ic Plist))))
   (setq ic (1+ ic)
   )
 )
 (entmake '((0 . "SEQEND")))

)


;;;----------------------------------------------------------------
(defun ve1doantaluy (p1 p2 / pvt diemcu ktdoantaluy ketthuc)
 (setq pvt (+ (angle p1 p2) (* (/ pi 2) chieutaluy)))
 (setq ketthuc 1)
 (if (< sodoan sodoanngan)
   (progn
     (setq ktdoantaluy ktdoantaluy1)
     (setq sodoan (1+ sodoan))
   )
   (progn
     (setq ktdoantaluy ktdoantaluy2)
     (setq sodoan 0)
   )
 )
 (setq p2 (polar p1 pvt ktdoantaluy))
 (plmake (list p1 p2))
 (setq dem (1+ dem))
)

(Defun xddsd (com epl kc / e0 e p dsd)
 (setq e0 (entlast))
 (while e0
   (setq e e0)
   (setq e0 (entnext e0))
 )
 (command com epl kc)
 (setq e (entnext e))
 (while e
   (setq p (cdr (assoc 10 (entget e))))
   (if	p
     (setq dsd (cons p dsd))
   )
   (setq e (entnext e))
 )
 (command "_.Undo" 1)
 (setq dsd dsd)
)
				; ve ta luy cho 1 doi tuong
(Defun vetaluy (ep / le e ketthuc them dsd thutu)
 (setq dem 0)
 (setq e (entget (car ep)))
 (if (or (= (cdr (assoc 0 e)) "LWPOLYLINE")
  (= (cdr (assoc 0 e)) "POLYLINE")
  (= (cdr (assoc 0 e)) "SPLINE")
  (= (cdr (assoc 0 e)) "LINE")
  (= (cdr (assoc 0 e)) "ARC")
  (= (cdr (assoc 0 e)) "CIRCLE")
     )

   (setq ketthuc 1)
   (prompt "\nDoi tuong duoc chon khong hop le")
 )
 (if ketthuc
   (progn
     (setq thutu 0)
     (setq dsd (xddsd "_.Measure" ep khoangcachtl))
     (setq p1 (car dsd))
     (repeat (1- (length dsd))
(setq thutu (1+ thutu))
(setq p2 (nth thutu dsd))
(ve1doantaluy p1 p2)
(setq p1 p2)
     )
   )
 )
 (setq dem dem)
)

;;;==================================================
(Defun C:vtl1 (/ ep chon lai solan chon)

 (setvar "cmdecho" 0)
 (setvar "blipmode" 0)
 (command "undo" "g")
 (nsl)

 (setq ep 1)
 (while ep
   (setq solan	0
  chieutaluy 1
   )
   (setq ep (entsel "\nChon doi tuong ve ta luy..."))

   (if	ep
     (progn
(nsl1)
(setq solan (vetaluy ep))
(initget "Undo Change")
(while
  (setq chon (getkword "Undo/Change <enter for exit>: "))


   (if (= chon "Undo")
     (command "_.Undo" solan)
   )
   (if (= chon "Change")
     (progn
       (nsl1)

       (setq chieutaluy -1)
       (command "_.Undo" solan)
       (setq solan (vetaluy ep))

     )
   )

  (initget "Undo Change")
)

     )
   )
 )
 (command "undo" "e")
)

Lisp này khá tốt, chi cần sửa tay một tẹo là rải taluy cho 2 đường ngon ơ. Chỉ có điều nhập " khoảng cách ký hiệu taluy" để làm gì hả bác xìnâu? Và ấn Enter là tiếp tục chứ không phải thoát. Theo em để rải đẹp thì cần phải tách 2 layer taluy ngắn và taluy dài ra vì như vậy chiều dài taluy ngắn và taluy dài có thể thay đổi riêng biệt nhau làm cho đường taluy mềm mại hơn. Để em thử nâng cấp lên " chỉ rải trên một đoạn của đường cong mà mình tuỳ ý đặt" xem sao nhé (vì trên tuyến nó thay đổi đoạn đào, đắp liên tục)

<<