Jump to content
InfoFile
Tác giả: tientracdia
Bài viết gốc: 311254
Tên lệnh: fn maublk camcoc
Lisp chèn block theo khoảng cách và xuất kết quả

 

Bạn thử cái này, lưu định dạng .CVS

Lệnh là "camcoc"

Điểm chèn block đặt ở tâm...

>>

 

Bạn thử cái này, lưu định dạng .CVS

Lệnh là "camcoc"

Điểm chèn block đặt ở tâm nhé.

Muốn chọn lại chỗ lưu file csv  dùng lệnh "fn"

Muốn chọn lại block mẫu dùng lệnh "maublk"

(vl-load-com)
(defun c:fn ( / )
            (setq fn_camcoc (getfiled "Create Output File" "" "csv" 1))
);;; end defun fi
(defun c:maublk ( / camcoc_ten_blk1)
      (setq  camcoc_ten_blk1 (car (entsel "\nChon block ki hieu chen:")))
      (if (= (cdr (assoc 0 (entget camcoc_ten_blk1))) "INSERT")
        (progn
        (setq camcoc_ten_blk (cdr (assoc 2 (entget camcoc_ten_blk1))))
        (setq XscFactor (vlax-get-property (vlax-ename->vla-object camcoc_ten_blk1) 'XEFFECTIVESCALEFACTOR))
        (setq YscFactor (vlax-get-property (vlax-ename->vla-object camcoc_ten_blk1) 'YEFFECTIVESCALEFACTOR))
        )
        (alert "\nChua chon duoc block mau!")
      );;;end IF
);;; end defun fi

(defun c:camcoc ( / camcoc_gocquay COC EL1 GOC LIST_DON LIST_TONG OSMLAST PHIA_CAM PT10 PT11 PT_CHO_CAM_COC PT_MID TOA_DO_X TOA_DO_Y)
      (setq    OSMLAST    (getvar "osmode"))
      (setq list_tong (list)
      )
(if (null camcoc_khoang_cach)      
    (setq camcoc_khoang_cach 5)
)      
(if (null camcoc_ten_blk)      
      (c:maublk)
)
      ;(setq list_don (list))
(if
      (setq  coc (car (entsel "\nChon coc:")))
      (progn
      (if (= (cdr (assoc 0 (entget coc))) "LINE")
          (progn
              (setq pt_mid  ( mid (setq pt10 (cdr (assoc 10 (entget coc)))) (setq pt11(cdr (assoc 11 (entget coc))))));;;setq
          );;;progn
      );;;end IF
      ;(setq camcoc_khoang_cach (getreal "\nNhap khoang cach: "));;;setq
      ;(setq camcoc_khoang_cach (duy:xd_gts camcoc_khoang_cach camcoc_khoang_cach "\nNhap khoang cach: "))
      (setq camcoc_khoang_cach (duy:xd_gts gtn camcoc_khoang_cach "Nhap khoang cach:"))
      (setq phia_cam (getpoint pt_mid "\nChon phia cam: ") );;;setq
      (setvar "osmode" 0)
      (setq goc (angle pt_mid phia_cam))
      (setq pt_cho_cam_coc (polar pt_mid goc camcoc_khoang_cach));;;setq
      (setq camcoc_gocquay (RTD (- goc (/ pi 2))))
      (command "_.insert" camcoc_ten_blk pt_cho_cam_coc XscFactor YscFactor camcoc_gocquay)
      (setq el1 (entlast))
      ;(vlax-put-property (vlax-ename->vla-object el1) 'XEFFECTIVESCALEFACTOR XscFactor)
      ;(vlax-put-property (vlax-ename->vla-object el1) 'YEFFECTIVESCALEFACTOR YscFactor)
      (command "_.dimaligned" pt_mid (cdr (assoc 10 (entget el1))) (polar pt_mid (+ goc (/ pi 2)) 8))
      (setq toa_do_x  (rtos (cadr (assoc 10 (entget el1))) 2 3));;;setq
      (setq toa_do_y  (rtos (caddr (assoc 10 (entget el1))) 2 3));;;setq
      (setq list_don (list (rtos camcoc_khoang_cach 2 10) toa_do_y toa_do_x));;;setq
      (setq list_tong (append  list_tong (list list_don)));;;setq
      ;(princ list_tong);;;princ
(while (null fn_camcoc)
            (c:fn)
);;; end If
      (LM:WriteCSV list_tong fn_camcoc);      
      ;(startapp "explorer" fn)
      (setvar "osmode" OSMLAST)
        (princ)
      )    
(progn
      (princ "\nChon chua dung");;;princ
(princ)      
)
)
);;; end defun c:camcoc
(defun RTD (x) (/ (* x 180) pi) )
(defun mid ( a b )
    (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) a b)
)
(defun LM:writecsv ( lst csv / des sep )
    (if (setq des (open csv "a"))
        (progn
            (setq sep (cond ((vl-registry-read "HKEY_CURRENT_USER\\Control Panel\\International" "sList")) (",")))
            (foreach row lst (write-line (LM:lst->csv row sep) des))
            (close des)
            t
        )
    )
)

;; List -> CSV  -  Lee Mac
;; Concatenates a row of cell values to be written to a CSV file.
;; lst -  list containing row of CSV cell values
;; sep -  CSV separator token

(defun LM:lst->csv ( lst sep )
    (if (cdr lst)
        (strcat (LM:csv-addquotes (car lst) sep) sep (LM:lst->csv (cdr lst) sep))
        (LM:csv-addquotes (car lst) sep)
    )
)

(defun LM:csv-addquotes ( str sep / pos )
    (cond
        (   (wcmatch str (strcat "**"))
            (setq pos 0)    
            (while (setq pos (vl-string-position 34 str pos))
                (setq str (vl-string-subst "\"\"" "\"" str pos)
                      pos (+ pos 2)
                )
            )
            (strcat "\"" str "\"")
        )
        (   str   )
    )
)
(defun duy:xd_gts (gtn gtmd mdich / gtn gtmd mdich)
(or gtn (setq gtn gtmd))
(setq gtn (cond ((getreal (strcat "\n" mdich " < " (rtos gtn 2 2) " >:")))(gtn)))
gtn)

Lisp giải quyết được khoảng cách , tọa độ và xuất ra excel vị trí cọc GPMB, rất hay.

xin nhờ Bạn giúp thêm cho việc chọn hướng gốc của tuyến ( để phân biện bên trái và phải tuyến ), chọn tên cọc ví dụ như H3,..nhập chiều rộng giải tỏa,  chọn hướng cấm cọc trái hay phải  thì xuất cọc theo hướng vuông góc và xuất ra bảng trên cad  và exxcel luôn, theo file minh họa sau

cám ơn

http://www.cadviet.com/upfiles/3/114381_coc_gpmb.dwg


<<

Filename: 311254_fn_maublk_camcoc.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 436729
Tên lệnh: chia
Nhờ sừa lisp. chia nhỏ pline

Không biết lệnh JOIN của cad xuất hiện từ phiên bản nào???

(defun c:chia  (/ c_chia_PL ent kc ss)
  (defun c_chia_PL  (ent kc / p oldos oldp findp ss)
    (defun findp (ent) (vlax-curve-getPointAtDist ent kc))
    (setq oldos (getvar "osmode"))
    (setvar "osmode" 0)
    (setq ss (ssadd)
          ss (ssadd ent ss))
    (while (and (setq p (findp ent)) (not (equal p oldp 0.01)))
     ...
>>

Không biết lệnh JOIN của cad xuất hiện từ phiên bản nào???

(defun c:chia  (/ c_chia_PL ent kc ss)
  (defun c_chia_PL  (ent kc / p oldos oldp findp ss)
    (defun findp (ent) (vlax-curve-getPointAtDist ent kc))
    (setq oldos (getvar "osmode"))
    (setvar "osmode" 0)
    (setq ss (ssadd)
          ss (ssadd ent ss))
    (while (and (setq p (findp ent)) (not (equal p oldp 0.01)))
      (command ".break" ent p p)
      (setq ent  (entlast)
            ss   (ssadd ent ss)
            oldp p))
    (command ".join" ent ss "")
    (setvar "osmode" oldos))
  (if (and (setq ss (ssget '((0 . "LWPOLYLINE"))))
           (setq kc (getdist "\nVAo khoang cach: ")))
    (while (and (setq ent (ssname ss 0)) (ssdel ent ss)) (c_chia_PL ent kc)))
  (princ))

 


<<

Filename: 436729_chia.lsp
Tác giả: conghoan1003
Bài viết gốc: 71239
Tên lệnh: vbu khd
Viết Lisp theo yêu cầu
Gửi Hoan, bây giờ thì Ý tưởng của Hoan đã được hoàn thiện bằng lisp sau đây. Khi chọn đối tượng, Hoan phải chọn cả đường địa hình tự nhiên và cả đường giới...
>>
Gửi Hoan, bây giờ thì Ý tưởng của Hoan đã được hoàn thiện bằng lisp sau đây. Khi chọn đối tượng, Hoan phải chọn cả đường địa hình tự nhiên và cả đường giới hạn cùng 1 lúc, cứ tiếp tục cho đến hết mặt cắt, enter kết thúc. :bigsmile:

;;;---------------------------------
;;; LISP vet bun, COPYRIGHT BY THIEP 0918841230
;;; FREE FROM CADVIET.COM-----------
(defun GiaoDT (e1 e2 / ob1 ob2 g L n kq)
 (setq	ob1 (vlax-ename->vla-object e1)
ob2 (vlax-ename->vla-object e2)
g   (vlax-variant-value
      (vla-IntersectWith ob1 ob2 acExtendnone)
    )
 )
 (if (/= (vlax-safearray-get-u-bound g 1) -1)
   (setq L (vlax-safearray->list g))
 )
 (setq n 0)
 (repeat (/ (length L) 3)
   (setq kq
   (append (list (list (nth n L) (nth (+ n 1) L) (nth (+ n 2) L)))
	   kq
   )
   )
   (setq n (+ n 3))
 )
 kq
)
(defun LWP (Lpoint *Model* / PntArr)
 (setq	PntArr (vlax-make-safearray
	 vlax-vbDouble
	 (cons 0 (1- (length Lpoint)))
       )
 )
 (vlax-safearray-fill PntArr Lpoint)
 (vla-AddLightWeightPolyline *Model* PntArr)
)
;;;-----------------------
(defun SS-enlst (ss / c L)
 (setq c -1)
 (repeat (sslength ss)
   (setq L (cons (ssname ss (setq c (1+ c))) L))
 )
 (reverse L)
)
;;;----------------------
(defun taoRay (ModelS poR1 poR2)
 (vla-Addray
   ModelS
   (vlax-3d-point poR1)
   (vlax-3d-point poR2)
 )
)

;-----------------------
(defun TextTaluy (model k po h ang / obj)
 (setq	obj (vla-AddText
      *Model*
      (strcat "1:" (rtos k 2 1))
      (vlax-3d-point po)
      h
    )
 )
 (vla-put-Alignment obj acAlignmentTopCenter)
 (vla-put-TextAlignmentPoint obj (vlax-3d-point po))
 (vla-put-Rotation obj ang)
 (vla-put-layer obj "vetbun")
)
;;;---------------------
(defun SAVE_MODE ()

 (command "Undo" "begin")
 (command "UCS" "W" "")
 (setq	OLD_OSMODE    (getvar "OSMODE")
OLD_CECOLOR   (getvar "CECOLOR")
OLD_AUTOSNAP  (getvar "AUTOSNAP")
OLD_ORTHOMODE (getvar "ORTHOMODE")
 )
 (setvar "cmdecho" 0)
 (setvar "plinegen" 1)

)
(defun RESTORE ()
 (command "Undo" "end")
 (setvar "osmode" OLD_OSMODE)
 (setvar "AUTOSNAP" OLD_AUTOSNAP)
 (setvar "ORTHOMODE" OLD_ORTHOMODE)
 (setvar "CECOLOR" OLD_CECOLOR)
 (setvar "cmdecho" 1)
)
;;;--------------------------
(defun DXF (code en) (cdr (assoc code (entget en))))
;;; -------------------------------
(defun existLinetype (doc LineTypeName / item loaded)
 (vlax-for item (vla-get-linetypes doc)
   (if (= (strcase (vla-get-name item)) (strcase LineTypeName))
     (setq loaded T)
   )
 )
)
;;;------loadLinetype
(defun loadLinetype (doc LineTypeName FileName)
 (if (and
       (not (existLinetype doc LineTypeName))
       (vl-catch-all-error-p
         (vl-catch-all-apply
           'vla-load
           (list
             (vla-get-Linetypes doc)
             LineTypeName
             FileName
           )
         )
       )
     )
   nil
   T
 )
)
;;;--------------------------
(vl-load-com)

;;;================================MAIN=============================
(DEFUN c:vbu (/	ActDoc *Model*	     *layer*	   en	  ss	 p1
	Pa     Pb     p1     p11    p2	   p21	  p3	 p4
	objD   enD    objR1  objR2  enR1   enR2	  pin1	 pin2
	pe1    pe2    objL2  objL1  enL1   enL2	  lay	 an1
	an2    pTex1  pTex2  i	    ss	   Len	  lop	 upp
	Lint   intP   enLWP
       )
 (setq	ActDoc	(vla-get-ActiveDocument (vlax-get-acad-object))
*Model*	(vla-get-ModelSpace ActDoc)
*layer*	(vla-get-Layers ActDoc)
 )
 (vla-StartUndoMark ActDoc)
 (SAVE_MODE)
 (loadLinetype ActDoc "HIDDEN" "acad.lin")
 (if (not (tblsearch "layer" "vetbun"))
   (progn
     (setq lay (vla-add *layer* "vetbun"))
     (vla-put-color lay acMagenta)
     (vla-put-Linetype lay "HIDDEN")
   )
 )
 (princ "Chon cac curve be mat nao vet: ")
 (While
   (setq SS (ssget '((0 . "LWPOLYLINE,LINE"))))
    (if (null k_Thiep1) (setq k_Thiep1 (getreal  "\nChon goc doc nao vet ben PHAI (mau so): ")))
    (if (null k_Thiep2) (setq k_Thiep2 (getreal  "\nChon goc doc nao vet ben TRAI (mau so): ")))
    (if (null d_Thiep) (setq d_Thiep (getreal  "\nChieu sau nao vet: ")))
    (if (null hei_Thiep) (setq hei_Thiep (getreal  "\nChon chieu cao chu: ")))
    (setq Len (SS-enlst ss)
   i   0
    )
    (foreach en Len
      (if (eq (dxf 0 en) "LWPOLYLINE")
 (progn
   (redraw en 3)
   (setq enLWP en
	 OBcur (vlax-ename->vla-object enLWP)
   )
   (vla-getboundingbox OBcur 'minpoint 'maxpoint)
   (setq lop (vlax-safearray->list minpoint)
	 upp (vlax-safearray->list maxpoint)
	 un  (getvar "viewsize")
	 ofp (list (/ (+ (car upp) (car lop)) 2)
		   (- (cadr lop) un)
		   0.0
	     )
   )
 )
      )				;end if
    )
    (foreach en Len
      (if (not (eq (dxf 0 en) "LWPOLYLINE"))
 (progn
   (setq intP (car (GiaoDT en enLWP)))
   (if intP
     (setq Lint (cons intP Lint))
   )
 )
      )
    )
    (setq Lint
    (vl-sort
      Lint
      '(lambda (e1 e2) (< (car e1) (car e2)))
    )
    )
    (setvar "osmode" 32)
    (setq p1  (car Lint)
   p2  (cadr Lint)
   p11 (list (+ (car p1) k_Thiep1) (- (cadr p1) 1) 0.0)
   p21 (list (- (car p2) k_Thiep2) (- (cadr p2) 1) 0.0)
   an1 (angle p1 p11)
   an2 (angle p2 p21)
    )
;;;================
    (vl-cmdf ".offset" d_Thiep enLWP ofp "")
    (setq enD (entlast))
    (setq objR1 (taoRay *Model* p1 p11)
   objR2 (taoRay *Model* p2 p21)
    )
    (setq enR1	(vlax-vla-object->ename objR1)
   enR2	(vlax-vla-object->ename objR2)
    )
    (setq PA (vlax-curve-getStartPoint enD)
   PB (vlax-curve-getEndPoint enD)
    )
    (setq pin1	(car (giaoDT enR1 enD))
   p11	(car (giaoDT enR1 enLWP))
   pin2	(car (giaoDT enR2 enD))
   p22	(car (giaoDT enR2 enLWP))
   pinR	(car (giaoDT enR1 enR2))
    )
    (cond ((/= p1 p11)
    (setq p1 p11)
   )
   ((/= p2 p22)
    (setq p2 p22)
   )
    )
    (setvar "osmode" 0)
    (if (< (car pin1) (car pin2))
      (Progn
 (vla-delete objR1)
 (vla-delete objR2)
 (if (< (car PA) (car PB))
   (progn
     (VL-CMDF "_.break" enD pin2 pin2)
     (setq ss (ssname (ssget pin2) 0))
     (entdel ss)
     (setq pe1 (list (+ (car pin1) 0.1) (+ (cadr pin1) 0.1) 0.0)
	   pe2 (list (+ (car pin1) 0.1) (- (cadr pin1) 0.1) 0.0)
	   pe3 (list (- (car pin1) 0.1) (+ (cadr pin1) 0.1) 0.0)
	   pe4 (list (- (car pin1) 0.1) (- (cadr pin1) 0.1) 0.0)
     )
     (setq enD (ssname (ssget pin1) 0))
     (VL-CMDF "_.break" enD pin1 pin1)
     (entdel (ssname (ssget "F" (list pe3 pe4)) 0))
     (setq enD (ssname (ssget "F" (list pe1 pe2)) 0))
   )
   (progn
     (VL-CMDF "_.break" enD pin1 pin1)
     (setq ss (ssname (ssget pin1) 0))
     (entdel ss)
     (setq pe1 (list (+ (car pin2) 0.1) (+ (cadr pin2) 0.1) 0.0)
	   pe2 (list (+ (car pin2) 0.1) (- (cadr pin2) 0.1) 0.0)
	   pe3 (list (- (car pin2) 0.1) (+ (cadr pin2) 0.1) 0.0)
	   pe4 (list (- (car pin2) 0.1) (- (cadr pin2) 0.1) 0.0)
     )
     (setq enD (ssname (ssget pin2) 0))
     (VL-CMDF "_.break" enD pin2 pin2)
     (entdel (ssname (ssget "F" (list pe1 pe2)) 0))
     (setq enD (ssname (ssget "F" (list pe3 pe4)) 0))
   )
 )
;;;end if trong
 (setq Lp    (list (car p1)
		   (cadr p1)
		   (car pin1)
		   (cadr pin1)
	     )
       objL1 (LWP Lp *Model*)
       enL1  (vlax-vla-object->ename objL1)
 )
 (setq Lp    (list (car p2)
		   (cadr p2)
		   (car pin2)
		   (cadr pin2)
	     )
       objL2 (LWP Lp *Model*)
       enL2  (vlax-vla-object->ename objL2)
 )
 (vl-cmdf ".pedit" "m" enL1 end enL2 "" "j" "" "")
 (setq lineNV (vlax-ename->vla-object (entlast)))
      )
;;;end progn 1
      (Progn
 (vla-delete objR1)
 (vla-delete objR2)
 (entdel enD)
 (setq Lp (list	(car p1)
		(cadr p1)
		(car pinR)
		(cadr pinR)
		(car p2)
		(cadr p2)
	  )
 )
 (setq lineNV (LWP Lp *Model*))
 (setq pin1 pinR
       pin2 pinR
 )
      )
;;;end progn 2
    )
;;;end if ngoai
    (vla-put-layer lineNV "vetbun")
    (vla-put-color lineNV acbylayer)
    (vla-put-LinetypeScale lineNV 2)
    (vla-put-LinetypeGeneration lineNV T)
;;;---tao text----
    (setq pTex1 (polar	(acet-geom-midpoint p1 pin1)
		(- an1 (/ pi 2))
		(/ hei_Thiep 2)
	 )
    )
    (TextTaluy *Model* k_Thiep1 pTex1 hei_Thiep an1)
    (setq pTex2 (polar	(acet-geom-midpoint p2 pin2)
		(+ an2 (/ pi 2))
		(/ hei_Thiep 2)
	 )
    )
    (TextTaluy *Model* k_Thiep2 pTex2 hei_Thiep (+ an2 pi))
    (setq Lint nil
   Len nil)

;(redraw en 4)
 )
;;;end while
 (vla-ZoomExtents (vlax-get-acad-object))
 (RESTORE)
 (vla-EndUndoMark ActDoc)
 (princ "\nChuc cac ban thanh cong. Thiep")
 (princ)
)
;;;-----------------ham dinh thong so k_Thiep, d_Thiep, hei_Thiep
(defun c:khd ()
 (setq	k_Thiep1	(cond (k_Thiep1)
	      (5)
	)
 )
 (setq oldk_Thiep1 k_Thiep1)
 (setq	k_Thiep1	(getreal (strcat "\nChon goc doc nao vet ben PHAI (mau so) <"
			 (rtos oldk_Thiep1 2 1)
			 "> : "

		 )
	)
 )
 (if (null k_Thiep1)
   (setq k_Thiep1 oldk_Thiep1)
 )
(setq	k_Thiep2	(cond (k_Thiep2)
	      (5)
	)
 )
 (setq oldk_Thiep2 k_Thiep2)
 (setq	k_Thiep2	(getreal (strcat "\nChon goc doc nao vet ben TRAI (mau so) <"
			 (rtos oldk_Thiep2 2 1)
			 "> : "

		 )
	)
 )
 (if (null k_Thiep2)
   (setq k_Thiep2 oldk_Thiep2)
 )

 (setq	d_Thiep	(cond (d_Thiep)
	      (5)
	)
 )
 (setq oldd_Thiep d_Thiep)
 (setq	d_Thiep	(getreal (strcat "\nChieu sau nao vet <"
			 (rtos oldd_Thiep 2 1)
			 "> : "

		 )
	)
 )
 (if (null d_Thiep)
   (setq d_Thiep oldd_Thiep)
 )
 (setq	hei_Thiep (cond	(hei_Thiep)
		(5)
	  )
 )
 (setq oldhei_Thiep hei_Thiep)
 (setq	hei_Thiep (getreal (strcat "\nChon chieu cao chu <"
			   (rtos oldhei_Thiep 2 1)
			   "> : "

		   )
	  )
 )
 (if (null hei_Thiep)
   (setq hei_Thiep oldhei_Thiep)
 )
 (prinC "\nBay gio ban co the su dung lisp vbu.lsp")
 (princ)
 (c:vbu)
)

Cảm ơn Thiêp nhiều, cái này dùng được 90% rồi.

Khi dùng mình vấn đề như thế này: Đường giới hạn vét có thêm một đoạn không cắt đường polyline (thực ra nó là đường trồng cỏ) cho nên khi quét, nếu quét luôn nó thì lisp sẽ không hiều. Còn nếu mình pick từng đường một thì lisp chạy được nhưng cũng có một số mặt cắt bị lỗi nhưng làm thế này thì nó sẽ lâu hơn là mỗi mặt cắt mình quét luôn 1lần. Nếu thiêp sữa được để quét một lần càng tốt không thì mình sẽ pick từng đường một cũng được

Còn ý tưởng của mình là thay vì mình quét từng mặt cắt mình sẽ quét tấc cả các mặt cắt luôn không biết như thế có khó qúa không? Nếu không thể quét tấc cả thì mình quét từng mặt cắt như thế cũng nhanh lằm rồi. Chúc sức khỏe! file test: http://www.cadviet.com/upfiles/2/tnct_3.dwg


<<

Filename: 71239_vbu_khd.lsp
Tác giả: tientracdia
Bài viết gốc: 226145
Tên lệnh: mtl
Lisp tạo viewport từ khung chọn bên model.

Nhoc xí xọn tiếp sức trong lúc bạn KangKung đi vắng vậy, bảo đảm tải về chạy ok, bạn thích đặt tên layout là gì cũng đc...

>>

Nhoc xí xọn tiếp sức trong lúc bạn KangKung đi vắng vậy, bảo đảm tải về chạy ok, bạn thích đặt tên layout là gì cũng đc ^^

;========LISP TAO VIEWPORT TREN LAYOUT BANG CACH CHON O MODEL========
;===============REV3=====================
(defun C:mtl()
 (command "UNDO" "BE")
 (setvar "OSMODE" 0)
 (setq taphop(ssget))
 (if (= Tyle nil)
(setq Tyle1 1)
(setq Tyle1 Tyle))
 (setq Tyle (getreal (strcat "\n Ty le: <" (rtos Tyle1 2 0) "> ")))
 (if (= Tyle nil)
(setq Tyle Tyle1))
 (setq soluong (sslength taphop))
 (setq index 0)
 (setq i 0)
 (setq ten (getstring "\n Nhap ten layout:"))
 (command "layout" "N" ten)
 (command "LAYOUT" "S" ten)
 (command "ERASE" "ALL" "")
 (command "MODEL")
 (setq X 0)
 (command "ZOOM" "E")
 (while (< index soluong)
(setq i(1+ i))
(setq khung(ssname taphop index))
(setq lst(acet-geom-vertex-list khung))
(command "COPYCLIP" khung "")
(command "LAYOUT" "S" ten)
(command "PASTECLIP" (list X 0))
(command "SCALE" (entlast) "" (list X 0) (/ 1 tyle))
(command "MVIEW" "O" (entlast))
(command "MSPACE")
(command "ZOOM" (nth 0 lst) (nth 2 lst))
(command "PSPACE")
(setq X(+ X 50 (/ (abs(- (car (nth 2 lst)) (car (nth 0 lst)))) tyle)))
(command "ZOOM" "W" (list 0 0) (list (+ X 100) 0))
(setq index (+ index 1))
)
 (command "MODEL")
 (command "UNDO" "END")
 (setvar "OSMODE" 15359)
 (princ)
 )

Cám ơn Bạn, Bài viết rất hay.

NHờ Bạn giúp cho khi khung nhìn không nằm ngang, khi ta chọn thì xuất qua Layout và xoay khung nhìn đó nằm lại ngang có được không bạn ?


<<

Filename: 226145_mtl.lsp
Tác giả: thong_kt
Bài viết gốc: 63058
Tên lệnh: scn
Cách scale nhiều đối tượng một lúc?
Cái này scale theo ý của bạn nè :

(defun c:scn()

(setq hcnc (entget(car(entsel "\n Chon hinh chu nhat chuan :"))))
(setq a (cdr(nth 14 hcnc)))
(setq b (cdr(nth 18 hcnc)))
(setq...
>>
Cái này scale theo ý của bạn nè :

(defun c:scn()

(setq hcnc (entget(car(entsel "\n Chon hinh chu nhat chuan :"))))
(setq a (cdr(nth 14 hcnc)))
(setq b (cdr(nth 18 hcnc)))
(setq m (getpoint "\n Chon diem tam scale tren hinh chu nhat chuan :"))
(setq TL (/ (distance m a) (distance m b)))

(prompt "\n Moi ban chon cac hinh chu nhat :")
(setq ssg (ssget '((0 . "LWPOLYLINE"))) n (sslength ssg) i 0)

(while (< i n)
(setq sn (ssname ssg i))
(setq ent (entget sn))
(setq c (cdr(nth 14 ent)))
(setq d (cdr(nth 18 ent)))
(setq md (/ (distance c d) (+ 1 TL)))
(setq mp (list (- (car d) md) (cadr d) 0))

(command "scale" sn "" mp tl)
(setq i (1+ i))

)
(princ)
)

Lai làm phiền bạn. Lisp sau mình đã dùng đuợc còn lisp này minh không sử dụng được . sao vậu nhỉ bạn. khi chương trình báo chọn các hình chữ nhật khác. Chọn xong thấy nó hết lệnh luôn.


<<

Filename: 63058_scn.lsp
Tác giả: cangua172
Bài viết gốc: 228019
Tên lệnh: xktl
Lisp xoá khung tên bên layout!

 

Hề hề hề,

Thử dùng cái ni xem sao nhé.

Tại sao bạn không làm khung ten thành một block chứa thuộc tính cho...

>>

 

Hề hề hề,

Thử dùng cái ni xem sao nhé.

Tại sao bạn không làm khung ten thành một block chứa thuộc tính cho tiện sử dụng mà lại làm khung tên rời rạc như vậy. 

Cái lisp này chỉ xóa được các khung tên có cùng kích thước và vị trí như bản vẽ bạn đã post, nếu sử dụng khung tên khác thì việc xóa sẽ không đảm bảo sạch đâu nhé, thậm chí nó có thể xóa cả những thứ bạn không muốn xóa đó.

 (defun c:xktl ( / llst ss)(setq cmdold (getvar "cmdecho"))(setvar "cmdecho" 0)(setq llst (layoutlist))(command "undo" "be")(foreach la llst     (command ".layout" "s" la "")     (setq ss (ssget "w" (list 19 25 0) (list 410 3 0) ))     (command "erase" ss ""))(command "model")(command "undo" "e")(setvar "cmdecho" cmdold)(princ))
Nếu có gì chưa ưng ý thì cứ mạnh dạn mà tố nghen.

Trước hết, em cảm ơn Anh Bình đã giúp đỡ em.... nhưng em chạy Lisp thì có một số Layout không xoá hết (nó chỉ xoá một phần của khung tên thôi).   Anh xem lại giúp em! Đoạn code  "  (setq ss (ssget "w" (list 19 25 0) (list 410 3 0) ))" có cách nào linh động hơn không? pick điểm để lấy giá trị đầu vào chẳng hạng (em không rành về Lisp lắm), để Lisp linh động hơn trong các bảng vẽ khác cần xoá nhưng toạ độ của các Layout nằm ở một vị trí khác. smile.png


<<

Filename: 228019_xktl.lsp
Tác giả: tdvn
Bài viết gốc: 55146
Tên lệnh: doimaudt
Viết Lisp theo yêu cầu
Chào các bác!

Em ðang cần Lisp có khả nãng nhý sau:

1_Chọn "n" ðối týợng trên bản vẽ.

2_Ðổi màu "n" ðối týờng này (mỗi ðối týợng có một...

>>
Chào các bác!

Em ðang cần Lisp có khả nãng nhý sau:

1_Chọn "n" ðối týợng trên bản vẽ.

2_Ðổi màu "n" ðối týờng này (mỗi ðối týợng có một màu mới).

Xin chân thành cảm õn! Em ðang rất cần. :cheers:

Ðây, nhýng chỉ ðổi màu các ðối týợng ðõn giản thôi

(defun C:DOIMAUDT( / ss i j name)
 (setq ss (ssget))
 (if ss (progn
(setq i 0 j 1)
(while (< i (sslength ss))
  (setq name (ssname ss i))
  (command "_.change" name "" "p" "c" j "")
  (setq j (1+ j) i (1+ i))
  (if (= j 256) (setq j 1))
)
 ))
)


<<

Filename: 55146_doimaudt.lsp
Tác giả: Bee
Bài viết gốc: 436806
Tên lệnh: test
Lấy lấy kí tự

10 giờ trước, AUTOCAD_2019 đã nói:
>>
10 giờ trước, AUTOCAD_2019 đã nói:

.

Chủ thớt có vẻ cần ^_^

Test thử nhé.

(defun c:test  (/ ss n value pos)
  (if (not (tblsearch "LAYER" "@TEN"))
    (command "Layer" "M" "@TEN" "")
    )
  (if (setq ss (ssget '((0 . "TEXT"))))
    (progn
      (setq n 0)
      (repeat (sslength ss)
        (setq value (vl-list->string (vl-remove-if (function (lambda (u) (or (< 64 u 91) (< 96 u 123))))
                                                   (vl-string->list (vl-string-subst "" "." (vl-string-subst "" " " (cdr (assoc 1 (entget (ssname ss n)))))))
                                                   )
                                     )
              )

        (if (setq pos (vl-string-search "/" value 1))
          (entmake
            (list
              (cons 0 "TEXT")
              (cons 100 "AcDbText")
              (cons 10 (trans (cdr (assoc 10 (entget (ssname ss n)))) 1 0))
              (assoc 40 (entget (ssname ss n)))
              (cons 1 (substr value 1 pos))
              (assoc 7 (entget (ssname ss n)))
              (assoc 50 (entget (ssname ss n)))
              (cons 8 "@TEN")
              (cons 100 "AcDbText")
              )
            )
          ) ;if
        (setq n (1+ n))
        ) ;repeat
      ) ;progn
    ) ;if
  (princ)
  )

 


<<

Filename: 436806_test.lsp
Tác giả: hugo007
Bài viết gốc: 162574
Tên lệnh: moc
Lisp vẽ đai móc

Nếu từ đầu đã có cái file như bên dưới thì mọi người chẳng mất quá nhiều thời gian để xử lý bài toán của bạn...

>>

Nếu từ đầu đã có cái file như bên dưới thì mọi người chẳng mất quá nhiều thời gian để xử lý bài toán của bạn rồi.

 

(defun c:moc ()
(if (not (tblsearch "layer" "daimoc"))
 (command "-LAYER" "m" "daimoc" "c" 1 "daimoc" "" )
 (setvar "clayer" "daimoc" )
)
(setq ss
(ssadd
 (entmakex '(
(0 . "LWPOLYLINE") (100 . "AcDbEntity") (67 . 0) (8 . "daimoc") 
(100 . "AcDbPolyline") (90 . 6) (70 . 0) (43 . 0) (38 . 0) (39 . 0) 
(10 84.67697199678696 -429.3909937113676) (40 . 0) (41 . 0) (42 . 0)
(10 -12.94293644983736 -65.06853555834368) (40 . 0) (41 . 0) (42 . -0.493145426031304) 
(10 59.5015005218429 29.3428928243452) (40 . 0) (41 . 0) (42 . 0) 
(10 968.2754701986995 29.3428928243452) (40 . 0) (41 . 0) (42 . -0.9553521308632)
(10 961.4360737523748 -120.3446071756548) (40 . 0) (41 . 0) (42 . 0) 
(10 811.4360737523748 -120.3446071756548) (40 . 0) (41 . 0) (42 . 0)))
(ssadd))
  blkName "#caiblocknaytenphaidai"
 )
 (if (not (tblsearch "block" blkName))
(progn (command "-block" blkName '(0 0 0) (eval ss) ""))
)
(while (setq pt (getpoint "\n\U+0110i\U+1EC3m ch\U+00E8n :"))
(command "-insert" blkName "s" 1 pt "")
(command  "._explode" (entlast))  
)
(command ".erase" ss "")
(princ)
)

Cảm phiền bác xem lại giúp e lisp nó vẫn còn 1 lỗi nhỏ.Đánh lệnh MOC lần đầu thì ok,đánh tiếp lần hai nó tự tạo ra cái đai móc hình như nằm ở toạ độ 0.0 và vẫn cho mình chọn điểm chèn để vẽ tiếp.Thanks.


<<

Filename: 162574_moc.lsp
Tác giả: bemove
Bài viết gốc: 9937
Tên lệnh: dtt
KHÔNG BIẾT TÊN LỆNH MOVETEXTCENTERRACTANG

;move text 2 center rectang
(defun c:dtt()

 (setvar "cmdecho" 0)
 (setq OS (getvar "OSMODE"))
 (setvar "OSMODE" 32)

 (setq P1 (getpoint "\nPick a corner of the rectangle: "))
 (setq P2 (getcorner P1 "\nPick opposite corner of the rectangle: "))
 (setq A (angle P1 P2))
 (setq D (distance P1 P2))
 (setq P3 (polar P1 A (/ D 2.0)))    

(setq ST (entsel "\nSelect text to center inside rectangle: "))

 (while
   (= ST nil)
    (progn
      (prompt "\nText was not...
>>

;move text 2 center rectang
(defun c:dtt()

 (setvar "cmdecho" 0)
 (setq OS (getvar "OSMODE"))
 (setvar "OSMODE" 32)

 (setq P1 (getpoint "\nPick a corner of the rectangle: "))
 (setq P2 (getcorner P1 "\nPick opposite corner of the rectangle: "))
 (setq A (angle P1 P2))
 (setq D (distance P1 P2))
 (setq P3 (polar P1 A (/ D 2.0)))    

(setq ST (entsel "\nSelect text to center inside rectangle: "))

 (while
   (= ST nil)
    (progn
      (prompt "\nText was not selected...")
      (setq ST (entsel "\nSelect text to center inside rectangle: "))
    )
 )

 (command "justifytext" ST "" "MC")
 (setq TMC (cdr (assoc 11 (entget (car ST)))))
 (command "move" ST "" TMC P3)

 (setvar "OSMODE" OS)
 (princ)

)

 

Lệnh tắt là dtt


<<

Filename: 9937_dtt.lsp
Tác giả: tienquyet123
Bài viết gốc: 133845
Tên lệnh: demc
Cách thống kê số lượng circle

Mình viết cho bạn đây vì nó không dài lắm.

(defun c:demc()
 (setq ra (cdr (assoc 40 (entget (car (entsel "Chon...
>>

Mình viết cho bạn đây vì nó không dài lắm.

(defun c:demc()
 (setq ra (cdr (assoc 40 (entget (car (entsel "Chon duong chon can thong ke:")))))
ci (ssget "x" (list (cons 40 ra)))
kq (sslength ci)
)
 (princ (strcat "\nTong so duong tron co duong kinh: " (rtos ra 2 2) " la " (rtos kq 2 0) " cai"))
 )

 

cám ơn bạn nhưng ko hiểu sao lisp của bạn chọn toàn sai số lượng.

bạn thử check lại giúp mình xem


<<

Filename: 133845_demc.lsp
Tác giả: tienquyet123
Bài viết gốc: 133873
Tên lệnh: dc
Cách thống kê số lượng circle

Lisp bác Tuệ sửa cho bạn chuẩn rồi mà.Mình sửa lại 1 chút để k ghi ra file nữa giúp bạn đây..COpy y nguyên thuật toán đếm của bác Hoành...

>>

Lisp bác Tuệ sửa cho bạn chuẩn rồi mà.Mình sửa lại 1 chút để k ghi ra file nữa giúp bạn đây..COpy y nguyên thuật toán đếm của bác Hoành ^^

 

(defun C:DC(/ e  Ln Bn old X Res) 	
(foreach e (acet-ss-to-list (ssget '((0 . "CIRCLE"))))
        (setq Ln (append Ln (list (* 2 (cdr (assoc 40 (entget e)))))))
 )
(foreach Bn Ln
   (if (setq old (assoc Bn Res))
       (setq Res (subst (cons bn (1+ (cdr old))) old Res))
       (setq Res (append Res (list (cons Bn 1))))
   )
)
(foreach X Res  (princ (strcat "So luong duong tron Duong kinh " (rtos (car X) 2 4) " = " (itoa (cdr X)) "\n")))
(princ)
)

Qua kết quả thì thấy bản vẽ có đúng 10 loại, thao tác thủ công cũng k chậm lắm đâu bạn hiền ^^

 

Đấy là 1 bản vẽ mình đưa lên làm VD mà.

Cám ơn lisp của phamngoctukts nó chạy ngon.

Lisp của Tue_NV mà ketxu sửa cho thì mình chưa dùng đc.

Còn nếu như bạn gia_bach nói cần thành thạo FILTER mình sẽ tìm hiểu thêm

và sẽ cần nhiều sự chỉ giáo của bạn.

 

 


<<

Filename: 133873_dc.lsp
Tác giả: engineer0405
Bài viết gốc: 196598
Tên lệnh: andim
Xin lisp chọn dim

Cái này dùng acet viết rất nhanh

Vài dòng là xong thôi


(defun c:andim(/ ssd)
 (if (setq ssd (ssget '((0 ....
>>

Cái này dùng acet viết rất nhanh

Vài dòng là xong thôi


(defun c:andim(/ ssd)
 (if (setq ssd (ssget '((0 . "DIMENSION"))))
   (acet-ss-visible (acet-ss-remove ssd (ssget "X" '((0 . "DIMENSION")))  ) 1)
 )
)

em cảm ơn anh nhiều ạ

anh cho em hỏi tý nữa ạ

cũng yêu cầu như trên mà áp dụng với text,Mtext thì lisp thế nào ạ


<<

Filename: 196598_andim.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 436939
Tên lệnh: ha
Tìm chỗ bị hở khi vùng chưa khép kín
31 phút trước, AUTOCAD_2019 đã nói:
>>
31 phút trước, AUTOCAD_2019 đã nói:

 

Tôi không có Cad trong tay, viết tạm thế này, bạn test xem có lỗi gì không.


; Tim khoang ho giua cac doi tuong. 03/06/2019
(defun C:HA(/ ho ss i j e1 e2 sta1 end1 sta2 end2 dis1 dis2 dis3 dis4 dis5)
 (setq ho (getreal "\nNhap khoang cach ho min: "))
 (princ "\nChon cac doi tuong kiem tra do ho...")
 (setq ss (ssget '((0 . "ARC,*LINE"))))
 (repeat (setq i (sslength ss))
  (setq i (1- i) e1 (ssname ss i) sta1 (vlax-curve-getstartpoint e1) end1 (vlax-curve-getendpoint e1) dis1 (distance sta1 end1))
  (if (< dis1 ho) (grdraw sta1 end1 1))
  (repeat (setq j (sslength ss))
   (setq j (1- j) e2 (ssname ss j) sta2 (vlax-curve-getstartpoint e2) end2 (vlax-curve-getendpoint e2))
   (setq dis2 (distance end1 end2) dis3 (distance end1 sta2) dis4 (distance sta1 sta2) dis5 (distance sta1 end2))
   (if (< dis2 ho) (grdraw end1 end2 1))
   (if (< dis3 ho) (grdraw end1 sta2 1))
   (if (< dis4 ho) (grdraw sta1 sta2 1))
   (if (< dis5 ho) (grdraw sta1 end2 1)))))
(vl-load-com)   


<<

Filename: 436939_ha.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 436939
Tên lệnh: ha1 ha2
Tìm chỗ bị hở khi vùng chưa khép kín
54 phút trước, AUTOCAD_2019 đã nói:
>>
54 phút trước, AUTOCAD_2019 đã nói:

 

Tôi không có Cad trong tay, viết tạm thế này, bạn test xem có lỗi gì không.


; Tim khoang ho giua cac doi tuong.
(defun C:HA1(/ len ho ss i j e1 e2 sta1 end1 sta2 end2 dis1 dis2 dis3 dis4 dis5)
 (setq len (/ (getvar "viewsize") 100))
 (setq ho (getreal "\nNhap khoang cach ho min: "))
 (princ "\nChon cac doi tuong kiem tra do ho...")
 (setq ss (ssget '((0 . "ARC,*LINE"))))
 (repeat (setq i (sslength ss))
  (setq i (1- i) e1 (ssname ss i) sta1 (vlax-curve-getstartpoint e1) end1 (vlax-curve-getendpoint e1) dis1 (distance sta1 end1))
  (if (< dis1 ho) (progn (VePoint-GR sta1 len 1) (VePoint-GR end1 len 1)))
  (repeat (setq j (sslength ss))
   (setq j (1- j) e2 (ssname ss j) sta2 (vlax-curve-getstartpoint e2) end2 (vlax-curve-getendpoint e2))
   (setq dis2 (distance end1 end2) dis3 (distance end1 sta2) dis4 (distance sta1 sta2) dis5 (distance sta1 end2))
   (if (< dis2 ho) (progn (VePoint-GR end1 len 1) (VePoint-GR end2 len 1)))
   (if (< dis3 ho) (progn (VePoint-GR end1 len 1) (VePoint-GR sta2 len 1)))
   (if (< dis4 ho) (progn (VePoint-GR sta1 len 1) (VePoint-GR sta2 len 1)))
   (if (< dis5 ho) (progn (VePoint-GR sta1 len 1) (VePoint-GR end2 len 1))))))
;----- VÏ Point Grvecs.
(defun VePoint-GR(p len col / p1 p2 p3 p4)
 (setq p1 (polar p pi len) p2 (polar p 0 len) p3 (polar p (/ pi -2) len) p4 (polar p (/ pi 2) len))
 (grvecs (list col p1 p2 p3 p4)))
;-----
; Tim khoang ho giua cac doi tuong. 03/06/2019
(defun C:HA2(/ ho ss i j e1 e2 sta1 end1 sta2 end2 dis1 dis2 dis3 dis4 dis5)
 (setq ho (getreal "\nNhap khoang cach ho min: "))
 (princ "\nChon cac doi tuong kiem tra do ho...")
 (setq ss (ssget '((0 . "ARC,*LINE"))))
 (repeat (setq i (sslength ss))
  (setq i (1- i) e1 (ssname ss i) sta1 (vlax-curve-getstartpoint e1) end1 (vlax-curve-getendpoint e1) dis1 (distance sta1 end1))
  (if (< dis1 ho) (grdraw sta1 end1 1))
  (repeat (setq j (sslength ss))
   (setq j (1- j) e2 (ssname ss j) sta2 (vlax-curve-getstartpoint e2) end2 (vlax-curve-getendpoint e2))
   (setq dis2 (distance end1 end2) dis3 (distance end1 sta2) dis4 (distance sta1 sta2) dis5 (distance sta1 end2))
   (if (< dis2 ho) (grdraw end1 end2 1))
   (if (< dis3 ho) (grdraw end1 sta2 1))
   (if (< dis4 ho) (grdraw sta1 sta2 1))
   (if (< dis5 ho) (grdraw sta1 end2 1)))))
(vl-load-com)   


<<

Filename: 436939_ha1_ha2.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 436960
Tên lệnh: ha4
Tìm chỗ bị hở khi vùng chưa khép kín

Không có Cad, không test được, viết dễ lỗi. Nhớ nhập khoảng hở càng nhỏ càng tốt.


; Tim khoang ho giua cac doi tuong.
(defun C:HA4(/ bk ho ss i j e1 e2 p1 p2 q1 q2 pv kc)
 (setq bk (/ (getvar "viewsize") 100)) ; user co the sua so 100 de lay ban kinh
 (setq ho (getreal "\nNhap khoang cach ho min: "))
 (princ "\nChon cac doi tuong kiem tra do ho...")
 (setq ss (ssget '((0 . "ARC,*LINE"))))
 (repeat (setq i (sslength...
>>

Không có Cad, không test được, viết dễ lỗi. Nhớ nhập khoảng hở càng nhỏ càng tốt.


; Tim khoang ho giua cac doi tuong.
(defun C:HA4(/ bk ho ss i j e1 e2 p1 p2 q1 q2 pv kc)
 (setq bk (/ (getvar "viewsize") 100)) ; user co the sua so 100 de lay ban kinh
 (setq ho (getreal "\nNhap khoang cach ho min: "))
 (princ "\nChon cac doi tuong kiem tra do ho...")
 (setq ss (ssget '((0 . "ARC,*LINE"))))
 (repeat (setq i (sslength ss))
  (setq i (1- i) e1 (ssname ss i) p1 (vlax-curve-getstartpoint e1) p2 (vlax-curve-getendpoint e1))
  (repeat (setq j (sslength ss))
   (setq j (1- j) e2 (ssname ss j) q1 (vlax-curve-getstartpoint e2) q2 (vlax-curve-getendpoint e2))
   (mapcar '(lambda(p e) (setq pv (vlax-curve-getClosestPointTo e p)) (if (< (distance p pv) ho) (progn (MkCircle p bk 1) (MkCircle pv bk 1)))) (list p1 p1 p2 p2 q1 q1 q2 q2) (list e1 e2 e1 e2 e1 e2 e1 e2)))))
(defun MkCircle(pt bk col)
 (entmake (list '(0 . "CIRCLE") (cons 62 col) (cons 10 pt) (cons 40 bk))))
;----- 
(vl-load-com)   


<<

Filename: 436960_ha4.lsp
Tác giả: hung1608
Bài viết gốc: 393907
Tên lệnh: tt%C2%A0
Hiệu Chỉnh Đường Dùng Lệnh Le

 

Thank bác! nhưng bí quá em mới dùng command.

+ Lsp ở dưới có lẽ đạt được cả Y/c 2 và 3 (do chưa hiểu lắm...

>>

 

Thank bác! nhưng bí quá em mới dùng command.

+ Lsp ở dưới có lẽ đạt được cả Y/c 2 và 3 (do chưa hiểu lắm về ý đồ của chủ thớt trong Y/c 3).

+ Yêu cầu Leader phải có 2 đoạn gấp khúc trở lên (2 Segment).

+ Có 1 leader mẫu trước và dùng kiểu offset như lsp trước.

+ Các Segment trước (về phía mũi tên) có chung cùng khoảng cách offset, Segment cuối cùng có khoảng cách khác.

(defun c:tt  (/ AT:Offset LWPoly ang1 ang2 clr dis dis2 ele ent epe ept i lma lpl lsp nepe nept nle npl obj ole opl pee pt1 pte sll)
 (defun AT:Offset  (O D P / _pt p1 p2 c D g)
  (setq _pt (lambda (s) (vlax-curve-getPointAtDist O (s (vlax-curve-getDistAtPoint O p1) 0.00001))))
  (if (and (setq p1 (vlax-curve-getclosestpointtoprojection O (trans P 1 0) '(0 0 1)))
           (or (setq p2 (setq c (_pt +))) (setq p2 (_pt -)))
           (if (minusp (- (* (- (car p2) (car p1)) (- (cadr (trans P 1 0)) (cadr p1)))
                          (* (- (cadr p2) (cadr p1)) (- (car (trans P 1 0)) (car p1)))))
            (if (vl-position (vla-get-objectname O) '("AcDbLine" "AcDbXline"))
             (setq D (- (abs D)))
             (setq D (abs D)))
            (if (vl-position (vla-get-objectname O) '("AcDbLine" "AcDbXline"))
             (setq D (abs D))
             (setq D (- (abs D)))))
           (or c (setq D (- D)))
           (not (vl-catch-all-error-p (setq g (vl-catch-all-apply 'vla-offset (list O D))))))
   (car (vlax-safearray->list (vlax-variant-value g)))))
 (defun LWPoly  (lst)
  (entmakex (append (list (cons 0 "LWPOLYLINE")
                          (cons 100 "AcDbEntity")
                          (cons 100 "AcDbPolyline")
                          (cons 90 (length lst))
                          (cons 70 0))
                    (mapcar (function (lambda (p) p)) lst))))
 (princ "\nSelect a Leader...!")
 (if (setq ele (ssget "_+.:E:S" '((0 . "LEADER"))))
  (progn (setq ent (ssname ele 0)
               ole (vlax-ename->vla-object ent)
               clr (vla-get-DimensionLineColor ole)
               lsp (vl-remove-if-not '(lambda (x) (member (car x) '(10))) (entget ent))
               pte (cdr (last lsp))
               lma (vl-remove-if '(lambda (x) (member (car x) '(-1 5 10))) (entget ent)))
         (if (> (length lsp) 2)
          (progn (setq opl (LWPoly lsp)
                       obj (vlax-ename->vla-object opl))
                 (vla-put-color obj clr)
                 (if (and (setq dis (getdist "\nOffset distance: "))
                          (or (setq dis2 (getreal (strcat "\nOffset Distance last Segment <" (rtos (* dis 1.5)) ">: ")))
                              (setq dis2 (* dis 1.5)))
                          (setq sll (getint "\nNumber of Leader:"))
                          (setq pt1 (getpoint "\nSelect side to offset to: ")))
                  (progn (setq i 1)
                         (repeat sll
                          (if (AT:Offset obj (* dis i) pt1)
                           (progn (setq npl  (entlast)
                                        lpl  (vl-remove-if-not '(lambda (x) (member (car x) '(10))) (entget npl))
                                        epe  (cdr (nth (- (length lsp) 2) lpl))
                                        pee  (cdr (nth (- (length lsp) 3) lpl))
                                        ept  (cdr (last lpl))
                                        ang1 (angle epe ept)
                                        ang2 (angle pte ept))
                                  (and (setq nept (polar pte (angle pte ept) (* dis2 i))
                                             nepe (inters pee epe nept (polar nept ang1 (distance ept epe)) nil))
                                       (setq lpl (append (reverse (cddr (reverse lpl))) (list (cons 10 nepe) (cons 10 nept))))
                                       (setq nle (vlax-ename->vla-object (entmakex (append lma lpl)))))
                                  (if nle
                                   (progn nle
                                          (vla-put-arrowheadsize nle (vla-get-arrowheadsize ole))
                                          (vla-put-DimensionLineColor nle clr)))
                                  (entdel npl)))
                          (setq i (1+ i)))))
                 (vla-erase obj))
          (Acet-ui-message "Lisp chi thuc hien voi Line-Leader co so Segment > 1!" "Thong bao!" (+ 0 16 768)))))
 (princ))

Cảm ơn bạn, có lisp đáp ứng đúng nhu cầu của mình rui

Thanks bạn nhiều


<<

Filename: 393907_tt%C2%A0.lsp
Tác giả: mr.thanh2610
Bài viết gốc: 436997
Tên lệnh: sf
Về vấn đề lisp hatch nhanh
(defun c:SF(/ p dt ans ten sc ang dt)
(setvar "cmdecho" 0)
(initget "B B1 B2 BK G GD GD1 GL GL1 GL2 D D1 C K N N1 TO GO GO1")
(setq ans (getkword "\n Chon kieu hatch < B/B1/B2/BK/G/GD/GD1/GL/GL1/GL2/D/D1/C/K/N/N1/TO/GO/GO1 > : "))
(initget "P S")
(setq ansp (getkword "\n Chon kieu pick diem hay chon doi tuong < P/S > :"))
(setq p nil dt t)
;(WHILE (or (not p) (not dt))

(if (= ans "B") 
(progn 
(setq ten...
>>
(defun c:SF(/ p dt ans ten sc ang dt)
(setvar "cmdecho" 0)
(initget "B B1 B2 BK G GD GD1 GL GL1 GL2 D D1 C K N N1 TO GO GO1")
(setq ans (getkword "\n Chon kieu hatch < B/B1/B2/BK/G/GD/GD1/GL/GL1/GL2/D/D1/C/K/N/N1/TO/GO/GO1 > : "))
(initget "P S")
(setq ansp (getkword "\n Chon kieu pick diem hay chon doi tuong < P/S > :"))
(setq p nil dt t)
;(WHILE (or (not p) (not dt))

(if (= ans "B") 
(progn 
(setq ten "AR-CONC" sc 20.0 ang 0.0
ten2 "ANSI32" sc2 200.0 ang 0.0) 
 (if (= ansp "P")
   (progn
     (while (setq p (getpoint "\n Chon 1 diem trong vung can hatch :"))
     		(lh1 p ten sc ang)
     		(lh1 p ten2 sc2 ang)
     )
   )
   (progn
     (princ "\n Chon doi tuong can hatch :")
     (while (setq dt (ssget) )
     (lh dt ten sc ang)
     (lh dt ten2 sc2 ang)
     )
   )
  )
)
  )





(if (= ans "B1") 
(progn
(setq ten "AR-CONC" sc 20.0 ang 0.0)
  (if (= ansp "P")
    (progn
        (while (setq p (getpoint "\n Chon 1 diem trong vung can hatch :"))
		(lh1 p ten sc ang)
	 )
    )
    (progn
        (princ "\n Chon doi tuong can hatch :")
     	(while (setq dt (ssget) )
    		(lh dt ten sc ang)
	 )
    )
   )
   
)
)




(if (= ans "B2") 
(progn
(setq ten "GRAVEL" sc 100.0 ang 0.0)
  (if (= ansp "P")
    (progn
        (while (setq p (getpoint "\n Chon 1 diem trong vung can hatch :"))
		(lh1 p ten sc ang)
	 )
    )
    (progn
        (princ "\n Chon doi tuong can hatch :")
     	(while (setq dt (ssget) )
    		(lh dt ten sc ang)
	 )
    )
   )
   
)
)


(if (= ans "BK") 
(progn
(setq ten "SOLID" sc 200.0 ang 0.0)
  (if (= ansp "P")
    (progn
        (while (setq p (getpoint "\n Chon 1 diem trong vung can hatch :"))
		(lh1 p ten sc ang)
	 )
    )
    (progn
        (princ "\n Chon doi tuong can hatch :")
     	(while (setq dt (ssget) )
    		(lh dt ten sc ang)
	 )
    )
   )
   
)
)



(if (= ans "G") 
(progn
(setq ten "ANSI31" sc 400.0 ang 0.0)
  (if (= ansp "P")
    (progn
        (while (setq p (getpoint "\n Chon 1 diem trong vung can hatch :"))
		(lh1 p ten sc ang)
	 )
    )
    (progn
        (princ "\n Chon doi tuong can hatch :")
     	(while (setq dt (ssget) )
    		(lh dt ten sc ang)
	 )
    )
   )
   
)
)



(if (= ans "GD") 
(progn
(setq ten "AR-B816" sc 10.0 ang 0.0)
  (if (= ansp "P")
    (progn
        (while (setq p (getpoint "\n Chon 1 diem trong vung can hatch :"))
		(lh1 p ten sc ang)
	 )
    )
    (progn
        (princ "\n Chon doi tuong can hatch :")
     	(while (setq dt (ssget) )
    		(lh dt ten sc ang)
	 )
    )
   )
   
)
)



(if (= ans "GD1") 
(progn
(setq ten "FLGSTONE" sc 500.0 ang 0.0)
  (if (= ansp "P")
    (progn
        (while (setq p (getpoint "\n Chon 1 diem trong vung can hatch :"))
		(lh1 p ten sc ang)
	 )
    )
    (progn
        (princ "\n Chon doi tuong can hatch :")
     	(while (setq dt (ssget) )
    		(lh dt ten sc ang)
	 )
    )
   )
   
)
)




(if (= ans "GL") 
(progn
(setq ten "NET" sc 1500.0 ang 0.0)
  (if (= ansp "P")
    (progn
        (while (setq p (getpoint "\n Chon 1 diem trong vung can hatch :"))
		(lh1 p ten sc ang)
	 )
    )
    (progn
        (princ "\n Chon doi tuong can hatch :")
     	(while (setq dt (ssget) )
    		(lh dt ten sc ang)
	 )
    )
   )
   
)
)

(if (= ans "GL1") 
(progn
(setq ten "ANGLE" sc 700.0 ang 0.0)
  (if (= ansp "P")
    (progn
        (while (setq p (getpoint "\n Chon 1 diem trong vung can hatch :"))
		(lh1 p ten sc ang)
	 )
    )
    (progn
        (princ "\n Chon doi tuong can hatch :")
     	(while (setq dt (ssget) )
    		(lh dt ten sc ang)
	 )
    )
   )
   
)
)

(if (= ans "GL2") 
(progn
(setq ten "AR-HBONE" sc 20.0 ang 0.0)
  (if (= ansp "P")
    (progn
        (while (setq p (getpoint "\n Chon 1 diem trong vung can hatch :"))
		(lh1 p ten sc ang)
	 )
    )
    (progn
        (princ "\n Chon doi tuong can hatch :")
     	(while (setq dt (ssget) )
    		(lh dt ten sc ang)
	 )
    )
   )
   
)
)



(if (= ans "D") 
(progn
(setq ten "HOUND" sc 500.0 ang 45.0)
  (if (= ansp "P")
    (progn
        (while (setq p (getpoint "\n Chon 1 diem trong vung can hatch :"))
		(lh1 p ten sc ang)
	 )
    )
    (progn
        (princ "\n Chon doi tuong can hatch :")
     	(while (setq dt (ssget) )
    		(lh dt ten sc ang)
	 )
    )
   )
   
)
)



(if (= ans "D1") 
(progn
(setq ten "EARTH" sc 500.0 ang 45.0)
  (if (= ansp "P")
    (progn
        (while (setq p (getpoint "\n Chon 1 diem trong vung can hatch :"))
		(lh1 p ten sc ang)
	 )
    )
    (progn
        (princ "\n Chon doi tuong can hatch :")
     	(while (setq dt (ssget) )
    		(lh dt ten sc ang)
	 )
    )
   )
   
)
)







(if (= ans "C") 
(progn
(setq ten "AR-SAND" sc 20.0 ang 0.0)
  (if (= ansp "P")
    (progn
        (while (setq p (getpoint "\n Chon 1 diem trong vung can hatch :"))
		(lh1 p ten sc ang)
	 )
    )
    (progn
        (princ "\n Chon doi tuong can hatch :")
     	(while (setq dt (ssget) )
    		(lh dt ten sc ang)
	 )
    )
   )
   
)
)



(if (= ans "K") 
(progn
(setq ten "AR-RROOF" sc 500.0 ang 45.0)
   (if (= ansp "P")
      (progn
	(while (setq p (getpoint "\n Chon 1 diem trong vung can hatch :"))
		(lh1 p ten sc ang)
	 )
      )
      (progn
	(princ "\n Chon doi tuong can hatch :")
     	(while (setq dt (ssget) )
    		(lh dt ten sc ang)
	 )
      )
   )
)
)



(if (= ans "N") 
(progn
(setq ten "AR-RSHKE" sc 30.0 ang 0.0)
   (if (= ansp "P")
      (progn
	(while (setq p (getpoint "\n Chon 1 diem trong vung can hatch :"))
		(lh1 p ten sc ang)
	 )
      )
      (progn
	(princ "\n Chon doi tuong can hatch :")
     	(while (setq dt (ssget) )
    		(lh dt ten sc ang)
	 )
      )
   )
)
)


(if (= ans "N1") 
(progn
(setq ten "SPANTILE" sc 400.0 ang 0.0)
   (if (= ansp "P")
      (progn
	(while (setq p (getpoint "\n Chon 1 diem trong vung can hatch :"))
		(lh1 p ten sc ang)
	 )
      )
      (progn
	(princ "\n Chon doi tuong can hatch :")
     	(while (setq dt (ssget) )
    		(lh dt ten sc ang)
	 )
      )
   )
)
)





(if (= ans "TO") 
(progn
(setq ten "ANSI32" sc 200.0 ang 45.0)
   (if (= ansp "P")
      (progn
	(while (setq p (getpoint "\n Chon 1 diem trong vung can hatch :"))
		(lh1 p ten sc ang)
	 )
      )
      (progn
	(princ "\n Chon doi tuong can hatch :")
     	(while (setq dt (ssget) )
    		(lh dt ten sc ang)
	 )
      )
   )
)
)




(if (= ans "GO") 
(progn
(setq ten "WOOD8" sc 700.0 ang 0.0)
   (if (= ansp "P")
      (progn
	(while (setq p (getpoint "\n Chon 1 diem trong vung can hatch :"))
		(lh1 p ten sc ang)
	 )
      )
      (progn
	(princ "\n Chon doi tuong can hatch :")
     	(while (setq dt (ssget) )
    		(lh dt ten sc ang)
	 )
      )
   )
)
)



(if (= ans "GO1") 
(progn
(setq ten "WOOD2" sc 500.0 ang 0.0)
   (if (= ansp "P")
      (progn
	(while (setq p (getpoint "\n Chon 1 diem trong vung can hatch :"))
		(lh1 p ten sc ang)
	 )
      )
      (progn
	(princ "\n Chon doi tuong can hatch :")
     	(while (setq dt (ssget) )
    		(lh dt ten sc ang)
	 )
      )
   )
)
)


;);WHILE
(princ)
)
;;;;;;;;
(defun lh1(p name tle goc)
(setvar "hpgaptol" 50.0)
(vl-cmdf "bhatch" "P" name tle goc p "")
)
;;;;;;;;;;
(defun lh(dt name tle goc)
(setvar "hpgaptol" 50.0)
(vl-cmdf "bhatch" "P" name tle goc "S" dt "" "")
) 

Tình hình là mình có sưu tầm 1 Lisp hatch nhanh vật liệu nhưng mình gặp 1 vấn đề là hatch 2 vị trí khác nhau trở lên là mảng hatch không liền khối, mình ko rành lắm về Code chỉ chỉnh sửa lại sơ sơ thôi, nhờ anh em nào rành chỉnh thêm giúp mình với, xin cảm ơn

HATCH NHANH VAT LIEU (SF).lsp


<<

Filename: 436997_sf.lsp
Tác giả: duy782006
Bài viết gốc: 437014
Tên lệnh: sf
Về vấn đề lisp hatch nhanh
(defun c:SF(/ p dt ans ten sc ang dt)
(setvar "cmdecho" 0)
(initget "B B1 B2 BK G GD GD1 GL GL1 GL2 D D1 C K N N1 TO GO GO1")
(setq ans (getkword "\n Chon kieu hatch < B/B1/B2/BK/G/GD/GD1/GL/GL1/GL2/D/D1/C/K/N/N1/TO/GO/GO1 > : "))

(if (= ans "B") 
(progn 
(setq ten "AR-CONC" sc 20.0 ang 0.0
ten2 "ANSI32" sc2 200.0 ang 0.0) 
)
)

(if (= ans "B1") 
(progn
(setq ten "AR-CONC" sc 20.0 ang 0.0)
)
)

(if (= ans "B2")...
>>
(defun c:SF(/ p dt ans ten sc ang dt)
(setvar "cmdecho" 0)
(initget "B B1 B2 BK G GD GD1 GL GL1 GL2 D D1 C K N N1 TO GO GO1")
(setq ans (getkword "\n Chon kieu hatch < B/B1/B2/BK/G/GD/GD1/GL/GL1/GL2/D/D1/C/K/N/N1/TO/GO/GO1 > : "))

(if (= ans "B") 
(progn 
(setq ten "AR-CONC" sc 20.0 ang 0.0
ten2 "ANSI32" sc2 200.0 ang 0.0) 
)
)

(if (= ans "B1") 
(progn
(setq ten "AR-CONC" sc 20.0 ang 0.0)
)
)

(if (= ans "B2") 
(progn
(setq ten "GRAVEL" sc 100.0 ang 0.0)
)
)

(if (= ans "BK") 
(progn
(setq ten "SOLID" sc 200.0 ang 0.0)
)
)

(if (= ans "G") 
(progn
(setq ten "ANSI31" sc 400.0 ang 0.0)
)
)

(if (= ans "GD") 
(progn
(setq ten "AR-B816" sc 10.0 ang 0.0)
)
)

(if (= ans "GD1") 
(progn
(setq ten "FLGSTONE" sc 500.0 ang 0.0)
)
)

(if (= ans "GL") 
(progn
(setq ten "NET" sc 1500.0 ang 0.0)
)
)

(if (= ans "GL1") 
(progn
(setq ten "ANGLE" sc 700.0 ang 0.0)
)
)

(if (= ans "GL2") 
(progn
(setq ten "AR-HBONE" sc 20.0 ang 0.0)
)
)

(if (= ans "D") 
(progn
(setq ten "HOUND" sc 500.0 ang 45.0)
)
)


(if (= ans "D1") 
(progn
(setq ten "EARTH" sc 500.0 ang 45.0)
)
)

(if (= ans "C") 
(progn
(setq ten "AR-SAND" sc 20.0 ang 0.0)
)
)



(if (= ans "K") 
(progn
(setq ten "AR-RROOF" sc 500.0 ang 45.0)
)
)



(if (= ans "N") 
(progn
(setq ten "AR-RSHKE" sc 30.0 ang 0.0)
)
)


(if (= ans "N1") 
(progn
(setq ten "SPANTILE" sc 400.0 ang 0.0)
)
)





(if (= ans "TO") 
(progn
(setq ten "ANSI32" sc 200.0 ang 45.0)
)
)




(if (= ans "GO") 
(progn
(setq ten "WOOD8" sc 700.0 ang 0.0)
)
)



(if (= ans "GO1") 
(progn
(setq ten "WOOD2" sc 500.0 ang 0.0)
)
)

 (setvar "hpname" ten)
 (setvar "hpscale" sc)
 (setvar "hpang" ang)

(initdia)
(command "hatch")
(while (< 0 (getvar "CMDACTIVE"))
(command pause)
) 

(princ)
)

Sửa 1 xí . Lệnh và lựa chọn kiểu hatch như cũ. chọn xong trả lại cho lệnh hatch của cad muốn chọn gì thì chọn.

 


<<

Filename: 437014_sf.lsp
Tác giả: Tue_NV
Bài viết gốc: 437026
Tên lệnh: trr
Help .......nhờ các anh viết lisp ....về lệnh trim

Lâu ngày không viết nên ngứa ngáy tay chân. 

Lisp của bạn đây : Lệnh TRR


(defun c:trr(/ e1 e2 i en)
(defun Tue-geom-divpt (p1 p2 k)
    (polar p1 (angle p1 p2) (* (distance p1 p2) k))
)
(defun Tue-list-tach (lst count / i j Lst-tinh Reslis)
 ;;;;;Ex: (Tue-list-tach '(1 5 4 6 3 5) 2)--> ((1 5) (4 6) (3 5))
 ;;;;;;;;;(Tue-list-tach '(1 5 4 6 3 5) 3)--> ((1 5 4) (6 3 5))
 ;;;;;;;;;(Tue-list-tach '(1 5 4 6 3 5) 5)-->...
>>

Lâu ngày không viết nên ngứa ngáy tay chân. 

Lisp của bạn đây : Lệnh TRR


(defun c:trr(/ e1 e2 i en)
(defun Tue-geom-divpt (p1 p2 k)
    (polar p1 (angle p1 p2) (* (distance p1 p2) k))
)
(defun Tue-list-tach (lst count / i j Lst-tinh Reslis)
 ;;;;;Ex: (Tue-list-tach '(1 5 4 6 3 5) 2)--> ((1 5) (4 6) (3 5))
 ;;;;;;;;;(Tue-list-tach '(1 5 4 6 3 5) 3)--> ((1 5 4) (6 3 5))
 ;;;;;;;;;(Tue-list-tach '(1 5 4 6 3 5) 5)--> nil
   (setq i 0 j 0)
   (while (and (< i (/ (length lst) count)) (= (rem (length lst) count) 0))
    (Repeat count
      (setq Lst-tinh (append Lst-tinh (list (nth j lst)) ))
      (setq j (1+ j))  
     )
         (setq Reslis (append Reslis (list Lst-tinh))
           Lst-tinh nil)
     (setq i (1+ i))
    )
 Reslis
)
(defun Tue-geom-inters(e1 e2 flag / Lst_tong Lst);;;Tue-list-tach
 ;;; flag= 0 : acExtendNone Does not extend either object.
 ;;; flag= 1 : acExtendThisEntity Extends the base object.
 ;;; flag= 2 : acExtendOtherEntity Extends the object passed as an argument.
 ;;; flag= 3 : acExtendBoth  Extends both objects.
;;Ex: (Tue-geom-inters (ssname (TUE-SS-ENTSEL '((0 . "*LINE,ARC,CIRCLE,ELLIPSE")) "\npick chon doi tuong thu 1 :") 0)
;;;;;;;;;;;;;;;;;;;;;;;(ssname (TUE-SS-ENTSEL '((0 . "*LINE,ARC,CIRCLE,ELLIPSE")) "\npick chon doi tuong thu 2 :") 0) 0)
  (if (= (type e1) 'ENAME) (setq e1 (vlax-ename->vla-object e1)))
  (if (= (type e2) 'ENAME) (setq e2 (vlax-ename->vla-object e2)))
  (Tue-list-tach (vlax-invoke e1 'IntersectWith e2 flag) 3)
)
;;;main
  (setq e1 (car(entsel "\n Chon duong cat 1 :")))
  (setq e2 (car(entsel "\n Chon duong cat 2 :")) i -1)
  (if (setq ss (ssget '((0 . "*LINE,ARC"))))
  (while (setq en (ssname ss (setq i (1+ i))))
    (if (and (= (length (setq p1 (Tue-geom-inters e1 en 0))) 1) (= (length (setq p2 (Tue-geom-inters e2 en 0))) 1))
    (command "._trim" e1 e2 ""
         (Tue-geom-divpt (car p1)  (car p2) 0.5) "")
  )
)
)
  )

 


<<

Filename: 437026_trr.lsp

Trang 292/303

292