Thêm dấu chấm "." sau toạ độ X,Y :

(defun c:AddDot(/ fname fname ifile ofile)
  ; By Gia Bach
  (if (and (setq fname (getfiled "Select Input File" (getvar "dwgprefix") "txt" 8))
	   (setq fname (findfile fname))
	   (setq name (getfiled "Select Output File" (getvar "dwgprefix") ";txt" 9)))
    (progn      
      (setq ifile (open fname "r"))
      (setq ofile (open name "w"))
      (if...
>>

Thêm dấu chấm "." sau toạ độ X,Y :

(defun c:AddDot(/ fname fname ifile ofile)
  ; By Gia Bach
  (if (and (setq fname (getfiled "Select Input File" (getvar "dwgprefix") "txt" 8))
	   (setq fname (findfile fname))
	   (setq name (getfiled "Select Output File" (getvar "dwgprefix") ";txt" 9)))
    (progn      
      (setq ifile (open fname "r"))
      (setq ofile (open name "w"))
      (if (and (/= ifile nil)(/= ofile nil))
	(progn
	  (while (setq line (read-line ifile))
	    (setq pos (vl-string-search " Y" line)
		  str (strcat (substr line 1 pos) "." (substr line (+ 1 pos) ) "."))
	    (write-line (strcat str) ofile))
	(close ifile)
	(close ofile) )	)  )  )  
  (princ)  )

Hề hề hề,

Thử chơi thẻ codebox xem có ngon hơn không:

 (defun c:copart (/ pl k plst p1 p2 goc pl1 pl2...
>>

Hề hề hề,

Thử chơi thẻ codebox xem có ngon hơn không:

 (defun c:copart (/ pl k plst p1 p2 goc pl1 pl2 plst1 plst2 plst3 ss ss1 a plg pt l)(vl-load-com)(command "undo" "be")(setq pl (car (entsel "\n Chon pline chuan"))        k (getreal "\n Nhap khoang cach offset: ")        ;;;; obj (vlax-ename->vla-object pl)        plst (acet-geom-vertex-list pl)        p1 (car plst)        p2 (cadr plst)        goc (angle p1 p2))(command "offset" k pl (polar p1 (+ (/ pi 2) goc) k) "")(setq pl1 (entlast)        plst1 (acet-geom-vertex-list pl1))(command "offset" k pl (polar p1 (- goc (/ pi 2)) k) "")(command "zoom" "e")(setq pl2 (entlast)        plst2 (append plst1 (reverse (acet-geom-vertex-list pl2)))        plst2 (append plst2 (list (car plst1)))        ss (ssget "cp" plst2)        ss (ssdel pl1 ss)        ss (ssdel pl2 ss)           	a  (acet-pline-make (list plst2))        plg (entlast)        ;;;; ss (ssadd plg ss)        pt (getpoint p1 "\n Chon diem dat hinh trich")        l (getreal "\n Nhap ty le hinh trich: "));;;;(command "zoom" "p")(command "copy" ss plg "" p1 pt)(command "erase" pl1 pl2 plg "")(setq plg (entlast))(etrim plg (polar pt (+ goc (/ pi 2)) (1+ k)))(setq plst3 (acet-ent-geomextents plg)        ss1 (ssget "w" (car plst3) (cadr plst3))        ss1 (ssdel plg ss1))(command "zoom" "w" (car plst3) (cadr plst3))(command "erase" plg "")(command "scale" ss1 "" pt l) (command "undo" "e")(princ))

Thôi thì chơi kiều chuối này cho chắc ăn vậy:

 

 

(defun c:copart (/ pl k plst p1 p2 goc pl1 pl2 plst1 plst2 plst3 ss ss1 a plg pt l)

(vl-load-com)

(command "undo" "be")

(setq pl (car (entsel "\n Chon pline chuan"))

k (getreal "\n Nhap khoang cach offset: ")

;;;; obj (vlax-ename->vla-object pl)

plst (acet-geom-vertex-list pl)

p1 (car plst)

p2 (cadr plst)

goc (angle p1 p2)

)

(command "offset" k pl (polar p1 (+ (/ pi 2) goc) k) "")

(setq pl1 (entlast)

plst1 (acet-geom-vertex-list pl1))

(command "offset" k pl (polar p1 (- goc (/ pi 2)) k) "")

(command "zoom" "e")

(setq pl2 (entlast)

plst2 (append plst1 (reverse (acet-geom-vertex-list pl2)))

plst2 (append plst2 (list (car plst1)))

ss (ssget "cp" plst2)

ss (ssdel pl1 ss)

ss (ssdel pl2 ss)

a (acet-pline-make (list plst2))

plg (entlast)

;;;; ss (ssadd plg ss)

pt (getpoint p1 "\n Chon diem dat hinh trich")

l (getreal "\n Nhap ty le hinh trich: "))

;;;;(command "zoom" "p")

(command "copy" ss plg "" p1 pt)

(command "erase" pl1 pl2 plg "")

(setq plg (entlast))

(etrim plg (polar pt (+ goc (/ pi 2)) (1+ k)))

(setq plst3 (acet-ent-geomextents plg)

ss1 (ssget "w" (car plst3) (cadr plst3))

ss1 (ssdel plg ss1))

(command "zoom" "w" (car plst3) (cadr plst3))

(command "erase" plg "")

(command "scale" ss1 "" pt l)

 

(command "undo" "e")

(princ)

)

 

Mong các bác chớ giận vì mình không muốn người dùng phải vất vả,

<<

cảm ơn TUE_NV rất rất nhiều!mình đang test thử và chưa thấy có vấn đề gì phát sinh!có gì mình sẽ báo cho TUE nhé!

Nhưng TUE_NV có thể cải tiến thêm 1 tí nữa...

>>

cảm ơn TUE_NV rất rất nhiều!mình đang test thử và chưa thấy có vấn đề gì phát sinh!có gì mình sẽ báo cho TUE nhé!

Nhưng TUE_NV có thể cải tiến thêm 1 tí nữa được ko? đó là cho phép mình chọn vùng để làm!chứ mình mới test thử 1 file khá nhiều nhà thì máy bị treo mất!mình muốn chọn từng vùng để làm dc ko?Thanks TUE_NV rất nhiều!Chúc sức khỏe bạn!

truongthanh thử code này xem nhé :

(defun c:ous(/ oldco oldos mau lay ss i ent dau cuoi ang sskd sskc chon)
(vl-load-com)
 (setq oldco (getvar "cecolor"))
 (setvar "cecolor" "1")
(setvar "pdmode" 3)
 (setq oldos (getvar "osmode"))
 (setvar "osmode" 0)
 (setq mau (car(entsel "\n Pick vao duong mau :")))

 	(setq lay (cdr(assoc 8 (entget mau))))
(initget "V A")
 (setq chon (getkword "\n Ban muon chon theo Vung hay chon toan bo data  :"))
 (if (= chon "V")
 (setq ss (ssget (list(cons 0 "*LINE") (cons 8 lay))))
 (setq ss (ssget "X" (list(cons 0 "*LINE") (cons 8 lay))))
 )
(command "zoom" "e")
 	(setq i 0)
 (while (    (setq ent (ssname ss i)
   	  dau (vlax-curve-getStartpoint ent)
  cuoi (vlax-curve-getendpoint ent)
  ang (angle dau cuoi)
  sskd (ssget "f" (list dau (polar dau ang 0.01)))
  sskc (ssget "f" (list cuoi (polar cuoi ang 0.01)))
   )
   (if (= (sslength sskd) 1) (command "point" dau))
   (if (= (sslength sskc) 1) (command "point" cuoi))
   (setq i (1+ i))
   )
 (command "zoom" "P")
 (setvar "osmode" oldos)
 (setvar "cecolor" oldco)
 (setvar "pdsize" 1)
 (princ)
 )

<<

các bác cho em hỏi

các bác cho em hỏi em có 1 đo9ạn SPL , giao của spl với các đoạn thẳng là A,B,C,D,E,Flàm sao để đo chiều dài các đoạn AB,CB,CD, EFcủa nó 1 các nhanh...

>>

các bác cho em hỏi

các bác cho em hỏi em có 1 đo9ạn SPL , giao của spl với các đoạn thẳng là A,B,C,D,E,Flàm sao để đo chiều dài các đoạn AB,CB,CD, EFcủa nó 1 các nhanh nhất hoặc các bác có lisp cho em cũng ddược .Thank các bác

Bạn sài thử LISP này :

Chấp nhận các đối tuợng : LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE

(defun c:len (/ *error* vl ov ob p1 p2 pa1 pa2 len)
 (defun *error* (msg)
   (if ov (mapcar 'setvar vl ov))
   (redraw ob 4)
   (if (not(wcmatch (strcase msg) "*BREAK,*EXIT*,*CANCEL*"))
     (princ (strcat "\n** Error: " msg " **")))
   (princ))

 (vl-load-com)
 (setq vl '("CMDECHO" "OSMODE" "orthomode")
       ov (mapcar 'getvar vl))
 (mapcar 'setvar vl '(0 33 0))
 (while
   (not
     (and
(setq ob (car(entsel "\nChon doi tuong can do (LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE) : ")))
(if ob (wcmatch (cdr (assoc 0 (entget ob))) "*LINE,ARC,CIRCLE,ELLIPSE") )
)
     )
   (alert "\nDoi tuong da chon khong phu hop.
           \nChap nhan cac doi tuong : LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE
    \nChon lai :")
   )
 (redraw ob 3)
 (while (and
   (setq p1 (getpoint "\nTu diem :"))
   (setq p2 (getpoint "\nDem diem :"))
   )
   (if (and
  (setq pa1 (vlax-curve-getParamAtPoint ob p1))
  (setq pa2 (vlax-curve-getParamAtPoint ob p2))
  )
     (progn
(setq len (abs (- (vlax-curve-getdistatparam ob pa1)
		  (vlax-curve-getdistatparam ob pa2))) )
(princ (strcat "\nChieu dai la : " (rtos len) "\n-------------------"))
)
     (alert "\nDiem chon khong thuoc doi tuong can do ! \nChon lai :" )
     )
   )
 (redraw ob 4)
 (mapcar 'setvar vl ov)
 (princ)
)

<<

Mới sưu tầm cái lisp ghi diện tích của boundary và liên kết diện tích với boundary đó, nghĩa là khi thay đổi boundary, diện tích tự động thay đổi theo. lệnh có hai tùy chọn: B dùng để tạo boundary và ghi diện tích; L để ghi diện tích cho boundary có sẵn. Tặng các bạn , ai thích thì xài:(lệnh là tarb)

(defun ufa (notifier-object reactor-object parameter-list) 
 (vl-load-com) 
 (cond 
  ...
>>

Mới sưu tầm cái lisp ghi diện tích của boundary và liên kết diện tích với boundary đó, nghĩa là khi thay đổi boundary, diện tích tự động thay đổi theo. lệnh có hai tùy chọn: B dùng để tạo boundary và ghi diện tích; L để ghi diện tích cho boundary có sẵn. Tặng các bạn , ai thích thì xài:(lệnh là tarb)

(defun ufa (notifier-object reactor-object parameter-list) 
 (vl-load-com) 
 (cond 
   ((vlax-property-available-p notifier-object "Area") 
    (setq actDoc 
    (vla-get-ActiveDocument (vlax-get-acad-object))) 
    (vla-SAVE actDoc) 
   ) 
 ) 
) 


(defun plar(/ pt pt1 pt2) 
(setq pt (getpoint"\nStarting Point: ")) 
(setq pt1 (getpoint pt "\nNext Point: ")) 
(command "Pline" pt pt1 "") 
  (while 
      (setq pt2 (getpoint pt1"\nNext Point: ")) 
     (command "pline" "" pt2 "") 
     (command "pedit" pt "j" pt pt2 "" "") 
     (setq pt1 pt2) 
  ) 
(command "pedit" pt "c" "") 
(princ) 
) 

(defun ar5 () 
(SETQ A NIL)
(vl-load-com) 

 (setq cm (getvar "cmdecho")) 
 (setvar"cmdecho" 0) 
 (setq fd (getvar "fielddisplay")) 
 (if (/= fd 0)(setvar"fielddisplay" 0)) 

   (setq ar1 (entsel "\nSelect Area Boundary: ")) 
   (setq ar2 (car ar1)) 
   (setq tab (vlax-ename->vla-object ar2)) 
   (setq oba (vla-get-objectid tab)) 

(setq lu (getvar "lunits")) 
(setq tpt (getpoint"\nSelect Area Text Point: ")) 
(cond 
((= lu 2) (setq lin (strcat "%<\\AcObjProp Object(%<\\_ObjId " 
                                   (rtos oba 2 0) ">%).Area \\f \"%lu6%qf1\">%"))) 
((= lu 4) (setq lin (strcat "%<\\AcObjProp Object(%<\\_ObjId " 
                                   (rtos oba 2 0) ">%).Area \\f \"%lu2%ct4%qf1 SQ. FT.\">%"))) 
((= lu 5) (setq lin (strcat "%<\\AcObjProp Object(%<\\_ObjId " 
                                   (rtos oba 2 0) ">%).Area \\f \"%lu5\">%"))) 
((= lu 3) (setq lin (strcat "%<\\AcObjProp Object(%<\\_ObjId " 
                                   (rtos oba 2 0) ">%).Area \\f \"%lu2%ct4%qf1 SQ. FT.\">%"))) 
((= lu 1) (setq lin (strcat "%<\\AcObjProp Object(%<\\_ObjId " 
                                   (rtos oba 2 0) ">%).Area \\f \"%lu1\">%"))) 
) 
(command "mtext" tpt "w" "0" lin "") 
(setq plineReactor (vlr-object-reactor (list tab)  "pline Reactor" '((:vlr-modified . ufa))))

(princ) 
)       

(defun c:tarb (/ key) 
(initget  1 "Boundary/label-area Label-area") 
(setq key (getkword "\nWould you like Boundary/label-area or Label-area: ")) 
  (cond 
    ((= key "Boundary/label-area")(plar)(ar5)) 
    ((= key "Label-area")(ar5)) 
  ) 
(princ) 
)

Đúng vậy bác Nguyen Hoanh, PP đã gặp nhiều trở ngại khi dùng MPLOT.lsp với việc chọn Block (của khung tên)

Thí dụ bản vẽ dưới đây:

Command:MPL

Pick...

>>

Đúng vậy bác Nguyen Hoanh, PP đã gặp nhiều trở ngại khi dùng MPLOT.lsp với việc chọn Block (của khung tên)

Thí dụ bản vẽ dưới đây:

Command:MPL

Pick Block:

Select objects: Specify opposite corner: 20 found

Select objects:

bad argument type: lentityp nil

Nhưng nếu vẽ thêm các Rectange cho mổi khung tên thì MPLOT in được ngay.

Kính nhờ Bác Hoanh check giúp.

http://www.cadviet.com/upfiles/2/multiple_drawings.dwg

lisp B2R (block to rectangle) dưới đây sẽ giúp Phiphi:

(defun c:b2r ()
 (setq ss (ssget '((0 . "INSERT"))))
 (while (setq e (ssname ss 0))
   (setq ss  (ssdel e ss)
  tmp (vla-getboundingbox (vlax-ename->vla-object e) 'p1 'p3)
  p1  (vlax-safearray->list p1)
  p3  (vlax-safearray->list p3)	  
  p1  (list (car p1) (cadr p1))
  p3  (list (car p3) (cadr p3))
  p2  (list (car p1) (cadr p3))
  p4  (list (car p3) (cadr p1))
  tmp (list
	(cons 0 "LWPOLYLINE")
	(cons 100 "AcDbEntity") 
	(cons 100 "AcDbPolyline") 
	(cons 90 4)
	(cons 70 1)
	(cons 10 p1)
	(cons 10 p2)
	(cons 10 p3)
	(cons 10 p4)
      )
   )
   (entmake tmp)
 )
)

<<

Để trực quan hơn, mình gửi file mẫu để tham khảo, file1 trước khi dùng lisp, file2 sau khi dùng lisp. cám ơn bạn đã quan tâm

>>

Để trực quan hơn, mình gửi file mẫu để tham khảo, file1 trước khi dùng lisp, file2 sau khi dùng lisp. cám ơn bạn đã quan tâm

http://www.cadviet.com/upfiles/Drawing1_18.dwg

http://www.cadviet.com/upfiles/Drawing2_7.dwg

Bạn dùng thử LISP sau :

(defun c:ins_point (/ ss i ent point curLayer)
 (if (setq ss (ssget (list (cons 0 "TEXT"))))
   (progn
     (setq i 0
    curLayer (getvar "clayer"))
     (if (not (tblsearch "layer" "points"))
(command "-layer" "n" "points"  "c" "1" "points" "") ) ; tao layer Point
     (setvar "clayer" "points")	    		     ; Set layer Current
     (repeat (sslength ss)
(setq ent (ssname ss i)
      point (cdr (assoc 10 (entget ent)))
      i	 (1+ i)
)
(entmake (list (cons 0 "POINT") (cons 10 point)))
     )
     (setvar "clayer" curLayer)
   )
 )
 (princ)
)

<<

ntSon đã thông hiểu với file *.txt, *.csv. Rất mong SSG nói về cách lấy dữ liệu ở file *.xls, và có 1 ví dụ cụ thể

vd tách dữ liệu từ 1 file *.xls như sau:

A1 ...

>>

ntSon đã thông hiểu với file *.txt, *.csv. Rất mong SSG nói về cách lấy dữ liệu ở file *.xls, và có 1 ví dụ cụ thể

vd tách dữ liệu từ 1 file *.xls như sau:

A1 A2 A3 A4

B1 B2 B4

C1 C2 C3

D1 D2 D3 D4

E1 E2

(Nhiều nhất có 4 cột)

Cảm ơn SSG rất nhiều.

Các file *.txt, *.csv có cách tổ chức data khác nhau nhưng bản chất của chúng đều là TextFile (bao gồm các ký tự ASCII, có thể đọc hiểu được một cách tường minh). Với *.xls thì không phải như vậy. Ví dụ, bạn thử dùng NotePad để open *.xls xem, chỉ thấy một đám ký tự lằng nhằng chẳng hiểu gì cả. Hàm read-line cũng chào thua!

 

AutoLisp "cổ điển" không thể truy xuất *.xls được. Từ khi Autodesk phát triển Visual Lisp (bắt đầu từ version nào ssg không nhớ chính xác, nhưng chắc chắn phải từ 2000 trở đi), kỹ thuật ActiveX được đưa vào, mở ra một khả năng ứng dụng rộng rãi, có thể giao tiếp được với nhiều phần mềm khác nhau, không riêng gì với Excel. Kỹ thuật ActiveX là một mảng rất rộng, có lẽ còn tốn nhiều... giấy mực cho đề tài này. Hãy đợi đấy!

 

Trong Visual Lisp, các function sử dụng kỹ thuật ActiveX được bắt đầu bằng tiếp đầu ngữ VLA. Bạn dùng function GET_xl (lưu ý: luôn luôn phải kèm theo nó function phụ rec-rem-dupl) trong bài ssg trả lời bạn caothang sẽ truy xuất được dữ liệu từ bất kỳ cell nào bạn muốn trong file *.xls. Lưu ý thêm, trước khi gọi các function VLA, bạn phải gọi (vl-load-com) và chỉ cần 1 lần duy nhất trong 1 tài liệu *.dwg đang mở.

Ví dụ:

(defun C:E2C ()
(vl-load-com)
(setq
   fn (getfiled "Select Data File" "" "xls" 0)
   d  (get_xl fn)
)
)

 

Bạn chạy E2C cho file *.xls hôm nọ, kết quả d bạn nhận được là:

Command: E2C

Return:

(("Sheet1$" ("STT" "Ho" "TenDem" "Ten") (1.0 "Kha" "Tran" "Ac") (2.0 "Au" "Duong" "Phong") (3.0 "Hoang" "Duoc" "Su") (4.0 "Hoang" nil "Dung") (5.0 "Quach" nil "Tinh") (6.0 "Hong" "That" "Cong")) ("Sheet2$") ("Sheet3$"))

 

Đây là một list 3 cấp:

- Cấp 1: chứa các sheet

- Cấp 2: chứa các record trong sheet

- Cấp 3: thành phần field trong record

 

Lấy toàn bộ nội dung của sheet1:

Command: (setq s1 (cdr (car d)))

Return:

(("STT" "Ho" "TenDem" "Ten") (1.0 "Kha" "Tran" "Ac") (2.0 "Au" "Duong" "Phong")

(3.0 "Hoang" "Duoc" "Su") (4.0 "Hoang" nil "Dung") (5.0 "Quach" nil "Tinh")

(6.0 "Hong" "That" "Cong"))

 

Cell B4 chẳng hạn (họ của đảo chủ đảo Đào hoa) được lấy như sau:

Command: (nth 1 (nth 3 s1))

Return:

"Hoang"

 

Tương tự như vậy, bạn có thể truy xuất bất kỳ cell nào trong cả file *.xls mà bạn muốn.

<<

1.....

2. Dùng file lisp sau

(defun c:XP () (startapp "explorer" (strcat "/n,/e," (getvar "dwgprefix")))...
>>

1.....

2. Dùng file lisp sau

(defun c:XP () (startapp "explorer" (strcat "/n,/e," (getvar "dwgprefix"))) (princ))

....

Cách 3:

Nhân tổ hộp phím ctrl+o hay open. nhấp vào icon history trên phía trái của cửa sổ hộp thoại

 

Right click vào link shortcut của file chọn properties

 

chọn find target là sẽ đến folder chứa file cần tìm. Cách này có cái hay là có thể tìm file trong vòng 1 tháng ko đụng đến máy tính với điều kiện là không được xoá cookies

<<

Cách đây vài tuần, trên Discovery có chiếu 1 chương trình về 1 đứa bé 12 tuổi tìm thứ trong tuần cho 1 ngày bất kỳ trong thế kỷ 20. Kết...

>>

Cách đây vài tuần, trên Discovery có chiếu 1 chương trình về 1 đứa bé 12 tuổi tìm thứ trong tuần cho 1 ngày bất kỳ trong thế kỷ 20. Kết quả là đứa bé chỉ đáp sai 1 câu. Mục đích chương trình là giới thiệu về khả năng nghe âm thanh tần số cao của trẻ em mà người lớn không có. Tuy nhiên, khi làm chương trình này,  không rõ Discovery có nghĩ tới việc 1 đứa bé tính nhẩm nhanh có thể cho ra kết quả chính xác hơn hay không?

Vì vậy tôi nghĩ đến 1 câu đố về lisp như sau:

Tìm thứ theo ngày, tháng năm bất kỳ, từ ngày 15 / 10 / 1582 (vì quy tắc năm nhuận của lịch Gregory chỉ đúng từ lúc này trở đi)

(defun C:thu ( / d m y)
    (setq d (getint "\nNhap ngay: ") m (getint "Nhap thang: ") y (getint "Nhap nam: "))
    (strcat "Ngay " (itoa d) " thang " (itoa m)  " nam " (itoa y) " la ngay "
         (nth (thu ...) '("chu nhat" "thu hai" "thu ba" "thu tu" "thu nam" "thu sau" "thu bay")))
)
(defun thu (d m y) ...)

Để đơn giản, xem như user nhập d m y hợp lệ

Yêu cầu: chỉ dùng +, - , * , / và rem trong hàm và gọi hàm "thu"

Không dùng biến phụ, setq, lệnh rẽ nhánh hoặc convert như if, cond, fix ...

2 vote cho lời giải đúng đầu tiên, 1 cho những lời giải sau nếu ngắn hơn các lời giải trước.

 

 

Hàm con đạt y/c của chủ đề thì đc.

Còn hàm chính thì "cho em xin" .

Và đây là lời giải :

(defun C:lich ( / d m y G th )

(setq d (getint "\nNhap ngay: ") m (getint "Nhap thang: ") y (getint "Nhap nam: "))

(If (< m 3) (setq m (+ m 12) y (- y 1)))

(setq G (thu d m y))

(mapcar '(lambda (a B)(if (= G a) (setq th B)))

'(1.0 2.0 3.0 4.0 5.0 6.0 7.0)

'("Chu Nhat" "Thu Hai" "Thu Ba" "Thu Tu" "Thu Nam" "Thu Sau" "Thu Bay"))

(If (> m 12) (setq m (- m 12) y (+ y 1)))

(alert (strcat "\n Ngay " (itoa d) " thang " (itoa m) " nam " (itoa y) " la ngay : " th)))

;============

(defun thu (d m y)

(+ (rem (+ (- d 1) (- (* 2.6 (+ m 1)) (rem (* 2.6 (+ m 1)) 1)) (- (* 5.25 (/ y 100)) (rem (* 5.25 (/ y 100)) 1))

(- (* 1.25 (* 100 (- (/ y 100.0) (/ y 100)))) (rem (* 1.25 (* 100 (- (/ y 100.0) (/ y 100)))) 1))) 7) 1))

<<

Chào bạn Phamvanthiet108,

Bạn thử dùng cái này nhé. Mình cải tạo thêm từ chính cái lisp bạn đã post lên. Lưu ý rằng ở lisp này mình chỉ giải quyết đến...

>>

Chào bạn Phamvanthiet108,

Bạn thử dùng cái này nhé. Mình cải tạo thêm từ chính cái lisp bạn đã post lên. Lưu ý rằng ở lisp này mình chỉ giải quyết đến mức độ đảo nhỏ cấp 1 thôi nhé. Nghĩa là nếu trong vùng chọn của bạn có vùng trống trong đảo cấp một là sẽ bị sai đó. Việc tổ hợp đảo và vùng trống nhiều cấp hiện tại mình chưa nghĩ ra giải pháp nào hợp lý cả. Lisp đã được chạy thử trên file bạn đã boundary xong chứ không phải file chưa tạo boundary bạn nhé. Việc tạo Boundary mình chưa giải quyết được.

Việc ghi diện tích ra file hay vẽ lên bản vẽ mình không làm do thiết nghĩ không phải quá khó đối với bạn.

Hy vọng bạn sẽ hài lòng dùng tạm.

(defun c:TDT ()
(setq cmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(prompt "\nchon cac doan can tinh:")
(setq TH (ssget))
(setq SPT (sslength TH))
(setq TOCD 0 DEM 0 dtlst (list) ssent (ssadd) area1 0 )
(while (< DEM SPT)
(setq PT (ssname TH DEM))
(setq CSDL (entget pt))
(setq TDT (cdr (assoc 0 CSDL)))
             (if (equal (cdr  (assoc 70 csdl)) 1 0.0001)
                 (progn
                 (setq dtlst (append dtlst (list pt)))
                 (setq ssent (ssadd pt ssent))
                 )
             )
(setq DEM (1+ DEM))
)
;;;;;;;;;(setq ssent1 (ssadd))
(foreach dt dtlst
            (setq els (entget dt))
            (setq plst (list))
            (foreach a els
                        (if (= (car a ) 10)
                            (setq plst (append plst (list (cdr a ))))
                        )
              )
              (setq ss1 (ssget "WP" plst (list (cons 0 "lwpolyline"))))
              (if ss1
                   (progn
                             (setq n (sslength ss1)
                                         i 0
                              )
                              (while (< i n)
                                       (setq en (ssname ss1 i )
                                               ssent (ssdel en ssent )
                                       )
                                       (command "area" "o" en )
                                       (setq area1 (+ area1 (getvar "area"))
                                               i (1+ i)
                                        )
                                 )
                                 ;;;;;;;;;;;;;;;(setq ssent (ssdel dt ssent)
                                         ;;;;;;;;;;ssent1 (ssadd dt ssent1)
                                 ;;;;;;;;;;;;;;;:lol:
                       )
                 )


)
area1
ssent
(setq j 0)
(repeat (sslength ssent)
          (setq ent (ssname ssent j))
          (command "area" "o" ent)
          (setq CDPT (getvar "AREA"))
          (setq TOCD (+ TOCD CDPT) )
          (setq j (1+ j))
)
(setq TOCD (- TOCD area1))                

(setvar "cmdecho" cmd)
(princ "\nTong dien tich la:")
(setq TCD TOCD)
)

 

Chúc bạn vui.

Em rất cảm cảm bác Bình đã quan tâm đến vấn đề của em.

<<