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)
)

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")

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)
)

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

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")

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!

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)
  )

-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.

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

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

(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))
)
)

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)
)