Chuyển đến nội dung
Diễn đàn CADViet

nhoclangbat

Thành viên
  • Số lượng nội dung

    1.306
  • Đã tham gia

  • Lần ghé thăm cuối

  • Ngày trúng

    35

Bài đăng được đăng bởi nhoclangbat


  1. ;;;;;;;;;;;============================================================
    (defun K:pline (listpoint closed Layer clr / Lst)
    	(setq Lst (list '(0 . "LWPOLYLINE")'(100 . "AcDbEntity")
    	(cons 8 (if Layer Layer (getvar "Clayer")))
    	(cons 62 (if clr clr 256))
        '(100 . "AcDbPolyline")
    	(cons 90 (length listpoint))
    	(cons 70 (if closed 1 0))))
    	(foreach PP listpoint	(setq Lst (append Lst (list (cons 10 PP)))))
    (entmakex Lst))
    ;end;=================================
    ;=================================HAM ENTMAKE VE CICLE
    	(defun K:tron (point R Layer Color)
    	(entmakex (list '(0 . "CIRCLE")
    	(cons 8 (if Layer Layer (getvar "Clayer")))
        (cons 62 (if Color Color 256))
    	(cons 10 point)
    	(cons 40 R)
    	)))
    ;end;=================================
    ;ham tao text 3
    (defun K:text(pt height string justify layer textstyle mau ang / lst)
    (setq lst (list '(0 . "TEXT")
                                  (cons 10 pt)
    							  (cons 40 height)
    							  (cons 1 string)
    							  (cons 50 (if ang ang 0))
    							  (cons 8 (if layer layer (getvar 'clayer)))
    							  (cons 7 (if textstyle textstyle (getvar 'textstyle)))
    							  (cons 62 (if mau mau 256))
    							  
    			)
    			justify (strcase justify))
    		(cond   ((= justify "L") (setq Lst (append Lst (list (cons 72 0) (cons 11 pt)))))
    		        ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 pt)))))
    				((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 pt)))))
    				((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 pt)))))
    				)
    	(entmakex Lst)
      );end K:text
    ;hàm t?o textstyle
    (defun K:style (MyStyle MyFont)
    (entmake (list    (cons 0 "STYLE")    
    (cons 100 "AcDbSymbolTableRecord")    
    (cons 100 "AcDbTextStyleTableRecord")    
    (cons 2 MyStyle)    (cons 3  MyFont)    
    (cons 70 0))))
    ;===============================================****************************++++++++++BAI 4+++++++++*********************===========
    (defun K:layer (ten clr)
    (if (null (tblsearch "LAYER" ten))
    (entmakex (list 
                   '(0 . "LAYER")
                   '(100 . "AcDbSymbolTableRecord")
                   '(100 . "AcDbLayerTableRecord")
    			   '(70 . 0)
                    (cons 2 ten)
                    (cons 62 clr))
    )
    )
    )
    ;===========================================================================================
     (defun C:ghichu(/ old oldd pt pt1 pt2 pt3 vttext h w goc str1 str2 bk pt4 lenstr1 lstp pdau pcuoi kcx obj)
    (vl-load-com)
      (setq old (getvar "OSMODE") oldd (getvar "cmdecho"))
      (setvar "cmdecho" 0)
       (setq str2 (getint "\nNhap so text trong tam:"))
      (setq bk (getreal "\nNhap ban kinh:"))
      (setvar "OSMODE" 512)
      (initget 1)
      (setq pt1 (getpoint "\nChon diem dau: "))
      (setvar "OSMODE" 0)
      (setq pt2 (getpoint pt1 "\ndiem thu 2: "))
      (setq goc (angle pt1 pt2))
      (setq str1 (getstring 1 "\nNhap text ngang: "))
      (setq lenstr1 (strlen str1))
      (setq pt3 (getpoint pt2 "\nHuong diem cuoi: "))
      (if (< (car pt2) (car pt3))
      (progn
        (setq vttext (polar pt2 (/ pi 4) 1.5))
    	(setq obj (K:text vttext 2.5 str1 "L" "GHI-CHU" "VHELVEI" nil nil))
        (setq lstp (vla-getBoundingBox (vlax-ename->vla-object obj) 'minp 'maxp))
    	(setq pdau (vlax-safearray->list minp))
        (setq pcuoi (vlax-safearray->list maxp))
    	(setq kcx (- (car pcuoi) (car pdau)))
        (setq pt3 (polar pt2 0 (+ 2.0 kcx)))
    	(setq pt4 (polar pt3 0 bk))
       )
       (progn
       (setq vttext (polar pt2 (+ (/ pi 2) (/ pi 4)) 1.5))
       (setq obj (K:text vttext 2.5 str1 "R" nil nil nil nil))
        (setq lstp (vla-getBoundingBox (vlax-ename->vla-object obj) 'minp 'maxp))
    	(setq pdau (vlax-safearray->list minp))
        (setq pcuoi (vlax-safearray->list maxp))
    	(setq kcx (- (car pcuoi) (car pdau)))
        (setq pt3 (polar pt2 PI (+ 2 kcx)))
        (setq pt4 (polar pt3 pi bk))
    	)
      );if
      (K:pline (list pt1 pt2 pt3) nil nil nil)
      (K:tron pt4 bk nil nil)
      (K:text pt4 3.0 (itoa str2) "M" nil nil nil nil)
      (setvar "OSMODE" old)
      (setvar "cmdecho" oldd)
      (princ)
      
    )
    
    

    - hi tối giờ nhoc bận, đã sữa cho bạn theo hiện hành ^^


  2. - bạn test thử xem đúng ý chưa hì ^^

    ;;;;;;;;;;;============================================================
    (defun K:pline (listpoint closed Layer clr / Lst)
    	(setq Lst (list '(0 . "LWPOLYLINE")'(100 . "AcDbEntity")
    	(cons 8 (if Layer Layer (getvar "Clayer")))
    	(cons 62 (if clr clr 256))
        '(100 . "AcDbPolyline")
    	(cons 90 (length listpoint))
    	(cons 70 (if closed 1 0))))
    	(foreach PP listpoint	(setq Lst (append Lst (list (cons 10 PP)))))
    (entmakex Lst))
    	;end;=================================
    ;=================================HAM ENTMAKE VE CICLE
    	(defun K:tron (point R Layer Color)
    	(entmakex (list '(0 . "CIRCLE")
    	(cons 8 (if Layer Layer (getvar "Clayer")))
        (cons 62 (if Color Color 256))
    	(cons 10 point)
    	(cons 40 R)
    	)))
    	;end;=================================
    ;;ham tao text 3
    (defun K:text(pt height string justify layer textstyle mau ang / lst)
    (setq lst (list '(0 . "TEXT")
                                  (cons 10 pt)
    							  (cons 40 height)
    							  (cons 1 string)
    							  (cons 50 (if ang ang 0))
    							  (cons 8 layer)
    							  (cons 7 textstyle)
    							  (cons 62 (if mau mau 256))
    							  
    			)
    			justify (strcase justify))
    		(cond   ((= justify "L") (setq Lst (append Lst (list (cons 72 0) (cons 11 pt)))))
    		        ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 pt)))))
    				((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 pt)))))
    				((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 pt)))))
    				)
    	(entmakex Lst)
      )	;end K:text
    ;hàm t?o textstyle
    (defun K:style (MyStyle MyFont)
    (entmake (list    (cons 0 "STYLE")    
    (cons 100 "AcDbSymbolTableRecord")    
    (cons 100 "AcDbTextStyleTableRecord")    
    (cons 2 MyStyle)    (cons 3  MyFont)    
    (cons 70 0))))
    ;===============================================****************************++++++++++BAI 4+++++++++*********************===========
    (defun K:layer (ten clr)
    (if (null (tblsearch "LAYER" ten))
    (entmakex (list 
                   '(0 . "LAYER")
                   '(100 . "AcDbSymbolTableRecord")
                   '(100 . "AcDbLayerTableRecord")
    			   '(70 . 0)
                    (cons 2 ten)
                    (cons 62 clr))
    )
    )
    )
    ;===========================================================================================
     (defun C:ghichu(/ old oldd pt pt1 pt2 pt3 vttext h w goc str1 str2 bk pt4 lenstr1 lstp pdau pcuoi kcx obj)
    (vl-load-com)
      (setq old (getvar "OSMODE") oldd (getvar "cmdecho"))
      (setvar "cmdecho" 0)
       (if (null (tblsearch "style" "VHELVEI")) (K:style "VHELVEI" "VHELVEI.ttf"))
      (if (null (tblsearch "layer" "GHI-CHU")) (K:layer "GHI-CHU" 7))
      (setq str2 (getint "\nNhap so text trong tam:"))
      (setq bk (getreal "\nNhap ban kinh:"))
      (setvar "OSMODE" 512)
      (initget 1)
      (setq pt1 (getpoint "\nChon diem dau: "))
      (setvar "OSMODE" 0)
      (setq pt2 (getpoint pt1 "\ndiem thu 2: "))
      (setq goc (angle pt1 pt2))
      (setq str1 (getstring 1 "\nNhap text ngang: "))
      (setq lenstr1 (strlen str1))
      (setq pt3 (getpoint pt2 "\nHuong diem cuoi: "))
      (if (< (car pt2) (car pt3))
      (progn
        (setq vttext (polar pt2 (/ pi 4) 1.5))
    	(setq obj (K:text vttext 2.5 str1 "L" "GHI-CHU" "VHELVEI" nil nil))
        (setq lstp (vla-getBoundingBox (vlax-ename->vla-object obj) 'minp 'maxp))
    	(setq pdau (vlax-safearray->list minp))
        (setq pcuoi (vlax-safearray->list maxp))
    	(setq kcx (- (car pcuoi) (car pdau)))
        (setq pt3 (polar pt2 0 (+ 2.0 kcx)))
    	(setq pt4 (polar pt3 0 bk))
       )
       (progn
       (setq vttext (polar pt2 (+ (/ pi 2) (/ pi 4)) 1.5))
       (setq obj (K:text vttext 2.5 str1 "R" "GHI-CHU" "VHELVEI" nil nil))
        (setq lstp (vla-getBoundingBox (vlax-ename->vla-object obj) 'minp 'maxp))
    	(setq pdau (vlax-safearray->list minp))
        (setq pcuoi (vlax-safearray->list maxp))
    	(setq kcx (- (car pcuoi) (car pdau)))
        (setq pt3 (polar pt2 PI (+ 2 kcx)))
        (setq pt4 (polar pt3 pi bk))
    	)
      );if
      (K:pline (list pt1 pt2 pt3) nil "GHI-CHU" nil)
      (K:tron pt4 bk "GHI-CHU" nil)
      (K:text pt4 3.0 (itoa str2) "M" "GHI-CHU" "VHELVEI" nil nil)
      (setvar "OSMODE" old)
      (setvar "cmdecho" oldd)
      (princ)
      
    )
    
    
    • Vote tăng 1

  3. "Pick trượt" hiểu đơn giản thế này: ý định người dùng pick vào điểm để chọn nhưng lỡ tay pick ra khoảng trống bên cạnh gần điểm đó nhóc. Khi trường hợp này xảy ra thì điểm  sẽ bị hiểu là "nil"

     - ^^ vậy là điểm cần pick đã đc xác định, thì nhoc sẽ đưa while vào khi nào bắt trúng điểm đó mới cho chuột nghĩ, còn mún nil lun thì ko cần while, nhoc sẽ set = if

    • Vote tăng 1

  4. - trượt theo kiủ nào Hieu nhỉ ^^, nhầm chuột phải hay enter thì mình có thể dùng initget khống chế, còn nhầm mục tiêu pick thì phải xét mục tiêu như thế nào mới pit đặt điều kiện bỏ vào while đc, như lệnh trên thì nó chỉ vẽ line bất kỳ nên không cần dùng while ^^


  5. - hi mấy anh trợ giúp nhoc với, bài toán text né line, nhoc mót nhặt từ nhiều nơi tới đc đây mà vẫn còn xíu gì đó nhoc vẫn chưa hiểu ^^, chạy vẫn chưa đc như ý.

    - vd: vẽ 1 rectang sau đó viết text trên các đỉnh, justy là middle, mã 11 trùng với đỉnh. khi chạy quét từng text thì nó chạy đúng ý nhoc là 45 độ là góc đầu tiên, còn quét 1 lần để duyệt thì mỗi text lại chạy khác nhau đúng ra đều 45 độ hết, mặc dù xung quanh đang trống chưa có vật cản nào ^^

    (defun move_text (position height / r ang found pt1 pt2 ssobj newpos)
    
      (setq	r (* 1.2 height)
    	ang   (/ pi 4)
    	found nil
      )
    
      (while (and (not found) (<= ang (* 2 pi)))
    
        (setq newpos (polar position ang r)
    	  pt1	 (list (- (car newpos) (/ height 2.0)) (- (cadr newpos) (/ height 2.0)) 0.0)
    	  pt2	 (list (+ (car newpos) (/ height 2.0)) (+ (cadr newpos) (/ height 2.0)) 0.0)
        )
    
        (setq ssobj (ssget "_C" pt1 pt2))
    
        (if	(= ssobj nil)
          (setq found T)
        )
    
    
        (setq ang (+ ang (/ pi 9)))
      )
    
      (if found
        newpos
        nil
      )
    
    )
    ;--------------------------------------------------------------------------------------------------
    (defun c:test (/ sstext ssl ent enx newvt pos)
    (setq sstext (ssget '((0 . "TEXT"))))
    (if sstext
    (progn
    ;---------------------------------
    (setq	ssl (sslength sstext))
    	  
      (repeat ssl
        (setq ent  (ssname sstext 0)
    	  enx  (entget ent)
    	  pos  (cdr (assoc 11 enx))
    	 )
         
        (setq newvt (move_text pos 3.5))
        (if	newvt
        (entmod (subst (cons 11 newvt) (assoc 11 enx) enx))
    	(princ "Ko ne dc\n")
        )
    
        (ssdel ent sstext)
      )
      ) ;end progn
     ) ;end if sstext
     (princ)
    )
    

  6. - ^^, khó phết anh Tue nhỉ, khuya rùi nhoc mới mò đc vậy ko biết  có ổn ko, nhưng hơi dài kaka,mai lại bận cả ngày ko có thời gian ngâm tiếp ^^

    (defun c:caodo(/ chon hh kk c_do c)
    (setq chon (car (entsel "\nchon cao do chuan:")))
    (if (= chon nil)
    (progn
    (setq hh (getvar "lastprompt"))
    (setq kk (strlen "chon cao do chuan: "))
    (setq c_do (distof (substr hh kk)))
    )
    (setq c_do (distof (cdr (assoc 1 (entget chon)))))
    )
    (princ (setq c (+ 0.5 c_do)))
    (princ)
    )
    
    • Vote tăng 1

  7. Sorry bạn. Chắc bạn nghỉ quá cao siêu quá mà do mình lại diễn đạt không thấu đáo. Mình thì viết lisp dựa vào mấy cái lisp có sẵn rồi chế lại thôi nên hiểu đơn giản nên nói vậy.

    Trường hợp của mình là như vậy nè:

    sau khi gõ lệnh: caodo

    yêu cầu nhập cao độ chuẩn.

    Lúc này có thể chọn trên màn hình luôn hoặc đánh số vào,

    Vậy đó.

    Không biết thế này được chưa nữa

    mong bạn bỏ qua nếu không hiểu

    - vậy ban thử cách nhoc nêu xem có đúng ý bạn ko ^^, yêu cầu nhập cao độ, ko nhập thì enter hay chuột phải bỏ qua lsp sẽ nhảy qua bước chọn text trên màn hình

    ^^

    (if (setq c_do (getreal "\nnhap cao do chuan:"))
    c_do
    (setq c_do (distof (cdr (assoc 1 (entget (car (entsel "\nchon cao do chuan:")))))))
    )
    
    • Vote tăng 1

  8. - hi lúc trước nhoc cũng ngơ ngơ 2 thằng này ^^, Hieu xem ví dụ này ngâm cứu thử :)

    (Null '()) => T
    (Null '(1 2 3)) => NIL
    (Null nil) => T
    (Null t) => NIL
    (Null 234,4) => NIL
    (Null "ngọng") => NIL

    - hiểu theo cách thổ dân của nhoc null là 1 hàm kiểm tra  , còn nil đại diện cho biến trống ko có giá trị => nil là con của null ^^.

    - Null  là hàm để kiểm tra xem một biến có Null ko , tức biến đó có nil ko (trích bác gugồ :P )

    • Vote tăng 1

  9. - ah đc ^^, nhoc ít xài bên 3d nên ít để ý trục Z, mới xực nhớ có đọc qua dùng lệnh 3dpoly có thể add Z lun ^^, code sẽ đc viết lại như thế này ^^

    (defun c:rrr(/ )
    (setq a '(1 2 3 4))
    (setq b '(2 7 8 9))
    (setq lst_new (mapcar '(lambda (x) (cdr x)) (list a b)))
    (apply 'command (append (list ".3dPoly") lst_new (list "")))
    ) 
    

    - các điểm đó sẽ đúng theo lst vd:  x=2 y=3 z=4, 

    • Vote tăng 1

  10. - Vẽ pline qua các điểm đó chắc đc ^^ nhưng nhoc chưa pit cách add đc Z của từng điểm vào pline, nhoc cũng chưa hiểu cách chuyển từ text sang lst của Hieu như thế nào, quét tới đâu chuyển tới đó hay quét hết 1 lúc rùi chuyển lun, nhoc có code mấy  dòng Hieu thử xem sao

    (defun c:rrr(/ )
    (setq a '(1 2 3 4))
    (setq b '(2 7 8 9))
    (setq lst_new (mapcar '(lambda (x) (cdr x)) (list a b)))
    (K:pline lst_new nil nil nil)
    ) 
    ;;;;;;;;;;;============================================================
    (defun K:pline (listpoint closed Layer clr / Lst)
    	(setq Lst (list '(0 . "LWPOLYLINE")'(100 . "AcDbEntity")
    	(cons 8 (if Layer Layer (getvar "Clayer")))
    	(cons 62 (if clr clr 256))
        '(100 . "AcDbPolyline")
    	(cons 90 (length listpoint))
    	(cons 70 (if closed 1 0))))
    	(foreach PP listpoint	(setq Lst (append Lst (list (cons 10 PP)))))
    (entmakex Lst))
    	;end;================================= 

    - biến a, b giả sử tương ứng với các lst tọa độ trả về của Hieu

    • Vote tăng 1

  11. - hi nhoc viết thí nghiệm  thử dùng grread ấy mà ^^, nếu lsp bạn Hieu viết để chuyển góc phương vị thì nhoc nghĩ chỉ để quay 1 đoạn thẳng là line, mục đích gì đó thì nhoc chưa pit, còn mún xoay nhóm obj hay polyline thì nhoc chưa làm nổi kaka.

    - anh Ha giúp nhoc các dùng grread nhập liệu từ bàn phím mà có giới hạn như bạn Hieu hỏi từ 0-180, vậy là mình sẽ có 2 cách trả về 1 là pick 2 là nhập liệu, nhoc chưa pit phải làm sao ^^


  12. Ok rồi nhoc ơi!

    Mình đang chỉnh cho text xuất ra có 2 chữ số thập phân, không biết lisp nên mò chỗ nào có số 1 đổi thành số 2 thử... hihi

    Cảm ơn nhoc nhé.

    - ek ^^ đổi vậy coi chừng nguy hiểm, trong đó nhiều số 1 lắm ^^, bạn kím ngay dòng này sữa số 1 thành 2 là đc nè

    (K:text pt1 h (strcat (rtos dt 2 1) "m%%178") "M" "ab-dientich" chon nil nil) => đổi số 1 màu đỏ thành số 2 là ok


  13. - hihi Hieu có ghé ngang qua xem thử, nhoc mới học hàm grread, cũng thử múa rìu xíu tận dụng lsp roo của Hieu chỉnh lại = grread, vấn đề giới hạn góc nhập thì nhoc chưa xử đc, nhưng giữ được sợi thun quay quay cho Hieu ^^, quay tới đầu sẽ hiển thị góc phương vị tại chỗ đó ^^ dưới dòng command, khi nào ok, pick chuột trái tại vị trí mún xác định thì đoạn thẳng cũ sẽ chuyển tới đó, mấy anh có hứng giúp nhoc cải tiến phần nhập dữ liệu cho nhoc học hỏi thêm ^^, mò sáng giờ vẫn chưa pit với grread thì xử sao ^^

    (defun c:roo(/ doigoc start end *error* vars ovars nvars dt db dh dg tt ent lst px pg p nhap edd info)
     (defun doigoc(goc)
      (rem (- 450.0 goc) 360.0))
     (defun start()
      (setq vars '("osmode" "cmdecho" "angdir" "angbase"))
      (setq ovars (mapcar 'getvar vars)
            nvars (mapcar 'setvar vars (list 0 0 1 (/ pi 2)))))
     (defun end()
      (and ovars (mapcar 'setvar vars ovars)))
     (defun *error* (ABC)
      (end))
     (vl-load-com) 
     (princ "Chon Doi Tuong Can Quay: ") 
     (setq dt (ssget)
           db (getpoint "\nChon BasePoint:")
           ent (ssname dt 0)
    	   info (entget ent)
           lst (mapcar 'cdr (vl-remove-if-not '(lambda(x) (or (= (car x) 10) (= (car x) 11))) (entget ent))))
     (command "undo" "be")    
     (start)
     ;=========================================================================================
     (if (< (distance db (setq px (car lst))) (distance db (setq pg (cadr lst))))
     (alert (strcat "\nPhuong Vi cu <" (rtos (doigoc (* 180.0 (/ 1 pi) (angle px pg))) 2 2) ">"))
     (alert (strcat "\nPhuong Vi cu <" (rtos (doigoc (* 180.0 (/ 1 pi) (angle pg px))) 2 2) ">"))
     )
     ;=========================================================================================
     (if (< (distance db (setq px (car lst))) (distance db (setq pg (cadr lst))))
      (progn 
     ;==================================================================================================
    (while (/= (car (setq nhap (grread t 15 0))) 3)
           (redraw)
    	   (if (= (car nhap) 5)
    	     (progn
    	        (setq p (cadr nhap))
    		   	(grdraw db p 1 1)
    			(prompt (strcat "\nPhuong Vi hien la <" (rtos (doigoc (* 180.0 (/ 1 pi) (angle db p))) 2 2) ">"))
    		 )
    		)
    )
    p
    (setq ang (angle db p))
    (setq edd (entmod (append info (list (cons 10 db) (cons 11 (polar db ang (distance px pg)))))))
    ;====================================================================================================   
          (redraw)
       )
    ;======================================================================================================
      (progn 
     ;====================================================================================================
    (while (/= (car (setq nhap (grread t 15 0))) 3)
           (redraw)
    	   (if (= (car nhap) 5)
    	     (progn
    	        (setq p (cadr nhap))
    		    (grdraw db p 1 1)
    			(prompt (strcat "\nPhuong Vi hien la <" (rtos (doigoc (* 180.0 (/ 1 pi) (angle db p))) 2 2) ">"))
    		 )
    		)
    )
    p
    (setq ang (angle db p))
    (setq edd (entmod (append info (list (cons 10 db) (cons 11 (polar db ang (distance px pg)))))))
    ;===================================================================================================   
         (redraw)
       )
     ;-------------------------------------------------------
     ) ;end if 
     (end)
     (command "undo" "e")
     )
     
    
    • Vote tăng 1

  14. - ^^ ah quên lsp mình nó tính khác, cái đó chỉ là đánh số vùng đã chọn, diện tích từng hình nó vô file txt chứ ko in ra text ^^, khi nào pick hết enter để chọn điểm ghi ra diện tích tổng các hình đã pick 

    - nhoc sữa lại xíu giống với lsp cũ của bạn

    
     
    
    ;========================================================================================
    (defun ReplaceString (old_str new_str str / m n) (vl-load-com)
    (setq m 0 n (strlen new_str))
    (while (setq m (vl-string-search old_str str m))
    (setq str (vl-string-subst new_str old_str str m))
    (setq m (+ n m))
    )
    str
    )
    ;========================================================================================
    (defun tachsym(str sym / datach kytu dem lstdatach)
      (setq dem 1)
      (while (<= dem (strlen str))
        (setq datach "")
        (setq kytu (substr str dem 1))
        (while (and (/= kytu sym) (<= dem (strlen str)))
          (setq datach (strcat datach kytu))
          (setq dem (+ dem 1))
          (setq kytu (substr str dem 1))
        ); end while con
        (setq dem (+ dem 1))
        (setq lstdatach (append lstdatach (list datach)))
      ) ;end while me
      datach
    )
    ;=============================================================
    ;======================================================================================================================
    (defun K:dsbg (table / lst phu)
    (tblnext table t)
    (while (setq phu (tblnext table nil))
    (setq lst (cons (cdr (assoc 2 phu)) lst))
    )
    )
    ;================================
    (defun c:dt(/ tl ntl tl2 h k tdt pt pt1 pt5 ss  frome toe cur dt S laos K:text getvalueK lacol ladin dt ss1 ten K:layer K:style ds_style e1 e1 chon)
    (vl-load-com)
    ;=====================================================================
     ;==================================================
    ;ham tao text 2
    (defun K:text(pt height string justify layer textstyle mau ang / lst)
    (setq lst (list '(0 . "TEXT")
                                  (cons 10 pt)
    							  (cons 40 height)
    							  (cons 1 string)
    							  (cons 50 (if ang ang 0))
    							  (cons 8 layer)
    							  (cons 7 textstyle)
    							  (cons 62 (if mau mau 256))
    							  
    			)
    			justify (strcase justify))
    		(cond   ((= justify "L") (setq Lst (append Lst (list (cons 72 0) (cons 11 pt)))))
    		        ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 pt)))))
    				((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 pt)))))
    				((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 pt)))))
    				)
    	(entmakex Lst)
      );end K:text
    ;--------------------------------------
    ; ham luu gia tri
    (defun getvalueK ( a giatri dongnhac / astr) 
    (or a (setq a giatri))
    (cond
    	((= (type a) 'INT) (setq a (cond ((getint (strcat "\n" dongnhac "(" (itoa a) ") :")))(a))))
    	((= (type a) 'REAL) (setq a (cond ((getreal (strcat "\n" dongnhac "(" (rtos a 2 1) ") :")))(a))))
    	((= (type a) 'STR) (setq a (cond ((= "" (setq astr (getstring T (strcat "\n" dongnhac " (" a "): ")))) a) (astr))))
    ))
    ;;;;
    ;=================================================================================
    (defun K:layer (ten clr)
    (if (null (tblsearch "LAYER" ten))
    (entmakex (list 
                   '(0 . "LAYER")
                   '(100 . "AcDbSymbolTableRecord")
                   '(100 . "AcDbLayerTableRecord")
    			   '(70 . 0)
                    (cons 2 ten)
                    (cons 62 clr))
    )
    )
    )
    ;========================================================================================
    ;hàm t?o textstyle
    (defun K:style (MyStyle MyFont)
    (entmake (list    (cons 0 "STYLE")    
    (cons 100 "AcDbSymbolTableRecord")    
    (cons 100 "AcDbTextStyleTableRecord")    
    (cons 2 MyStyle)    (cons 3  MyFont)    
    (cons 70 0))))
    ;=====================================================================================
    (if (= fname nil)
        (setq fname (getfiled "Chon tap tin luu so lieu" "//" "txt" 1))
      )
      (setq fo (open fname "a"))
      (princ "Cac dien tich da chon:" fo)
      (princ "\n" fo)
    ;======================================================================================
     (if (null (tblsearch "layer" "ab-dientich")) (K:layer "ab-dientich" 4))
     (if (null (tblsearch "style" "VAVON")) (K:style "VAVON" "VAVON.ttf"))
    ;===================================================================================
    (setvar "cmdecho" 0)
    (command "undo" "begin")
    (setq lacol (getvar "CEColor"))
    (setq ladin (getvar "dimzin"))
    (setq laos (getvar "osmode"))
    (setq lacl (getvar 'clayer))  
    ;================================================================
    (setq ds_style (vl-princ-to-string (K:dsbg "style")))
    (setq e1 (tachsym ds_style "("))
    (setq e2 (Xstrcase (tachsym e1 ")")))
    (initget 1 e2)
    (setq chon (getkword (strcat "Nh\U+1EADp ch\U+1EEF \U+0111\U+1EA7u t\U+00EAn Style m\U+00FAn set: < "  (ReplaceString " " "/" e2)  " >:")))
    ;========================================================
    (setq tl (getvalueK tl 1000.0 "Mau so Ti le ht "))
    (setq ntl (/ 1000 tl))
    (setq h (getvalueK h 1.8 "Nhap chieu cao text "))
    (setq tl2 (* ntl ntl))
    ;==================================================================
    (setq k 0 tdt 0)
    (setvar "dimzin" 0)
    (setvar "OSMODE" 0)
    ;======================================
    ;===========================================================
    (initget 1)
    (setq pt1 (getpoint "\n Chon mien tinh dien tich: "))
    (while (/= pt1 nil)
    (setq k (+ 1 k))
    ;-----------------------------------------------------------------------------
    (setq frome (entlast));; chon doi tuong cuoi cung truoc khi boundary
    (command "cecolor"1 "-boundary" pt1 "");; boundary
    (setq toe (entlast));; chon doi tuong cuoi cung sau khi boundary
    (setq cur frome	ss (ssadd) S 0)
    (while 	(not (eq cur toe));; chon cac doi tuong tu frome den toe
    
    	(setq cur (entnext cur) ss (ssadd cur ss))
    
    	(command "area" "S" "O" ss "" "")
    
    	(setq dt (/ (getvar "AREA") tl2) S (+ S dt))
    
    );while
    
    (command "area" "A" "O" "L" "" "")
    
    (setq dt (/ (getvar "AREA") tl2))
    
    (setq S (+ S (* dt 2))) 
    (K:text pt1 h (strcat (rtos dt 2 1) "m%%178") "M" "ab-dientich" chon nil nil)  
    (princ dt fo)
    (princ " m2")
    (princ "\n" fo)
    (setvar "CEColor" lacol)
    ;==========================================
    ;===================================================================
    (setq pt1 (getpoint (strcat "\nchon mien do tiep theo...")))
    );while
    ;=======================================================================
    (setvar "DIMZIN" ladin)
    ;================================================
    ;=================================================================================
    ;===============
    (setvar 'clayer lacl)
    ;=====================
    (setvar "OSMODE" laos)
    (command "undo" "end")
    (close fo)
    (setvar "cmdecho" 1)
    (princ "\n")
    (princ "xong")
    (princ)
    )
     
    

     

    • Vote tăng 1
×