6 giờ trước, binbin72088@gmail.com đã nói:

Cảm ơn anh

>>

6 giờ trước, binbin72088@gmail.com đã nói:

Cảm ơn anh @cuongtk2 nhiều lắm, lisp đúng ý lun, lần đầu tiên e xài lisp bằng vba luôn. Đồng thời cũng cảm ơn anh @thiep vì rất hào hiệp. E cũng muốn biết bản chất cách làm như nào để tự làm cho trục oy nữa, mấy anh cho em biết nguyên lý được ko? Ban đầu e nghĩ là dùng SSget rồi chọn các vertex, rồi dùng hàm for cho từng điểm, sau đó move lần lượt các điểm về 0, e biết sơ sơ ko biết vậy có đúng ko?

"Bản chất làm như nào để tự làm cho trục oy nữa" là dùng hàm vlax-curve-getClosestPointTo để tìm điểm gần nhất của điểm này trên 1 curve nào đó. Như vậy, bất kỳ curve ở hướng nào, nó cũng tìm được điểm getClosestPoinTo (ở đây curve là 1 line // với trục ox hoặc oy)

Bạn thử lisp này với phương Line là // trục Ox hoặc Oy. Nếu bạn muốn phương của Line bất kỳ thì khi lisp yêu cầu "Pick endpoint line:" thì nhấn nút F8.

(defun emLINE (pt1 pt2)
  (entmakex (list (cons 0 "LINE")
                  (cons 100 "AcDbEntity")
                  (cons 100 "AcDbLine")
                  (cons 10 pt1)
                  (cons 11 pt2)
            )
  )
)
(defun PointInside (pt ptlst / l_dis)
    (mapcar '(lambda (x) (setq l_dis (cons (distance pt x) l_dis))) ptlst)
    (acet-geom-point-inside pt ptlst (apply 'max l_dis))
)
;;; Lisp stretch vertexes's lwpolyline inside a window to line
;;; by Trân Thiêp, tel: 0918841230        
(defun c:trev (/ p1       p2       porect   enttemp  ss       entLine
                 enttempLWP        p1       p2       p3       p4       entlst
                 obj      orthomode_o       L1 lstpo vlapt poner
                )
  (setq acadObj (vlax-get-acad-object)
        doc     (vla-get-ActiveDocument acadObj)
        *Model* (vla-get-ModelSpace doc)
  )
  (defun *error* (msg)
    (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
        (princ (strcat "\n** Error: " msg " **"))
    )
    (acet-sysvar-restore)
    (vla-EndUndoMark doc)
    (princ)
  )
  (vla-StartUndoMark doc)
  (acet-sysvar-set (list "cmdecho" 0 "osmode" 0))
  (setq orthomode_o (getvar "ORTHOMODE"))
   
  (setq p1 (getpoint "\nPick point1 window: ")
        p2 (getcorner p1 "\nPick point2 corner: ")
  )
  (setq ss (ssget "_C" p1 p2 '((0 . "*POLYLINE"))))
  (setq porect (acet-geom-rect-points p1 p2))
  (setvar "ORTHOMODE" 1)
  (setq p3 (getpoint "\nPick startpoint line: ")
        p4 (getpoint p3 "\nPick endpoint line: ")
  )
  (setq entLine (emLINE p3 p4))
  (setvar "ORTHOMODE" orthomode_o)
  (setq l1 nil)
  (setq vlapt (vlax-make-safearray vlax-vbdouble '(0 . 1)))
  (setq entlst (acet-ss-to-list ss))
  (if entlst
    (progn (foreach ent entlst
             (setq L1 nil)
             (setq obj (vlax-ename->vla-object ent))
             (setq lstpo (acet-geom-vertex-list ent))
             (foreach po lstpo
               (if (PointInside po porect)
                 (progn
                   (setq poner (vlax-curve-getClosestPointTo entLine po T))                   
                   (vlax-safearray-fill vlapt (list (car poner) (cadr poner)))
                   (vla-put-Coordinate obj
                                       (fix (vlax-curve-getParamAtPoint ent po))
                                       vlapt
                   )
                 )

               )
             )

           )
           (acet-sysvar-restore)
           (vla-EndUndoMark doc)
           (princ "\nOk")
    )
  )
  (princ)
)

 

<<

Quick code xem bạn dùng cái nào thì dùng ^^

Vanilla lisp

(defun c:al(/ s kq i)
(while (not (setq s (ssget...
>>

Quick code xem bạn dùng cái nào thì dùng ^^

Vanilla lisp

(defun c:al(/ s kq i)
(while (not (setq s (ssget (list (cons 0 "*TEXT"))))))
(setq kq 0 i -1)
(entmake 
	(list (cons 0 "MTEXT")
	(cons 100 "AcDbEntity")
	(cons 100 "AcDbMText")
	(assoc 8 (entget (ssname s 0)))
	(cons 1
		(rtos
		(repeat (sslength s)
			(setq kq (+ kq (cond ((distof (cdr (assoc 1 (entget (ssname s (setq i (1+ i))))))))(0))))	
		))
	)
	(cons 10 (getpoint "\nInsert point :"))
	)
)
(princ))

- Visual lisp :

 

(defun c:vl(/ d s l lr)(vl-load-com)		
	(while (not (ssget (list (cons 0 "*TEXT")))))
	(vlax-for x 
		(setq s (vla-get-activeselectionset (setq d  (vla-get-activedocument (vlax-get-acad-object)))))
		(setq l (cons (cond ((distof (vla-get-textstring x)))(0)) l))
		(or lr (setq lr (vla-get-layer x)))
	)
	(vla-put-layer
		(vla-addmtext 
			(vla-get-block (vla-get-activelayout d))
			(vlax-3d-point (getpoint "\nInsert point :"))
			(getvar 'textsize)
			(rtos (apply '+ l))
		)
		lr
	)
	(and s (not(vla-delete s))(vlax-release-object s))
	(princ)
)

- Hoặc kết hợp với acet

(defun c:acet(/ s)
(entmake 
	(list (cons 0 "MTEXT")
	(cons 100 "AcDbEntity")
	(cons 100 "AcDbMText")	
	(cons 1 (rtos
		(apply '+ (mapcar '(lambda(x)(cond ((distof (acet-dxf 1 (entget x))))(0))) (acet-ss-to-list (setq s (ssget (list (cons 0 "*TEXT"))))))))
	)
	(assoc 8 (entget (ssname s 0)))
	(cons 10 (getpoint "\nInsert point :"))
	)
)
(princ))

Lưu ý với bạn là các code trên (kể cả của bác Bee đều k tính đến trường hợp đối tượng chọn là các Mtext có kèm mã như mã xuống dòng, layẻ, màu sắc, chiều cao ....

 

bác bày cho e cách sửa lisp al từ mtext thành text được ko ạ? e sửa mtext thành text+ bỏ 2 dòng dưới mà nó ko ra kết quả ạ :)

<<

Download lisp

Filename: 408919_acet.lsp

Vì mấy anh chia sẻ rồi em cũng thử bằng cách nêu lúc đầu. Chứ không có ý làm ảnh hưởng đến bác @Doan Nguyen Van nhé!

(defun getVert (e / i L) ;;;Return list of all vertex from pline e
(setq i 0 L nil)
(vl-load-com)
(repeat (fix (+ (vlax-curve-getEndParam e) 1))
    (setq L (append L (list (vlax-curve-getPointAtParam e i))))
    (setq i (1+ i))
)
L
)
(defun c:STR(/ ent p1...
>>

Vì mấy anh chia sẻ rồi em cũng thử bằng cách nêu lúc đầu. Chứ không có ý làm ảnh hưởng đến bác @Doan Nguyen Van nhé!

(defun getVert (e / i L) ;;;Return list of all vertex from pline e
(setq i 0 L nil)
(vl-load-com)
(repeat (fix (+ (vlax-curve-getEndParam e) 1))
    (setq L (append L (list (vlax-curve-getPointAtParam e i))))
    (setq i (1+ i))
)
L
)
(defun c:STR(/ ent p1 cmd osm L diem1 diem2 diem3 diem4 diem5 diem6 diem7 kc1 kc2 L1 L2 L3
gt1 gt2 gt3 list1 list2 doan1 doan2 doan3 doan4 doan5 doan6 doan7 doan8 sset k lay1 lay2 lay3 lay4 lay5 lay6 ssetz  )
(prompt "Chon doi tuong muon STRETCH")
(setq ent (car (entsel)))
(setq p1 (getpoint "\nChon diem muon STRETCH den:"))
(command ".undo" "BE") 
(setq cmd (getvar "CMDECHO"))
(setq osm (getvar "OSMODE"))
(setvar "CMDECHO" 0)
(setvar "OSMODE" 0)
(setq L (getvert ent))
(setq L (vl-sort L '(lambda (x y) (> (cadr x)(cadr y)))))
(setq diem1 (car (nth 0 L)))
(setq diem2 (car (nth 1 L)))
(setq diem3 (cadr (nth 0 L)))
(setq diem4 (cadr (nth 1 L)))
(setq diem5 (car p1) )
(setq diem6 (list diem5 diem3 ))
(setq diem7 (list diem5 diem4 ))
(setq kc1 (distance (nth 0 L) diem6))
(setq kc2 (distance (nth 1 L) diem7))
(setq L1 nil ) 
(setq L2 nil ) 
(setq L3 nil ) 
(setq j 0)
(if (< diem1 diem2)
(progn
;(alert "loaij1")
(if (< kc1 kc2)
(progn
;(alert "trai")
(while (< j (length L) )
(setq gt1 (/ (atof (itoa j)) 2))
(setq gt2 (fix gt1))
(setq gt3 (- gt1 gt2))
(if (= gt3 0)
(progn
(setq list1 (nth j L))
(setq L1 (append L1 (list list1)))
)
(progn
(setq list2 (nth j L))
(setq L2 (append L2 (list list2)))
)
)
(setq j (1+ j))
)
)
)
(if (> kc1 kc2)
(progn
;(alert "phai")
(while (< j (length L) )
(setq gt1 (/ (atof (itoa j)) 2))
(setq gt2 (fix gt1))
(setq gt3 (- gt1 gt2))
(if (/= gt3 0)
(progn
(setq list1 (nth j L))
(setq L1 (append L1 (list list1)))
)
(progn
(setq list2 (nth j L))
(setq L2 (append L2 (list list2)))
)
)
(setq j (1+ j))
)
)
)
)
(progn
;(alert "loaij2")
(if (< kc1 kc2)
(progn
;(alert "phai")
(while (< j (length L) )
(setq gt1 (/ (atof (itoa j)) 2))
(setq gt2 (fix gt1))
(setq gt3 (- gt1 gt2))
(if (= gt3 0)
(progn
(setq list1 (nth j L))
(setq L1 (append L1 (list list1)))
)
(progn
(setq list2 (nth j L))
(setq L2 (append L2 (list list2)))
)
)
(setq j (1+ j))
)
)
)
(if (> kc1 kc2)
(progn
;(alert "trai")
(while (< j (length L) )
(setq gt1 (/ (atof (itoa j)) 2))
(setq gt2 (fix gt1))
(setq gt3 (- gt1 gt2))
(if (/= gt3 0)
(progn
(setq list1 (nth j L))
(setq L1 (append L1 (list list1)))
)
(progn
(setq list2 (nth j L))
(setq L2 (append L2 (list list2)))
)
)
(setq j (1+ j))
)
)
)
)
)
(setq k 0)
(while (< k (length L1) )
(setq doan1 (nth k L1))
(setq doan6 (car p1) )
(setq doan7 (cadr (nth k L1)))
(setq doan8 (list doan6 doan7 0.0) )
(setq	doan2 (polar doan1 0 1))
(setq	doan3 (polar doan1 0 -1))
(setq	doan4 (polar doan2 (/ pi 2) 1))
(setq	doan5 (polar doan3 (/ pi 2) -1))
(setq sset (ssget "_C" doan5 doan4 '((0 . "*POLYLINE"))))
(setq kc2 (distance doan1 doan8))
(command "stretch" sset "" doan1 doan8)
(setq k (1+ k))
)
;(setq lay1 (nth 0 L1))
;(setq lay2 (nth (- (length L1) 1) L1))
;(setq	lay3 (polar lay1 (/ pi 2) 10))
;(setq	lay4 (polar lay2 (/ pi 2) -10))
;(setq	lay5 (polar lay3 0 10))
;(setq	lay6 (polar lay4 0 -10))
;(setq ssetz (ssget "_C" lay5 lay6 '((0 . "*POLYLINE"))))
;(command "stretch" ssetz "" lay1  pause)
(setvar "CMDECHO" cmd)
(setvar "OSMODE" osm)	
(command ".undo" "E")
(princ)
)

15 giờ trước, VO HINH đã nói:

DungNguyen685  có thểm thêm...

>>

15 giờ trước, VO HINH đã nói:

DungNguyen685  có thểm thêm lệnh để lisp hoàn chỉnh đc k?

 tạo bảng thổng kế sắp xếp tên và ký hiệu theo thứ tự  kt 01- kt 02.....

(defun c:DM (/ at>att at>item at>set atable cnt cw ena nc nr pt j list1 list2 list3 L rh) 
   (vl-load-com)
   ;; GET_ATTS BY BILL KRAMER
   (defun get_ATTS (EN / EL ATTS)
(setq EL (entget EN))
(setq ENA (cdr (assoc 2	 EL))) ; wiz
(if (and (= (cdr (assoc 0 EL)) "INSERT")
     (= (cdr (assoc 66 EL)) 1)
    ) ;_ end and
    (progn
    (setq EN (entnext EN)
          EL (entget EN)
    ) ;_ end setq
    (while (= (cdr (assoc 0 EL)) "ATTRIB")
        (setq ATTS (cons (list
                 (vla-get-ObjectID
                  (vlax-ename->vla-object EN)
                 ) ; wiz
                 (cdr
                     (assoc 2 EL)
                 ) ;_ end_cdr
                 (cdr (assoc 1 EL))
                 ) ;_ end_list
                 ATTS
               ) ;_ end_cons
          EN   (entnext EN)
          EL   (entget EN)
        ) ;_ end setq
    ) ;_ end while

    (list ena (reverse ATTS)) ; wiz

    ) ;_ end progn
) ;_ end if
   ) ;_ end_defun
   (if    (setq at>set (ssget '((0 . "INSERT"))))
(progn
    (setq at>att
         (mapcar 'get_atts
             (vl-remove-if
             'listp
             (mapcar 'cadr (ssnamex at>set))
             ) ;_ end_vl-remove-if
         ) ;_ end_mapcar
    ) ;_ end_setq
    (setq PT (getpoint "\nTable insertion point: ")
      RH (* 2.0 (getvar "TEXTSIZE"))
      CW (* 20.0 (getvar "TEXTSIZE"))
      NR (+ 2 (length at>att))
      NC (1+ (length (cadar at>att)))
    ) ;_ end_setq
    (setq
    aTable (vla-addtable
           (vla-get-modelspace
               (vla-get-activedocument
               (vlax-get-acad-object)
               ) ;_ end_vla-get-activedocument
           ) ;_ end_vla-get-modelspace
           (vlax-3d-point PT)
           NR
           NC
           RH
           CW
           ) ;_ end_vla-addtable
    ) ;_ end_setq
    (vla-setcellvalue aTable 0 0 "DANH M\U+1EE4C B\U+1EA2N V\U+1EBC")
    (vla-setcellvalue aTable 1 0 "STT")
    (vla-setcellvalue aTable 1 1 "T\U+00CAN B\U+1EA2N V\U+1EBC") 
    (vla-setcellvalue aTable 1 2 "K\U+00DD HI\U+1EC6U")
    (vla-MergeCells aTable 1 1 2 (length (cadar at>att)))
	;(princ     (cadr at>att))
;;edit by tavantants	
(setq L nil ) 
(setq j 0)
(while (< j (length  at>att) )
	(setq list1 (nth j at>att))
	(setq list2 (nth 2 (cadr (nth 1 list1))))
	(setq list3 (substr list2 (+ 2 (vl-string-search " " list2))))	
	(setq L (append L (list (list  list3 (nth 1 list1)      ))))	
(setq j (1+ j))
)
(setq L (vl-sort L '(lambda (x y) (< (atof(car x)) (atof(car y))))))
;;edit by tavantants
    (setq CNT 2) ;_ end_setq
    (foreach Item L
    (vla-setcellvalue aTable CNT 0 (- CNT 1)) ;Thay  (car Item) thành (- CNT 1)
    (setq at>item 1)
    (while (<= at>item (length (cadar L)))
        (vl-catch-all-apply
        '(lambda ()
             (vla-settext
             aTable
             CNT
             at>item
             (strcat " "
                 "%<\\AcObjProp Object(%<\\_ObjId "
                 (itoa (car (nth (1- at>item) (cadr Item))))
                 ">%).TextString>%"
             ) ;_ end_strcat
             ) ;_ end_vla-setcellvalue
;;edit by tavantants			 
			 (vla-SetCellAlignment aTable CNT 0 5)
			 (vla-SetCellAlignment aTable CNT 1 4)			 
			 (vla-SetCellAlignment aTable CNT 2 5)			 
	(vla-setTextHeight aTable (- CNT 0) (getvar "TEXTSIZE"))			 	 
	(vla-SetColumnWidth aTable 0 (* 6 (getvar "TEXTSIZE")) )    ;(getvar "TEXTSIZE")
	(vla-SetColumnWidth aTable 1 (* 24 (getvar "TEXTSIZE")))			 
	(vla-SetColumnWidth aTable 2 (* 14 (getvar "TEXTSIZE")))	
	(vla-SetRowHeight aTable 0 (* 2 (getvar "TEXTSIZE")))
	(vla-SetRowHeight aTable 1 (* 2 (getvar "TEXTSIZE")))
	(vla-SetRowHeight aTable 2 (* 2 (getvar "TEXTSIZE")))	
	(vla-SetRowHeight aTable (- CNT 0) (* 2 (getvar "TEXTSIZE")))
;;edit by tavantants	
         ) ;_ end_lambda
        ) ;_ end_vl-catch-all-apply
        (setq at>item (1+ at>item))
    ) ;_ end_while
    (setq CNT (1+ CNT))
    ;;ready next row
    ) ;_ end_foreach
) ;_ end_progn
   ) ;_ end_if
   (princ)
) ;_ end_Defun

Bạn thử cái này. Chú ý ký hiệu bản vẽ giữa chữ với số là dấu cách.

VD: KT 01 hoặc KT 1

Còn nếu muốn thay đổi bằng ý tự "-" hay gì đó thì sửa trong 2 dấu " " chỗ này.

(setq list3 (substr list2 (+ 2 (vl-string-search " " list2))))

Mình có edit thêm một số chỗ giãn dòng và cột phụ thuộc vào TEXTSIZE, nên để textstyle Standard font họ arial hay vni... để không bị lỗi font.

<<

Chú ý tên block mới không trùng với các block cũ trong bản vẽ.

(defun c:cre (/ err oer res sta bb entzx sttt made)										
  (defun err(s)
    (if (and (/= s "Function cancelled")(/= s "quit / exit abort"))
      (princ (strcat "\n>>Error: " s))
      )
    (res)
    )
  (defun res()
    (if cla (setvar "Clayer" cla))
    (setq *error* oer)
    (setvar "Cmdecho" 1)
    (princ)
   ...
>>

Chú ý tên block mới không trùng với các block cũ trong bản vẽ.

(defun c:cre (/ err oer res sta bb entzx sttt made)										
  (defun err(s)
    (if (and (/= s "Function cancelled")(/= s "quit / exit abort"))
      (princ (strcat "\n>>Error: " s))
      )
    (res)
    )
  (defun res()
    (if cla (setvar "Clayer" cla))
    (setq *error* oer)
    (setvar "Cmdecho" 1)
    (princ)
    )										
  (defun sta()
    (setq oer *error*
	  *error* err
	  cla (getvar "Clayer")
	  )
    (setvar "Cmdecho" 0)
    (setvar "Clayer" "0")
    (graphscr)
    )										
  (defun made(/ loop ss p)
    (setq loop T)
    (while loop
      (princ "\nChon doi tuong tao block: ")
(setq p1 (getpoint "\nPick point1 window: ")
      p2 (getcorner p1 "\nPick point2 corner: ")
)
  (setq ss (ssget "_C" p1 p2 ))  
      (if (null ss)(exit))	  
(setq sttt 0)
(while (< sttt (sslength ss))
	(setq entzx (ssname ss sttt))
	(setq bb (cdr (assoc 0 (entget entzx))))
	(if (= bb "INSERT")
		(command "EXPLODE" entzx )
	)
	(setq sttt (1+ sttt))
)	  
	  (setq sss (ssget "_C" p1 p2 )) 
	  (princ "\nChon text lam name block: ")
	  (setq ssText (ssget ":S:E" '((0 . "MTEXT,TEXT"))))	  
	  (if (null ssText)(exit))	  
      (setq p (getpoint "\nChon diem dat block: "))
      (if (null p)(exit))
      (command "_.Undo" "_Group")
      (command "_.Cutclip" sss "")
      (command "_.Pasteblock" p)
	  (setq ent (entlast))
	  (setq dxf1 (cdr(assoc 1 (entget (ssname ssText 0) ))))
	  (setq dxf2 (cdr(assoc 2 (entget ent ))))	  
      (command "-RENAME" "B" dxf2 dxf1 )	  
      (command "_.Undo" "_End")
      )
    )
	
  (sta)
  (made)
  (res)
(princ)
  )

tôi sử dụng thì gặp lỗi sau:

Command: locso

Select object: ; error: misplaced dot on input

Mong các bạn xem lại giúp. Thanks

>>

tôi sử dụng thì gặp lỗi sau:

Command: locso

Select object: ; error: misplaced dot on input

Mong các bạn xem lại giúp. Thanks

Bạn sửa như sau:

(defun c:locso()
 (setq te (car (entsel))
text (cdr (assoc 1 (entget te)))
sl (strlen text)
kq ""
i 1)
 (while (< i sl)
   (setq so (substr text i 1))
   (if (/= so ".")
     (progn
   (if (numberp (read so))
     (setq kq (strcat kq so))
     )
     )
     (setq kq (strcat kq so))
     )
   (setq i (1+ i))
   )
 kq
 )

Trước khi in làm cái cho đỡ quên up :D

;;===============SUPER UP DIM, UP TEXT THEO VIEWPORT=======================================
(defun c:SUP( / oldCmdEcho listVPorts itemVPort ss ssl temp ed old new )
(vl-load-com)
(setq oldCmdEcho (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq currentLayout (getvar "ctab"))
(setvar "CTAB" "Model")
(command "_.ucs" "w");Ve lai Model va dat lai UCS...
>>

Trước khi in làm cái cho đỡ quên up :D

;;===============SUPER UP DIM, UP TEXT THEO VIEWPORT=======================================
(defun c:SUP( / oldCmdEcho listVPorts itemVPort ss ssl temp ed old new )
(vl-load-com)
(setq oldCmdEcho (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq currentLayout (getvar "ctab"))
(setvar "CTAB" "Model")
(command "_.ucs" "w");Ve lai Model va dat lai UCS ve World
(foreach lay (layoutlist) (setvar "CTAB" lay)

(if (/= (getvar "CTAB") "Model")
 (progn
  (command "zoom" "all")
  (setq listVPorts (vl-sort (vports) '(lambda(v1 v2) (< (car v1) (car v2)))))
  (if (> (length listVPorts) 1)
   (progn
    (command "_MSPACE")
    (foreach itemVPort (cdr listVPorts)
     (setvar "CVPORT" (car itemVPort))
      ; (vpsel "W")
      (setq ent (vlax-vla-object->ename
                    (vla-get-activepviewport
                      (vla-get-activedocument (vlax-get-acad-object)))))
      (setq cvscale (vla-get-customscale (vlax-ename->vla-object ent)))
      (setvar "dimscale" (/ 1 cvscale))
      (setq cvscale (strcat "D" (rtos (/ 1 cvscale) 2 0)))
      (if (not (tblsearch "DIMSTYLE" cvscale))
      (command "-DIMSTYLE" "s" cvscale)
      (command "-DIMSTYLE" "r" cvscale) )
      (setq SCALE (getvar "dimscale"))
      ; (command "DIM1" "UP" "P" "")
      (vpsel "W")
      (c:UP)
    )
    (command "_PSPACE")
   )
   (prompt "\nThere are no viewports defined in this Layout!")
  )
 )
 (prompt "\nThis routine works only in Layout!")
)
);END foreach
(setvar "CMDECHO" oldCmdEcho)
(setvar "CTAB" currentLayout)
(princ)
)
;=====================================================================================
;https://lispbox.wordpress.com/2015/05/05/selecting-objects-within-viewport-and-copy-it-to-clipboard-by-selecting-a-ps-viewport/
;;; vpsel.lsp
; By Jimmy Bergmark
; Copyright (C) 1997-2006 JTB World, All Rights Reserved
; Website: http://www.jtbworld.com (http://www.jtbworld.com)
; E-mail: info@jtbworld.com
; 2000-04-14 - First release
; Tested on AutoCAD 2000
; DESCRIPTION
; Select all visible objects in selected or active paperspace viewport Works transparently when in modelspace and for polygonal viewports too
; Example1: ERASE ALL R 'VPC >>> Erase all in model except what is visible
; Example2: (command "erase" "all" "r" (c:vpc) "")
; Example3: VPC ERASE >>> VPC is run previous the command and the objects are also in previous selection set
; c:vpc - select all visible objects with crossing in viewport
; c:vpw - select all visible objects with window in viewport
; Phai dua UCS ve World ******************************************************************************************************************************************
(defun vpsel (typ / ad ss ent vpno ok vpbl vpur msbl msur msul mslr pl nlist x n)
 (vl-load-com)
 (setq ok t)
 (if (= (getvar "tilemode") 0)
  (progn
   (setq ad (vla-get-activedocument (vlax-get-acad-object)))
   (if (= (getvar "cvport") 1)
    (if (and (= (getvar "cmdactive") 0) (/= (setq ss (ssget ":E:S" '((0 . "VIEWPORT")))) nil))
     (progn
      (setq ent (ssname ss 0))
      (setq vpno (dxf 69 (entget ent)))
      (vla-Display (vla-get-activepviewport ad) :vlax-true)
      (vla-put-mspace ad :vlax-true)
      (setvar "cvport" vpno))
     (progn
      (setq ok nil)
      (princ)))
  (setq ent (vlax-vla-object->ename (vla-get-activepviewport ad))))
(if (and ok (/= 1 (logand 1 (dxf 90 (setq ed (entget ent))))))
(progn
(if (= (vla-get-clipped (vlax-ename->vla-object ent)) :vlax-false)
(progn
(vla-getboundingbox
(vla-get-activepviewport ad) 'vpbl 'vpur)
(setq msbl (trans (vlax-safearray->list vpbl) 3 2))
(setq msur (trans (vlax-safearray->list vpur) 3 2))
(setq msul (list (car msbl) (cadr msur)))
(setq mslr (list (car msur) (cadr msbl)))
(setq ss1
(ssget (strcat typ "P") (list msbl msul msur mslr))))
(progn
(setq pl (entget (dxf 340 (entget ent))))
(setq nlist nil)
(foreach x pl
(if (eq 10 (car x))
(setq nlist (cons (trans (cdr x) 3 2) nlist))))
(setq ss1 (ssget (strcat typ "P") nlist))))
(sssetfirst nil ss1)
(if ss1
(setq n (sslength ss1))
(setq n 0))
(princ n)
(princ " found ")
(if (and ss1 (= (getvar "cmdactive") 1))
ss1
(princ)))
(princ)))
(princ)))
;=============================================================================================

https://www.youtube.com/watch?v=ywKjGk7k8lo

7 giờ trước, emhoccad đã nói:

E đang có rất nhiều Bloc cần...

>>

7 giờ trước, emhoccad đã nói:

E đang có rất nhiều Bloc cần đổi màu đối tượng bên trong nó.

cần lisp đổi các màu như sau:

- màu xanh --> trắng

- màu vàng--> màu xanh nước biển

Sau khi đổi xong Block (Cad ko cho đổi tên giống nhau trong cùng bản vẽ) vẫn giữ được tên như cũ, ảnh minh họa và file bản vẽ tham khảo

 

 

 

E cảm ơn các bác ah.

 

 

doimaublock.dwg

Hàng về chủ thớt test nhé. ^_^

(defun c:test  (/ ss e blk doc)
  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (if
    (setq ss (ssget ":L" '((0 . "INSERT"))))
     (repeat (setq i (sslength ss))
       (setq e (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
       (setq blk (vla-item (vla-get-blocks doc) (vla-get-effectivename e)))
       (vlax-for x  blk
         (cond
           ((= (vlax-get x 'layer) "2")
            (vla-put-layer x "4")
            )
           ((= (vlax-get x 'layer) "3")
            (vla-put-layer x "7")
            )
           
           )         
         )
       )
     )
  (vla-regen doc acallviewports)
  (princ)
  )

 

<<

 

Ý 1 : Quick code :

 

(defun c:test(/ i adoc daolst )(vl-load-com)
(defun daolst (lst p / lst1 i a <img...
>>

 

Ý 1 : Quick code :

 

(defun c:test(/ i adoc daolst )(vl-load-com)
(defun daolst (lst p / lst1 i a <img src='http://www.cadviet.com/forum/public/style_emoticons/<#EMO_DIR#>/cool.png' class='bbc_emoticon' alt='B)' />
(setq p (car (vl-sort lst '(lambda(x y)(< (distance p x)(distance p y))))))
(cond
  ((setq a (member p lst)) (setq i -1)  
  (setq b (append a
   (reverse(repeat (vl-position p lst)
	(setq lst1 (cons (nth (setq i (1+ i)) lst) lst1))
   ))
  )))
)
b
)
(command "undo" "be")
(setq i -1 a (acet-geom-vertex-list (car (entsel "\nChon Pline :"))) a (daolst a (getpoint "\nDiem bat dau danh so :")))
(mapcar '(lambda(x y)(or (eval x) (set x y))
(set x (cond ((getreal (strcat "\nNhap " (vl-princ-to-string x) ": <" (rtos (eval x) 2 2) ">")))
((eval x))
   )
))
'(1st inc h)'(1 1 1))
(mapcar
'(lambda(x)
  (vla-addtext
   (cond  (adoc)
((setq adoc (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))))
   )
   (rtos (+ 1st (* (setq i (1+ i)) inc)) 2 0)
   (vlax-3d-point x)
   h
  )
)
(if (wcmatch (getstring "\nGiu nguyen chieu ? <y> ") ",")
  a
  (reverse a)
)
)(command "undo" "en")
)

- Ý 2 của bạn k có cơ sở, vì mình tạo Dtext chứ k tạo Mtext, và mình tạo theo style hiện hành

Trong lisp này có daolst là gì thế bác nhỉ? vì khi dùng lisp này thì cad báo là  error: no function definition: DAOLST? Bác có cách nào sửa được không?

<<

Quick code. Lần sau bạn nhớ chú ý cách đặt vấn đề và nội quy box này :

 

(defun c:test(/ i...
>>

Quick code. Lần sau bạn nhớ chú ý cách đặt vấn đề và nội quy box này :

 

(defun c:test(/ i adoc)(vl-load-com)(command "undo" "be")
(setq i -1 a (acet-geom-vertex-list (car (entsel "\nChon Pline :"))))
(mapcar '(lambda(x y)(or (eval x) (set x y))
(set x (cond ((getreal (strcat "\nNhap " (vl-princ-to-string x) ": <" (rtos (eval x) 2 2) ">")))
((eval x))
  )
))
'(1st inc h)'(1 1 1))
(mapcar
'(lambda(x)
 (vla-addtext
  (cond  (adoc)
((setq adoc (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))))
  )
  (rtos (+ 1st (* (setq i (1+ i)) inc)) 2 0)  
  (vlax-3d-point x)
  h
 )
)
(if (wcmatch (getstring "\nGiu nguyen chieu ? <y> ") ",")
 a
 (reverse a)
)
)(command "undo" "en")
)

Em cảm ơn Bác nhiều nhé, nhưng bác có thể sửa giúp em để cho khi mình chọn đường polyline ở đâu thì text hiện ra ở đó được không? và sửa lại sao cho lisp có thể đánh bắt đầu từ điểm mình pick.

Thanks!

<<

(defun c:rb(/ ST:Geom-Center ST:Ss->ListEnt)
(defun ST:Geom-Center (ent / p1 p2)
(vla-getboundingbox (vlax-ename->vla-object ent) 'p1...
>>

(defun c:rb(/ ST:Geom-Center ST:Ss->ListEnt)
(defun ST:Geom-Center (ent / p1 p2)
(vla-getboundingbox (vlax-ename->vla-object ent) 'p1 'p2)
(setq p1 (vlax-safearray->list p1)
p2 (vlax-safearray->list p2)
pt (mapcar '* (mapcar '+ p1 p2) '(0.5 0.5 0.5))
)
)
(defun ST:Ss->ListEnt (ss / n e l)
 (setq n (sslength ss))
 (while (setq e (ssname ss (setq n (1- n))))
(setq l (cons e l))
 )
)
(or ang (setq ang 180))
(setq ang (cond ((getreal (strcat "\nGoc quay < " (rtos ang 2 2) " >:")))(ang)))
(foreach e (ST:Ss->ListEnt (ssget))
(command ".rotate" e "" "_non" (ST:Geom-Center e) ang )
))

không hiểu sao em dùng cái này của bác ketxu text nó bị văng rất xa . phải dùng Ctrl + A mò lại mới thấy vị trí mới của nó .

bác ketxu co thể chỉnh lại hộ e tí dc ko .

<<

Hề hề hề.

Làm thử thế này có nhanh hơn không nhé:

;; free lisp from cadviet.com
;;; this lisp was...
>>

Hề hề hề.

Làm thử thế này có nhanh hơn không nhé:

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=13203&st=880
(defun c:mtl(/ doc Util MS c1 c2 kc2tl L1 oldos i j p dgiao pc2)
(vl-load-com)
(setq oldco (getvar "cecolor"))
(setq doc (vla-get-activeDocument (vlax-get-acad-object))
Util (vla-get-utility doc)
MS (vla-get-ModelSpace doc))
(vla-StartUndoMark doc)
(setq c1 (car(entsel "\n Chon duong bien thu nhat :")))
(setq c2 (car(entsel "\n Chon duong bien thu hai :")))
(if (not *kc2tl*) (setq *kc2tl* 2))
(setq kc2tl (getdist (strcat "\n Khoang cach giua taluy ngan va taluy dai < "
			(rtos *kc2tl* 2 2) " > : "
		     )
	   )
)
(if (not kc2tl) (setq kc2tl *kc2tl*) (setq *kc2tl* kc2tl))
(setq L1 (vlax-curve-getDistAtParam c1
		(setq pre (vlax-curve-getEndParam c1))
	)
)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setvar "cecolor" "8")
(setq i 0 j 0)
(Repeat (1+ (fix (/ L1 kc2tl)))
(setq p (vlax-curve-getPointAtDist c1 i))
(setq dgiao (vlax-curve-getClosestPointTo c2 p nil))
(if (= (rem j 2) 0)
(setq pc2 dgiao)
(setq pc2 (list (/ (+ (car p) (car dgiao)) 2) (/ (+ (cadr p) (cadr dgiao)) 2) 0))
)
(vla-addline MS (vlax-3d-point p)
	 (vlax-3d-point pc2)
)
(setq i (+ i kc2tl))
(setq j (1+ j))
;;;;;;;;;;(command ".change" "L" "" "p" "C" 8 "" ""); doi mau doi tuong
;(princ)
);repeat
(setvar "osmode" oldos)
(setvar "cecolor" oldco)
(vla-EndUndoMark doc)
(princ)
)

Chúc bạn vui.

Ok. Đã test thanh bạn nhiều :D.Nếu muốn tạo lớp mới: "ghi chu" cho đối tượng được tạo ra làm như nào nhỉ ?

<<

Thằng Mleader nó lại chẳng giống ai nhỉ ^^. bạn sửa lại như vầy (tách ra cho dễ)

(defun C:dc()
(vl-load-com)
(setq...
>>

Thằng Mleader nó lại chẳng giống ai nhỉ ^^. bạn sửa lại như vầy (tách ra cho dễ)

(defun C:dc()
(vl-load-com)
(setq txtcol 2 lcol 30) 
(setq colorObj (vla-getinterfaceobject (vlax-get-acad-object) "AutoCAD.AcCmColor.17"))   
(foreach ent (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X" '((0 . "DIMENSION,LEADER")))))))
(if (vlax-property-available-p ent 'TextColor)
(vla-put-Textcolor ent txtcol)
)
(if (vlax-property-available-p ent 'DimensionLinecolor)
(vla-put-DimensionLinecolor ent lcol)
)
(if (vlax-property-available-p ent 'ExtensionLinecolor)
(vla-put-ExtensionLinecolor ent lcol)
)

)
(foreach ent (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X" '((0 . "MULTILEADER")))))))    
   (vla-put-ColorIndex colorObj ldrcol) 
   (vla-put-LeaderLineColor ent colorObj)
    (vla-put-ColorIndex colorObj txtcol) 
   (vla-put-TrueColor ent colorObj)
)
)

hic ! Bác KETXU kiểm tra lại lisp xem nó chạy ok không và với đường Dim trong File em gửi thì lisp không thể đổi màu được. Bác chỉnh giúp em để nó đổi màu được mọi đường Dim với

File : http://www.cadviet.com/upfiles/3/doi_mau_dim.dwg

<<

Đây là lisp mình viết đang còn hạn chế về tính tự động(chỉ tính từng hạng mục một).Bây giờ muốn phát triển thêm...

>>

Đây là lisp mình viết đang còn hạn chế về tính tự động(chỉ tính từng hạng mục một).Bây giờ muốn phát triển thêm tính nhiều hạng mục

chỉ 1 lần chạy:

ý tưởng thì có nhưng viết lại không được mới khổ chứ:

1. Sẽ định nghĩa đối tượng tương ứng với hạng mục

Hạng mục 1

 1.1 chọn đối tượng

 1.2 chọn text hạng mục có sẳn (nếu ghi thì tôt hơn)

 1.3 chọn đơn vị m or m2

Hạng mục 2

 1.1 chọn đối tượng

 1.2 chọn text hạng mục có sẳn (nếu ghi thì tôt hơn)

 1.3 chọn đơn vị m or m2

..........

Sau khi định nghĩa xong các hạng mục Enter thì lisp điền diện tích luôn.

Và đây là lisp:

(defun c:DTTN (/ NDTS dem1 lstkm point kcach point1 pointtim diemtam xuongdong kt diemtren1)
(setvar "CMDECHO" 0)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (setq lop1 "entdauco")
  (prompt "\nChon Pline hoac Hatch mau tinh dien tich.")
  (setq fltr (ssx_fe))
  (prompt "\nChon Text ghi dien tich.")
  (setq DTS (car (entsel)))
  (setq DTS (entget DTS))
  (setq NDTS (cdr (assoc 1 DTS)))
  (command "-layer" "new" "Tinh dien tich TN" "color" "2" "Tinh dien tich TN" "")
  (command "-layer" "set" "Tinh dien tich TN" "")
(if (null cdtxt)
 (caidat)
)
 (setq th (getvar "textsize"))
 (setq dentay (- dentay (* 1.5 th)))
  ;(prompt "\nChon trac ngang.")
  (setq danhsachkm (acet-ss-to-list (ssget "X" (list (cons 8 lop1) (cons 1 "K*")))))
  (setq lstkm (mapcar '(lambda (e) (cons (cdr (assoc 11 (entget e))) (cdr (assoc 1 (entget e))))) danhsachkm))
  (setq lstkm (vl-sort lstkm '(lambda(x y / tmx tmy) (setq tmx (timlt x) tmy (timlt y))
                 (or (< (car tmx) (car tmy))
    (and (= (car tmx) (car tmy)) (< (last tmx) (last tmy)))))))
  (setq ss (acet-ss-to-list (ssget "X" '((0 . "LINE")(8 . "ENTTNTUNHIEN")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq dem1 1)
(setq sodt (length danhsachkm)
ta 
            (chr 8)
stxoa (strcat ta ta ta ta ta ta ta ta ta ta ta ta ta ta 
            ta ta ta ta ta ta)
stxuly "Xu ly duoc: "
ptcu nil
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (foreach ent lstkm
    (setq point (car ent))
    (setq kcach (distance point (cdr (assoc 11 (entget (nth 0 ss))))))
    (foreach enxt ss
      (setq point1 (cdr (assoc 11 (entget enxt))))
      (setq toay (cadr point1))
      (if (and (< (distance point1 point) kcach) (< toay (cadr point)) (equal (car point1) (car point) 1))
(progn
 (setq pointtim (cdr (assoc 11 (entget enxt))))
 (setq kcach (distance pointtim point))
)
      )
    )
    (setq diemtam (polar pointtim (/ pi 2) (/ kcach 2)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
    (vla-ZoomCenter (vlax-get-acad-object) (vlax-3D-point diemtam) (+ kcach 50))
    (setq dd (acet-ss-to-list (ssget "C" (polar pointtim 0 0.1 ) (polar pointtim 0 0.15 ) '((0 . "LINE")(8 . "ENTTNTUNHIEN")))))
    (setq diemdau (cdr (assoc 10 (entget (car dd)))))
    (setq diemcuoi (cdr (assoc 11 (entget (car dd)))))
    (setq diemtren (polar point (/ pi 2) 10))
	(setq diemtren1 (list (car diemcuoi) (cadr diemtren) 0))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq SSS (ssget "C" diemdau diemtren1 fltr)) 
(if (/= sss nil)
(progn
(setq i 0)
(setq s 0)
(setq N (sslength sss))
 (setq data (ssget "C" diemdau diemtren1 '((0 . "INSERT") (8 . "entdauco"))))
  (while (< i N)
  ;(luuos)
  (setvar "osmode" 0)
  (setq DT (ssname sss i))	
  (setq j 0)
  (setq ent1 (ssname data 0))
  (setq diemchuan (cdr (assoc 10 (entget ent1))))
  (Command "area" "o" DT)
  (if (= (getvar "area") 0)
  (progn
  (setq s (+ s (getvar "PERIMETER")))
  (setq i (1+ i))
  (setq donvi "m")
  )
  (progn
  (setq s (+ s (getvar "AREA")))
  (setq i (1+ i))
  (setq donvi "m2")
  )
  ))
  (setq diemghi (polar diemchuan 0 dentax))
  (setq diemghi (polar diemghi (/ pi 2) dentay))
  (setq txt NDTS)
  (command "TEXT" diemghi th 0 txt)
  (setq pointt11 (polar diemghi 0 cdtxt))
  (command "TEXT" pointt11 th 0 ":")
  (setq pointt1 (polar pointt11 0 cdsokl))
  (command "TEXT" "J" "R" pointt1 th 0 (rtos s 2 2))
  (setq point2 (polar pointt1 0 0.2))
  (command "TEXT" point2 th 0 donvi)
  ;(traos)
  )
  (progn
  (setq data (ssget "C" diemdau diemtren1 '((0 . "INSERT") (8 . "entdauco"))))
  (setq ent1 (ssname data 0))
  ;(luuos)
  (setvar "osmode" 0)
  (setq diemchuan (cdr (assoc 10 (entget ent1))))
  (setq diemghi (polar diemchuan 0 dentax))
  (setq diemghi (polar diemghi (/ pi 2) dentay))
  (setq txt NDTS)
  (command "TEXT" diemghi th 0 txt)
  (setq pointt11 (polar diemghi 0 cdtxt))
  (command "TEXT" pointt11 th 0 ":")
  (setq pointt1 (polar pointt11 0 cdsokl))
  (command "TEXT" "J" "R" pointt1 th 0 "0.00")
  (setq point2 (polar pointt1 0 0.2))
  (command "TEXT" point2 th 0 donvi)
  ;(traos)
  )
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; xu ly phan tram chay o duoi
(setq pt (* (/ (* dem1 1.0) sodt) 100.0)
dem1 (+ dem1 1)
)
(if (/= pt ptcu)
(progn
(princ (strcat stxoa stxuly (rtos pt 2 0) "%"))
(setq ptcu pt)
)
)
;(princ "\nDang xu ly")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setvar "MODEMACRO" "DANG CHUYEN DU LIEU CHO TRONG GIAY LAT")  
)
(setvar "CMDECHO" 1)
;(thoi)
)
(defun timlt (st / tm)
  (setq tm (vl-string->list (substr (strcase (cdr st)) (+ 3 (vl-string-search "KM" (strcase (cdr st)))))))
  (read (strcat "(" (vl-list->string (subst 32 43 (subst 32 58 tm))) ")"))
)
(defun ssx_fe (/ data fltr ent)
  (setq ent (car (entsel "\nSelect object <None>: ")))
  (if ent
    (progn
      (setq data (entget ent))
      (foreach x '(0 2 6 7 8 39 62 66 210) ; do not include 38
        (if (assoc x data)
          (setq fltr
            (cons (assoc x data) fltr)
          )
        )
      )
      (reverse fltr)
    )
  )
)
(defun Caidat (/ htxt httxt ltxt lsokl)
 (if (null dentax)
 (progn
 (setq dentax 10)
 (setq dentay 10)
 ))
 (setq x (getstring (strcat "\nKhoang cach dien phuong x <"(rtos dentax)"> :")))
 (setq y (getstring (strcat "\nKhoang cach dien phuong y <"(rtos dentay)"> :")))
 (if (/= x "") (setq dentax (atof x)))
 (if (/= y "") (setq dentay (atof y)))
(setq htxt 0.2)
(setq httxt (getstring (strcat "\nNhap chieu cao chu <"(rtos htxt)"> :")))
(if (/= httxt "") (setq htxt (atof httxt)))
(setvar "textsize" htxt)
(setq cdtxt 4.5)
(setq ltxt (getstring (strcat "\nNhap chieu dai chuoi <"(rtos cdtxt)"> :")))
(if (/= ltxt "") (setq cdtxt (atof ltxt)))
(setq cdsokl 0.75)
(setq lsokl (getstring (strcat "\nNhap chieu dai chu so khoi luong <"(rtos cdsokl)"> :")))
(if (/= lsokl "") (setq cdsokl (atof lsokl)))
)
(defun C:Caidatlai (/ htxt httxt ltxt lsokl)
(if (null dentax)
 (progn
 (setq dentax 10)
 (setq dentay 10)
 ))
 (setq x (getstring (strcat "\nKhoang cach dien phuong x <"(rtos dentax)"> :")))
 (setq y (getstring (strcat "\nKhoang cach dien phuong y <"(rtos dentay)"> :")))
 (if (/= x "") (setq dentax (atof x)))
 (if (/= y "") (setq dentay (atof y)))
(setq htxt 0.2)
(setq httxt (getstring (strcat "\nNhap chieu cao chu <"(rtos htxt)"> :")))
(if (/= httxt "") (setq htxt (atof httxt)))
(setvar "textsize" htxt)
(setq cdtxt 4.5)
(setq ltxt (getstring (strcat "\nNhap chieu dai chuoi <"(rtos cdtxt)"> :")))
(if (/= ltxt "") (setq cdtxt (atof ltxt)))
(setq cdsokl 0.75)
(setq lsokl (getstring (strcat "\nNhap chieu dai chu so khoi luong <"(rtos cdsokl)"> :")))
(if (/= lsokl "") (setq cdsokl (atof lsokl)))
) 

Đây là file test:

http://www.cadviet.com/upfiles/5/66960_vi_du.dwg

cho mình hỏi là mình dùng trên file của bạn thì ok nhưng ứng dụng vào bản vẽ của mình thì nó báo Layer "Tinh dien tich TN" already exists. là sao bạn nhỉ?

<<

Download lisp

Filename: 406447_dttn_caidatlai.lsp

26 phút trước, emhoccad đã nói:

Có duy nhất cái Block này viền...

>>

26 phút trước, emhoccad đã nói:

Có duy nhất cái Block này viền ngoài màu Green nó có layer "Outline" ko đổi sang được Layer màu trắng bác ah. 

 

Bác giúp e sửa lisp cứ màu xanh là chuyển hết sang layer "0" nhé

 

Block mau.dwg

Đổi về Layer 0 thì nó lại theo màu layer 4.

(defun c:test  (/ ss e blk doc)
  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (if
    (setq ss (ssget ":L" '((0 . "INSERT"))))
     (repeat (setq i (sslength ss))
       (setq e (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
       (setq blk (vla-item (vla-get-blocks doc) (vla-get-effectivename e)))
       (vlax-for x  blk
         (cond
           ((= (vlax-get x 'layer) "2")
            (vla-put-layer x "4")
            )
           ((= (vlax-get x 'layer) "3")
            (vla-put-layer x "7")
            )
           ((= (vlax-get x 'Color) 3)
            (vla-put-color x 256)
            (vla-put-layer x "0")
            )           
           )         
         )
       )
     )
  (vla-regen doc acallviewports)
  (princ)
  )

 

<<

1 giờ trước, tavantoan12 đã nói:

May quá bác bắt đầu hiểu ý...

>>

1 giờ trước, tavantoan12 đã nói:

May quá bác bắt đầu hiểu ý em rồi, cám ơn bác đã kiên nhẫn.

Với câu hỏi của bác thì: Do tính chất công việc em buộc phải làm tròn tọa độ ở wcs , làm tròn của em là từ số thứ 4 sau dấu phẩy sẽ đưa nó về 0 chính về thế mới có dòng (setq p1 (list (atof (rtos (car p) 2 3)) (atof (rtos (cadr p) 2 3)) 0)) này đó bác, không phải làm tròn kiểu luprec đâu ( cái này chỉ về mặt hiển thị thôi chứ bản chất nó không làm tròn)

Theo video của bác, nếu bác đưa về wcs , để luprec 7 thì tọa độ của bác sẽ không có dạng xx,xxx0000 (đây là điều em muốn)

Mình chỉnh 1 chút chủ thớt test nhé.

(defun c:dt  (/ p p1 center n clayer osmode)
  (setvar "cmdecho" 0)
  (setq clayer (getvar "clayer")
        osmode (getvar "osmode")
        )
  (setvar "ORTHOMODE" 1)
;;;  (command "ucs" "w")
  (command "clayer" "8 ???")
  (command "cmleaderstyle" "1")
  (prompt "\n Ch?n v? trí di?m T ")
  (setq n 0)
  (while
    (setq p (getpoint))
     (setq n (1+ n))
     (setq p1 (list (atof (rtos (car p) 2 3)) (atof (rtos (cadr p) 2 3)) 0))
     (setvar "osmode" 0)
     (command "circle" p1 0.05)
     (command "line" (polar p1 0 0.05) (polar p1 pi 0.05) "")
     (command "rotate" "l" "" p1 "c" 90 "")
 ;(command "ucs" "p")
     (command "mleader" "h" p1 pause 0 (strcat "T" (rtos n 2 0)))
     (setvar "osmode" osmode)
     )
;;;  (command "ucs" "p")
  (command "clayer" clayer)
  (princ)
  )

 

<<

Tue_NV đã chỉnh sửa tất cả lại

Bạn test thử nhé :

;; free lisp from cadviet.com

(defun c:ggoc(/ oldos curve cao ddau ddau1 pre i diem1 diem2 gocA gocB gocC 
do...
>>

Tue_NV đã chỉnh sửa tất cả lại

Bạn test thử nhé :

;; free lisp from cadviet.com

(defun c:ggoc(/ oldos curve cao ddau ddau1 pre i diem1 diem2 gocA gocB gocC 
do dotinh phut giay diemchen1 diemchen2 diemchen10 chuoido L)
(setvar "cmdecho" 0)
(command "undo" "be")
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq curve (car(entsel "\n Chon Polyline :")))
(setq cao (getvar "textsize"))
(setq ddau (vlax-curve-getStartPoint curve) i 1)
(setq ddau1 ddau)
(setq pre (vlax-curve-getEndParam curve))

(while (< i pre)

(setq diem1 (vlax-curve-getPointAtParam curve i))
(setq diem2 (vlax-curve-getPointAtParam curve (1+ i))) 
(setq gocA (/ (* (angle diem1 ddau) 180) pi))
(setq gocB (/ (* (angle diem1 diem2) 180) pi))
(if (< (abs(- gocA gocB)) 180) 
(setq gocC (abs(- gocA gocB)))
(setq gocC (- 360 (abs(- gocA gocB))))
)
(setq do (fix gocC))

(setq dotinh (* (- gocC do) 3600))
(setq phut (fix (/ dotinh 60)))
(setq giay (fix (rem dotinh 60)))

(if (> (cadr diem1) (cadr diem2))
(progn
(setq diemchen1 (list (car diem1) (+ (cadr diem1) (* 3.0 cao)) 0))
(setq diemchen2 (list (car diem1) (+ (cadr diem1) (* 1.5 cao)) 0)) 
)
(progn
(setq diemchen1 (list (car diem1) (- (cadr diem1) (* 1.5 cao)) 0))
(setq diemchen2 (list (car diem1) (- (cadr diem1) (* 3.0 cao)) 0))
)
)
(setq chuoido (strcat (rtos do 2 0) (chr 176) (rtos phut 2 0) "'" (rtos giay 2 0) "''"))
(setq L (vlax-curve-getDistAtPoint curve diem1))

(wtxt chuoido diemchen1)
(wtxt (strcat "L = " (rtos L 2 0)) diemchen2)

(setq i (1+ i))
(setq ddau diem1)
)
(setq diemchen10 (list (car ddau1) (- (cadr ddau1) (* 1.5 cao)) 0))
(wtxt (strcat "L = " (rtos (vlax-curve-getDistAtPoint curve ddau1) 2 0)) diemchen10)

(setvar "osmode" oldos)
(command "undo" "end")
(princ)
)
;
;

;
(defun wtxt (txt p / sty d h)
(setq
    sty (getvar "textstyle")
    d (tblsearch "style" sty)
    h (cdr (assoc 40 d))
)
(entmake (list (cons 0 "TEXT") (cons 7 sty) (cons 1 txt) (cons 10 p) (cons 11 p) (cons 72 1) (cons 73 2)
          (if (> h 0) (cons 40 h) (assoc 40 d)) (assoc 41 d))
)
)

:D

Rất tuyệt bác Tuệ à. chỉ còn một lỗi nhỏ là khi chiều cao text lớn thì hai dòng text gần trùng lên nhau. Nếu có thể bác khắc phục hiện tượng này luôn nhé. Cám ơn tất cả mọi người rất nhiều, có cái này mình giảm được ít nhất 30phút cho mỗi bản vẽ :lol2: :lol2:

<<

(defun C:CA (/ dt p1 p2 sl s2 i )
 (command "undo" "be")
 (setq osm (getvar "osmode"))
 (setq dt (ssget)
       p1 (getpoint "\nDiem goc: ")
       p2 (getpoint p1 "\nDiem den: ")
       sl (getint "\nSo lan: ")
       s2 (/ (distance p1 p2) sl)
       i 1)
 (setvar "osmode" 0)
 (repeat sl
  (command ".copy" dt "" p1 (polar p1 (angle p1 p2) (* i s2)))
  (setq i (1+ i)))
 (command "undo" "e")
 (setvar "osmode"...
>>

(defun C:CA (/ dt p1 p2 sl s2 i )
 (command "undo" "be")
 (setq osm (getvar "osmode"))
 (setq dt (ssget)
       p1 (getpoint "\nDiem goc: ")
       p2 (getpoint p1 "\nDiem den: ")
       sl (getint "\nSo lan: ")
       s2 (/ (distance p1 p2) sl)
       i 1)
 (setvar "osmode" 0)
 (repeat sl
  (command ".copy" dt "" p1 (polar p1 (angle p1 p2) (* i s2)))
  (setq i (1+ i)))
 (command "undo" "e")
 (setvar "osmode" 1023)
 (princ))

Rất cảm ơn Ketxu đã có 1 số góp ý để Lisp được hoàn thiện hơn.

Lệnh này Copy_Array các đối tượng, kể cả Text...

>>

Rất cảm ơn Ketxu đã có 1 số góp ý để Lisp được hoàn thiện hơn.

Lệnh này Copy_Array các đối tượng, kể cả Text (Mtext). Riêng Text chứa số thì có thể tăng/giảm theo gia số, nó chấp nhận cả số có tiền và/hoặc hậu tố.

Nếu có nhiều Text số được chọn thì chỉ 1 Text số chọn sau cùng được tăng/giảm. Số chữ số thập phân (nếu có) sẽ lấy theo Text chọn.

; Doan Van Ha CADViet.com
; Copy-Array cac doi tuong ke ca Text (Mtext), rieng Text co chua so thi tang giam theo gia so, chap nhan so co tien to va hau to.
; Neu co nhieu Text chua so duoc chon thi chi 1 Text chon sau cung duoc tang/giam. So chu so thap phan (neu co) lay theo Text chon.
(defun C:CA (/ dsdt dt dt1 dt2 p1 p2 sl x kwrd strt strp num sym ds daup giaso)
(vl-load-com)
(command "undo" "be")
(setq osm (getvar "osmode") cmd (getvar "cmdecho"))
(princ "\nChon cac doi tuong can Copy-Array...")
(setq dsdt (vl-remove-if 'listp (mapcar 'cadr (ssnamex (setq dt (ssget)))))
  		dt1 dt
  		p1 (getpoint "\nDiem goc: ")
  		p2 (getpoint p1 "\nDiem den: ")
  		sl (getint "\nSo lan: ")
  		x 1)
(setvar "osmode" 0) (setvar "cmdecho" 0)
(foreach n dsdt
 (if (or (= "TEXT" (cdr (assoc 0 (entget n)))) (= "MTEXT" (cdr (assoc 0 (entget n)))))
  (if (KT_NUM (cdr (assoc 1 (entget n))))
(setq dt2 n))))
(if dt2 (setq dt1 (ssdel dt2 dt)))
(if dt2
 (progn
  (initget "Y N")
  (setq kwrd (getkword "\nBan muon Text tang dan ?   ") giaso (getreal "\nGia so: "))
  (setq x 1)
  (repeat (1- sl)
(command ".copy" dt2 "" p1 (polar p1 (angle p1 p2) (* (distance p1 p2) x)))
(if (eq kwrd "Y")
(progn
 	(CHIA3 (cdr (assoc 1 (entget dt2))))
 	(setq daup (if (not (vl-string-search "." (cadr ds))) 0 (- (strlen (cadr ds)) (vl-string-search "." (cadr ds)) 1)))
 	(entmod (subst (cons 1 (strcat (car ds) (rtos (+ (atof (cadr ds)) (* x giaso)) 2 daup) (caddr ds)))  (assoc 1 (entget (entlast))) (entget (entlast))))
 	(entupd (entlast))))
(setq x (1+ x)))))
(if dt1
 (progn
  (setq x 1)
  (repeat (1- sl)
(command ".copy" dt1 "" p1 (polar p1 (angle p1 p2) (* (distance p1 p2) x)))
(setq x (1+ x)))))
(command "undo" "e")
(setvar "osmode" osm) (setvar "cmdecho" cmd)
(princ))
;----- Chia text ra tiento_num_hauto.
(defun CHIA3 (str / trai phai lstt lstn)
(setq lstt (vl-string->list str) lstn (reverse lstt))
(while lstt
 (cond ((or (< (car lstt) 48) (> (car lstt) 57)) (setq trai (cons (car lstt) trai) lstt (cdr lstt)))
		(T (setq lstt nil))))
(while lstn
 (cond ((or (< (car lstn) 48) (> (car lstn) 57)) (setq phai (cons (car lstn) phai) lstn (cdr lstn)))
		(T (setq lstn nil))))
(setq ds (list (vl-list->string (reverse trai))
                   	(if (= (strlen str) (strlen (vl-list->string (reverse trai)))) "" (vl-string-right-trim (vl-list->string phai) (vl-string-left-trim (vl-list->string trai) str)))
                   	(if (= (strlen str) (strlen (vl-list->string (reverse trai)))) "" (vl-list->string phai)))))
;----- Kiem tra 1 text co chua num hay khong?
(defun KT_NUM(str / ds kt)
(foreach n (vl-string->list str)
 (if (and (>= n 48) (<= n 57)) (setq kt T)))
kt)

P/S: sửa 07/02/2012 để không còn dùng các hàm Acet.

 

Mình thấy Lisp của bác rất hay, nhưng còn hạn chế ở một chỗ là khi coppy tăng dần text chẳng hạn như CN: 01, khi tăng dần lên 1 đơn vị thì các text sau chỉ còn là CN: 2 CN: 3..... thôi. Mong bác sửa lại sao cho các text sau coppy vẫn là CN: 02, CN: 03 ......

<<

Sửa lại đây:

(defun c:test  (/ Make-Line ang bv cdi hbv hcd len msp pd3 po1 po2 po3 po4 pt1 pt2 pt3 pt4 tlv p11 p33)
 (defun Make-Line  (p1 p2 lay)
  (entmakex (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2) (cons 8 lay))))
 (vl-load-com)
 (setq msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
       cdi (* (getvar "DIMTXT") (getvar "DIMSCALE")))
 (if (and (setq pt1 (getpoint "\nDiem p1:...
>>

Sửa lại đây:

(defun c:test  (/ Make-Line ang bv cdi hbv hcd len msp pd3 po1 po2 po3 po4 pt1 pt2 pt3 pt4 tlv p11 p33)
 (defun Make-Line  (p1 p2 lay)
  (entmakex (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2) (cons 8 lay))))
 (vl-load-com)
 (setq msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
       cdi (* (getvar "DIMTXT") (getvar "DIMSCALE")))
 (if (and (setq pt1 (getpoint "\nDiem p1: "))
          (setq pt2 (getpoint "\nDiem p2: "))
          (setq pt3 (getpoint "\nDiem p3: "))
          (setq pt4 (getpoint "\nDiem p4: "))
          (setq hcd (getdist "\nChieu cao dam: "))
          (setq hbv (getdist "\nChieu day bt bao ve: "))
          (setq tlv (getreal "\nTi le ve <Nhap 20 de co ty le 1/20>:")))
  (progn (setq po1 (polar pt3 (* pi 1.0) hcd)
               po2 (polar po1 (* pi (/ 30 180.0)) (* 70 (/ 100 tlv)))
               po3 (polar pt4 (* pi 0.0) hcd)
               po4 (polar po3 (* pi (/ 150 180.0)) (* 70 (/ 100 tlv)))
               ang (angle pt1 pt2)
               pd3 (polar pt1 (+ ang (* pi 1.5)) (* cdi 4)))
         (Make-Line po1 po2 "CAT-THEP")
         (Make-Line po3 po4 "CAT-THEP")
         (setq p11 (inters pt1 pt2 po1 (polar po1 (* pi 1.5) hcd))
               p33 (inters pt1 pt2 po3 (polar po3 (* pi 1.5) hcd)))
         (mapcar (function (lambda (x y z) (vla-adddimaligned msp x y z)))
                 (mapcar 'vlax-3d-point (list pt1 pt2 p11))
                 (mapcar 'vlax-3d-point (list p11 p33 p33))
                 (mapcar 'vlax-3d-point (list pd3 pd3 pd3)))))
 (princ))

P/s: Làm kiểu này thì khai báo chiều dày bt bảo vệ không quan trọng, bạn có thể xóa dòng đó đi.