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

buithengan1

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

    31
  • Đã tham gia

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

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


  1. Bạn tìm trong lisp, thay thế đoạn mã Lisp:

                    (command "lengthen" e_name "")

                    (setq tot_len (+ tot_len (getvar "PERIMETER")))

    Bằng: 

                   ;(command "lengthen" e_name "")

                   ; (setq tot_len (+ tot_len (getvar "PERIMETER")))

                    (vl-load-com)

                   (setq tot_len (+ tot_len (vla-get-Length (vlax-ename->vla-object e_name))))

    Rồi thử lại xem thế nào.

    Mình thử rồi mà vẫn ko dc bạn ơi


  2. Mình có lisp này nhưng ko biết vì sao sử dụng trên cad 2018 bị lỗi. ai biết sửa lỗi giúp mình với cảm ơn nhiều

    cad nó báo lỗi này

     

     52064_12312.jpg

    (defun C:tg (/ tot_len ss e_name e_record e_type Tkq obn obd)
    (while
      (setq tot_len 0.0)
    
      (setq ss (ssget))
    
      (if (null ss)
    
        (exit)
    
      )
    
      (while (> (sslength ss) 0)
    
        (setq e_name (ssname ss 0))
    
        (setq e_record (entget e_name))
    
        (setq e_type (cdr (assoc '0 e_record)))
    
        (cond ((wcmatch e_type "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")
    
    	   (command "lengthen" e_name "")
    
    	   (setq tot_len (+ tot_len (getvar "PERIMETER")))
    
    	   (ssdel e_name ss)
    
    	  )
    
    	  ((wcmatch e_type "MLINE") (add_mline))
    
    	  (e_type (ssdel e_name ss))
    
        )
    
      )
    (prompt (strcat "\nTotal length is: " (rtos tot_len 2 2)))
    (setq en (car (entsel "Thay cho so : ")))
    (while (= en nil)
    (setq en (car (entsel "Thay cho so : ")))
    )
    (setq elst (entget en))
    (setq elstold (assoc 1 elst)) 
    (setq elstnew (cons 1 (rtos tot_len 2 2)))
    (setq elst (subst elstnew elstold elst))
    (entmod elst)
    (setq elst nil)
    (setq dtl nil)
    (command "_change" en "" "p" "c" "1" "")
    ;(START_PG)
    	;(setq obd (vlax-ename->vla-object (car (nentsel "\nChon text ghi chieu dai"))))
    	;(vla-put-textstring obd (rtos tot_len 2 2))
    ;(END_PG)
      ;(princ)
      )
      )
    ;;;;;
      
    

  3. mình có lisp cắt đối tượng tại giao điểm nhưng muốn sửa lại cách chọn đối tượng của lisp theo layer.

    như trong ví dụ là Chon Line/Polyline bi cắt là layer "plineintn" và Chon cac Line/Polyline để cắt  là

    "plinetaluytrai" và "plinetaluypha

    (defun c:brk(/ ent os)
      (vl-load-com)
      (defun ints (o1 o2 / l0 l)
        (setq l (vlax-Invoke (vlax-EName->vla-Object o1) "IntersectWith" (vlax-EName->vla-Object o2) acExtendBoth)
     l0 nil)
        (while l
          (setq l0 (append l0 (list (list (car l) (cadr l) (caddr l))))
       l (cdddr l)))
        l0
      )
      (command "undo" "be") 
      (setq ent (car (entsel "\nChon Line/Polyline bi cat:"))
    os (getvar 'osmode))
      (setvar 'osmode 0)
      (prompt "\nChon cac Line/Polyline de cat:")
      (mapcar '(lambda(x) (mapcar '(lambda(y) (command "break" ent y y)) (ints ent x)))
        (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "LINE,*POLYLINE")))))))
      (command "undo" "e") (setvar 'osmode os)
    ) 

    http://www.cadviet.com/upfiles/5/52064_mau_1.dwg

    i"

    • Vote giảm 1

  4. (Defun c:k()
    (while
    (setq cmd (getvar "cmdecho"))
    (setq osm (getvar "osmode"))
    (setq nbc (getvar "clayer"))
    	(setvar "cmdecho" 0)
    	(command "osnap" "none")
    	(initget "Heso Do")
    	(setq pt (getpoint "\n HE SO / < CHON DIEM>: "))
       	(if (= pt "Heso")
    	    	(progn	
    			(setq am (getreal " HE SO: "))
    			(if (and (null am) (/= ac 0))
    				(setq am ac)
    			)
    		(setq pt (getpoint "\n CHON DIEM: "))	
    		)
    		(setq ac am))
    			
    	(if (or (= am 0) (null am)) (setq am 1))
    	(setq s 0)
    	(progn 
    ;		(setq pt (getpoint "\n CHON DIEM: "))	
    	      (while pt
    			(setq entold (cdr (assoc 5 (entget (entlast)))))
    			(command "boundary" pt "")
    			(setq entnew (cdr (assoc 5 (entget (entlast)))))
    			(if (/= entold entnew)    
    				(progn 
                            	(setq entnew (entget (entlast)))
                            	(if (assoc 62 entnew)
                              		(setq entnew (subst (cons 62 (+ 3 (cdr (assoc 62 entnew)))) (assoc 62 entnew) entnew))
                              		(setq entnew (append entnew (list (cons 62 (+ 3 (cdr (assoc 62 (tblsearch "layer" (cdr (assoc 8 entnew))))))))))
                              	)
    				
                              
                            	(entmod entnew)
                            	(Command "area" "o" (entlast))
    					(setq s (+ s (getvar "area")))
       					(setq pt (getpoint "\n CHON DIEM: "))
    					(entdel (entlast))
    	        		)
    				(progn
    					(princ "CHON DIEM SAI")
    					(setq pt (getpoint "\n CHON DIEM: "))
    				)
    			)
    		  )
    
                )
    	(PRINt " CHON TEXT CAP NHAT KHOI LUONG")
    	(SETQ SS1 (SSGET))
    	(SETQ DS (ENTGET (SSNAME SS1 0)))
    	(SETQ ND (CDR (ASSOC 1 DS)))
    	(SETQ LCT (STRLEN ND))
    	(SETQ DEM 1)
    	(SETQ DEM1 1)
    	(WHILE (< DEM LCT)
    		(PROGN
    			(SETQ BT (SUBSTR ND DEM 1))
    			(IF (= BT "=") (SETQ DEM1 DEM) (SETQ DEM1 (+ DEM1 1)))
    			(IF (= BT "=") (SETQ DEM LCT) (SETQ DEM (+ DEM 1)))
    		)
    	)	
    	(SETQ ND1 (SUBSTR ND 1 DEM1))
    	(SETQ ND2 (RTOS (* S AM) 2 2))
    	(SETQ ND3 (STRCAT ND2))
    	(SETQ NDM (CONS 1 ND3))
    	(SETQ NDC (CONS 1 ND))
    	(SETQ DS (SUBST NDM NDC DS))
    	(ENTMOD DS)
    (setvar "cmdecho" cmd)
    (setvar "clayer" nbc)
    (setvar "osmode" osm)
    (princ (* s am))
    )
    )
    

    bạn có thể sửa hộ mình lisp này sau khi cập nhật khối lượng tự động đổi màu của text luôn được không. cảm ơn bạn nhiều


  5. mấy anh cho em hỏi khi xuất text điểm đo bằng nova thì tọa độ xuất ra khác với tọa độ hiển thi trên cad là lý do vì sao vậy?

    khi dùng tọa độ đó áp lại vào cad thì tọa độ các điểm mốc ko còn đúng nữa vậy làm sao để cho tọa độ các mốc đúng trở lại 

    cảm ơn các anh nhiều.

    http://www.cadviet.com/upfiles/5/52064_hoc_dieu.txt

    http://www.cadviet.com/upfiles/5/52064_ho_hoc_dieu_hc.dwg


  6.  

    Bạn thử cái này.

     

    (defun C:LGT (/ obn Tkq Lob)
    (setq obn (vlax-ename->vla-object (car (nentsel "\nChon doi tuong nguon")))
    Tkq (strcat "%<\\AcObjProp Object(%<\\_ObjId " (itoa (vla-get-objectid obn)) ">%).TextString>%")
    )
    (while (setq obd (car (nentsel "\nChon text dich")))
    (vla-put-textstring (vlax-ename->vla-object obd) Tkq)
    )
    (vl-cmdf "regen")
    (princ)
    )
    

    hay quá cảm ơn bạn nhiều


  7. (defun C:LGT (/ obn Tkq Lob)
    	(START_PG)
    	(setq obn (vlax-ename->vla-object (car (nentsel "\nChon doi tuong nguon")))
    				obd	(vlax-ename->vla-object (car (nentsel "\nChon text dich")))
    				Tkq	(strcat "%<\\AcObjProp Object(%<\\_ObjId "
    										(rtos (vla-get-objectid obn) 2 0)
    										">%).TextString>%"
    						)
    	)
    	(vla-put-textstring obd Tkq)
    	(vla-update obd)
    	(vl-cmdf "regen")
    	(END_PG)
    	(princ)
    )
    
    

    lisp này copy text từ đối tượng này sang đối tượng khác và tự động thay đổi khi đối tượng nguồn thay đổi nó có khuyết điểm là chỉ chọn đc 1 đối tượng đích giờ mình muốn chọn nhiều giá trị đích hơn nhờ mọi người sửa giúp mình. cảm ơn

    • Vote tăng 1
    • Vote giảm 1

  8.  

    Bạn dùng cái này thử xem.

    Chọn 1 khung pline rồi chọn cái tên khung (ô-..), chọn tới đâu xuất excel tới đó.

    Phần diện tích k biết lấy đơn vị là gì.

     

    (defun c:tta (/ ss ss1 y xlApp xlCells row col i iPt)
      (vl-load-com)      
      (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 0 col 1)
      (vla-put-visible xlApp :vlax-true)
     
      (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X" '((0 . "TEXT"))))))
    sst (vl-remove-if-not '(lambda (x) (distof (vla-get-TextString (vlax-ename->vla-object x)))) ss)
    sst (mapcar '(lambda (x) (list (vlax-get (vlax-ename->vla-object x) 'TextAlignmentPoint)
     (vla-get-TextString (vlax-ename->vla-object x)))) sst)
      )
      (prompt "\nChon khung pline:")
      (while (setq pl (ssget ":E:S" '((0 . "LWPOLYLINE"))))
        (mapcar '(lambda (x) (redraw x 4)) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X")))))
        (setq pl (ssname pl 0)) (redraw pl 3)
        (setq oo (car (entsel "\nChon ten cua khung:")))  (redraw pl 4) (redraw oo 3)
        
        (setq  ssd (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= 10 (car x))) (entget pl))) 
     lst (list (vla-get-TextString (vlax-ename->vla-object oo)))
        )
        (foreach pt ssd
          (setq txt (car (vl-sort sst '(lambda (x y) (< (distance (car x) pt) (distance (car y) pt)))))
       lst (append lst (list (last txt))) 
          )
        )
        (setq lst (append lst (list (vla-get-Area (vlax-ename->vla-object pl))))
     i -1 row (1+ row))
        (mapcar '(lambda (x) (vlax-put-property xlCells "Item" row  (+ col (setq i (1+ i))) x)) lst)
        (prompt "\nChon khung pline:")
      )
      (mapcar 'vlax-release-object (list xlApp xlCells))
      (mapcar '(lambda (x) (redraw x 4)) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X")))))
      (redraw)
      (princ)
    )
    

    ban tot77 oi cái  lisp của bạn chỉ sử dụng được với text nằm ngang thôi còn với các text  khác 0 độ thì ko được bạn có thể sửa lại hộ mình được không cảm ơn bạn.


  9.  

    Bạn dkkx3a và bạn xaakiii_mboet có thể cho biết bạn đánh cấp cho Pline gấp khúc, nhưng bạn đánh cấp với trường hợp các cấp nằm dưới Pline sử dụng trong trường hợp thực tế nào không?

    Tue_NV sử dụng Lisp đánh cấp với các cấp nằm trên Pline trong trường hợp đánh bậc cấp.

    Tue_NV xin nâng cấp vào Lisp : đánh cấp cho pline gấp khúc ở 2 trường hợp :

    1. Các cấp nằm trên pline

    2. các cấp nằm dưới pline

    Các bạn sử dụng thử xem : (áp dụng đúng luôn cho Spline)

    (defun c:dcap(/ curve B sp ep Lx n po1 po2 po3 i oldos ans)(vl-load-com)(command "undo" "be")(setq oldos (getvar "osmode"))(setvar "osmode" 0)(setvar "cmdecho" 0)(setq curve (car(entsel "\n Ban Pick chon Pline :")) ss (ssadd))(while (null curve) (setq curve (car(entsel "\n Ban Pick chon lai Pline :")))) (setq B (getdist "\n Nhap be rong danh cap :"))(initget "T D")	(setq ans (getkword "\n Ban danh cap Tren hay Duoi duong pline < T / D > :"))(setq sp (vlax-curve-getStartPoint curve))(setq ep (vlax-curve-getEndPoint curve))	(if (> (cadr sp) (cadr ep))   		(progn			(setq ep (vlax-curve-getStartPoint curve))			(setq sp (vlax-curve-getEndPoint curve))		))(setq Lx (abs (- (car ep) (car sp)) ))(setq n (abs(fix (/ (- Lx (rem Lx B )) B ))) i 1)(setq po1 sp)(Repeat n(setq dvi (list (+ (car sp) (* i B )) (cadr sp) 0))(command "Xline" "Ver" dvi "")(setq po3 (car (giaodt curve (entlast))) )(entdel (entlast))(if (= ans "D")(setq po2 (list (car po3) (cadr po1) 0))(setq po2 (list (car po1) (cadr po3) 0)))(dline po1 po2) (dline po2 po3)(setq po1 po3)(setq i (1+ i)))(if (= ans "D")(setq po2 (list (car ep) (cadr po1) 0))(setq po2 (list (car po1) (cadr ep) 0)))(dline po1 po2)(dline po2 ep) (setvar "osmode" oldos)(command "undo" "end")(princ));(defun dline(p1 p2)(entmake (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2))));(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 nilsd (fix (/ (length g) 3)))(repeat sd(setq kq (append kq (list (list (car g) (cadr g) (caddr g))))g (cdddr g)))kq)nil))
    Hiện nay chức năng download Lisp file của diễn đàn bị lỗi. Nếu bạn sử dụng chức năng download Lisp file của diễn đàn bị lỗi thì hãy nhấn nút Reply bài viết này của Tue_NV -> chép hết code về (không sót đấy nhé về chạy thử là được

    Chúc thành công tongue2.gif

    bạn tue-nv ơi bạn có thể sửa giùm mình cái lisp này thành  đánh cấp với chiều cao H cho trước được không. cảm ơn bạn trước nha

×