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

hatrongquan88

Thành viên
 Xem Hồ Sơ  Xem hoạt động của họ

  • Số lượng nội dung

    36

  • Đã tham gia

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

  • Ngày trúng

    1

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

  2. Đã đăng · Trả lời báo cáo

    Vào lúc 18/4/2021 tại 18:28, gia_bach đã nói:

    Thay dòng :

    • cadvietlisp.lsp
      lisp help
    •   
    
(setq sFlag (getkword (if IsRus "\nNiodaieou eiidaeiaou a [Oaee/Excel/Ia niodaiyou] <Oaee> : "
"\nSave coordinates to [Text file/Excel/Not save] <Text> : ")))

    thành:

    • cadvietlisp.lsp
      lisp help
    •   
    
(setq sFlag "Excel"

    Trong lisp có 4 dòng như vậy.

    Bạn có thể giúp mình viết 1 lisp như thế này nữa đc k? Mình muốn chuyển gốc tọa độ X, Y (giống lệnh UCS) về vị trí khác. thao tác như thế này:

    1. Gõ lệnh

    2. Pick chon điểm Y1

    3. Nhập khoảng cách từ Y1 về gốc tọa độ

    Phương X vuông góc với phương Y. Ví dụ sau khi thao tác xong ta sẽ có tọa độ điểm pick Y1 là X=0.00 ; Y= 10.00; Z= 0.00

    • Vote giảm 1

  3. Đã đăng · Trả lời báo cáo

    12 giờ trước, gia_bach đã nói:

    Thay dòng :

    • cadvietlisp.lsp
      lisp help
    •   
    
(setq sFlag (getkword (if IsRus "\nNiodaieou eiidaeiaou a [Oaee/Excel/Ia niodaiyou] <Oaee> : "
"\nSave coordinates to [Text file/Excel/Not save] <Text> : ")))

    thành:

    • cadvietlisp.lsp
      lisp help
    •   
    
(setq sFlag "Excel"

    Trong lisp có 4 dòng như vậy.

    Cảm ơn bạn đã hỗ trợ, mình đã thử và thành công.

  4. Đã đăng · Trả lời báo cáo

    3 giờ trước, ketxu đã nói:

    Chưa test nhưng chắc bạn chỉ cần đổi dòng này thôi :
     

    • cadvietlisp.lsp
      lisp help
    •   
    
(if (null sFlag)
      (setq sFlag "Text") 
    )

    thành
     

    • cadvietlisp.lsp
      lisp help
    •   
    
(if (null sFlag)
      (setq sFlag "Excel")
    )

    Lúc nó hỏi đoạn đó thì Enter thôi. Vẫn giữ lại đc các Option để nhỡ đâu có việc cần tới

     

    (if(null sFlag)(setq sFlag "Text"))

    Mình đã thay đổi dòng này chữ Text thành Excel nhưng nó vẫn ưu tiên lựa chọn text file. 

  5. Đã đăng · Trả lời báo cáo

    Mình có sưu tầm được Lisp để phục vụ công việc. Do nhu cầu của công việc và kiến thức có phần hạn chế nên mình xin phép được nhờ anh em trên diễn đàn hỗ trợ chỉnh sửa lại giúp mình lisp này.  Khi thao tác đến phần "Save coordinates to: thì bỏ hẳn lựa chọn Text file và No save (hoặc ưu tiên lựa chon mục có phần chấm đen là Excel). Chúc diễn đàn ngày càng phát triển, mình xin cảm ơn!

    1.png

    2.png

    TT.LSP

  6. Đã đăng · Trả lời báo cáo

    2 giờ trước, duy782006 đã nói:

    Sửa một cách nhanh nhất đây. Dư hay thừa gì  trong code thì kệ, kết quả như ý bạn là được. 

    
;;  DimPolySeq.lsp [command names: DPI, DPO]
;  To dimension the lengths of all segments of a Polyline on the Inboard or Outboard
;    side, adding a sequencing number and colon as prefix.  For self-intersecting or open
;    Polyline without a clear "inside" and "outside," will determine a side -- if not as
;    desired, undo and run other command.
;  Dimensions along arc segments will be angular Dimensions, showing length of arc
;    as text override, not included angle native to angular Dimensions.  They will not
;    update if Polyline is stretched, as Dimensions along line segments will.
;  Uses current Dimension and Units settings; dimension line location distance from
;    Polyline segment = 1.5 x dimension text height for stacked fractions to clear [but
;    see suggestion below if you don't use stacked fractions].
;  Sequencing number + colon & space are in text override; number is stored in non-
;    localized variable *DPseq.  Remembers that, and continues sequence on subsequent
;    usage within same editing session of same drawing, whether using all DPI or all
;    DPO or a mixture of the two commands.
;  Accepts LW and 2D "heavy" Polylines, but not 3D Polylines or meshes.
;  Kent Cooper, 29 August 2016

(vl-load-com)

(defun DP (side / *error* clay cmde styht plsel pl cw inc pt1 pt2 pt3 pt4)

  (defun *error* (errmsg)
    (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
      (princ (strcat "\nError: " errmsg))
    ); if
    (setvar 'clayer clay)
    (setvar 'osmode osm)
    (command-s "_.undo" "_end")
    (setvar 'cmdecho cmde)
    (princ)
  ); defun -- *error*

  (setq clay (getvar 'clayer) osm (getvar 'osmode) cmde (getvar 'cmdecho))
  (setvar 'cmdecho 0)
  (setvar 'osmode 0)
  (if (not *DPseq) (setq *DPseq 1))
  (command
    "_.undo" "_begin"
    "_.layer" "_make" "A-ANNO-DIMS" "_color" 2 "" "" ;; <---EDIT if desired
  ); command
  (setq styht (cdr (assoc 40 (tblsearch "style" (getvar 'dimtxsty))))); height of text style in current dimension style
  (if (= styht 0.0) (setq styht (* (getvar 'dimtxt) (getvar 'dimscale)))); if above is non-fixed-height
  (while
    (not
      (and
        (setq plsel (entsel "\nSelect Polyline: "))
        (wcmatch (cdr (assoc 0 (entget (car plsel)))) "*POLYLINE")
        (= (logand (cdr (assoc 70 (entget (car plsel)))) 88) 0)
          ;; not 3D or mesh [88 = 8 (3D) + 16 (polygon mesh) + 64 (polyface mesh)]
      ); and
    ); not
    (prompt "\nNothing selected, or not a LW or 2D Polyline.")
  ); while
  (setq pl (vlax-ename->vla-object (car plsel)))
  (vla-offset pl styht); temporary
  (setq cw (< (vla-get-area (vlax-ename->vla-object (entlast))) (vla-get-area pl)))
    ;; clockwise for closed or clearly inside/outside open; may not give
    ;; desired result for open without obvious inside/outside
  (entdel (entlast))
  (repeat (setq inc (fix (vlax-curve-getEndParam pl)))
    (setq
      pt1 (vlax-curve-getPointAtParam pl inc)
      pt2 (vlax-curve-getPointAtParam pl (- inc 0.5)); segment midpoint
      pt3 (vlax-curve-getPointAtParam pl (1- inc))
    ); setq
    (if (equal (angle pt1 pt2) (angle pt2 pt3) 1e-8); line segment
      (command ; then
        "_.dimaligned" pt1 pt3
        "_text" "<>"
      ); [leaves at dimension line location prompt]
      (command ; else [arc segment]
        "_.dimangular" ""
        (inters ; arc center
          (setq pt4 (mapcar '/ (mapcar '+ pt1 pt2) '(2 2 2)))
          (polar pt4 (+ (angle pt1 pt2) (/ pi 2)) 1)
          (setq pt4 (mapcar '/ (mapcar '+ pt2 pt3) '(2 2 2)))
          (polar pt4 (+ (angle pt2 pt3) (/ pi 2)) 1)
          nil
        ); inters
        pt1 pt3
        "_text"
          (strcat
            (itoa *DPseq) ": "
            (rtos (abs (- (vlax-curve-getDistAtParam pl inc) (vlax-curve-getDistAtParam pl (1- inc)))) 2 0)
            "mm"
            ;; [edit mode and precision and suffix as desired -- this is per request on AutoCAD Forum]
          ); strcat
      ); command [leaves at dimension line location prompt]
    ); if
    (command ; complete Dimension: dimension line location
      (polar
        pt2
        (apply
          (if (or (and cw (= side "in")) (and (not cw) (= side "out"))) '- '+)
          (list
            (angle '(0 0 0) (vlax-curve-getFirstDeriv pl (- inc 0.5)))
            (/ pi 2)
          ); list
        ); apply
        (* styht 1.5)
          ;; [If you don't use stacked fractions, consider using styht without multiplier]
      ); polar
    ); command
    (setq
      inc (1- inc)
      *DPseq (1+ *DPseq)
    ); setq
  ); repeat
  (setvar 'clayer clay)
  (setvar 'osmode osm)
  (command "_.undo" "_end")
  (setvar 'cmdecho cmde)
  (princ)
); defun -- C:DP

(defun C:DPI () (DP "in")); = Dimension Polyline Inside
(defun C:DPO () (DP "out")); = Dimension Polyline Outside

(prompt "\nType DPI to Dimension a Polyline on the Inside, DPO to do so on the Outside."

     

    Cảm ơn bạn nhiều nha.

  9. Đã đăng · Trả lời báo cáo

    Mình có sưu tầm được trên diễn đàn lisp dim pl cạnh xiên DimPolySeq (Dim PL canh xien).lsp khi chạy lisp thì lisp hiện số thứ đoạn dim 

     

    11.PNG.ee9e7d6753103728cc57d3b846a084b3.PNG

     

    Nhờ các bạn sửa lại giúp mình lược bỏ bớt phần hiển thị số đoạn trước chiều dài đoạn dim, để dim chỉ hiển thị chiều dài dim. Rất mong các bạn giúp đỡ, mình xin cảm ơn.

     

     

  10. Đã đăng · Trả lời báo cáo

    Vào lúc 2/7/2009 tại 09:12, gia_bach đã nói:

    Chào các bạn.

    Về cơ bản thì LISP ERC của bạn Thiệp đã giải quyết đuợc các yêu cầu xóa các đối tuợng trong, ngoài và giữa 2 đuờng bao.

    Tuy nhiên với các đối tuợng có giao với đuờng bao thì Lisp ERC chưa hoàn chỉnh.

    Để giải quyết vấn đề xóa các đối tuợng có giao với đuờng bao, tui dùng giải pháp là cắt các đối tuợng này tại giao điểm với đuờng bao, sử dụng hàm break_with của CAB trên www.TheSwamp.org

    Do hàm break_with chỉ cắt các đối tuợng lines, lwplines, plines, splines, ellipse, circles & arcs nên với các đối tuợng còn lại như Text, Dimension,... LISP không giải quyết triệt để. :s_big:

     

    Các bạn chạy thử và cho ý kiến. File

      

    
(defun c:EWB (/ ov vl ss1 ss2 ptLst plSet) ;EWB -> Erase With Boundary
 (defun *error* (msg)    
   (if ov (mapcar 'setvar vl ov)) ; reset Sys vars
   (princ (strcat "\n<< Error: " msg " >>")) ; Print Error Message
   (princ) ; Exit Cleanly
   )
 (command "_.undo" "_begin")
 (setq vl '("CMDECHO" "OSMODE" "ORTHOMODE") ; Sys Var list
       ov (mapcar 'getvar vl)) ; Get Old values  
 (mapcar 'setvar vl '(0 0 0)) ; Turn off CMDECHO, OSMODE, ORTHOMODE

 (initget "T N G")
 (setq	bit (getkword "\nBan muon xoa Trong hay Ngoai duong bao, hay Giua 2 duong bao : " ) )
 (cond
   ((= bit "T") ;xoa Trong duong bao
    (princ"\n<<< Chon duong bao >>> ")
    (if (and (setq ss (ssget "_:S" '((0 . "LWPOLYLINE,CIRCLE,ELLIPSE"))))
      (setq ssInside (GetssInside ss))
      (> (sslength ssInside) 0))
      (mapcar 'entdel (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssInside))) ) ; xoa ssInside
      )
    )

   ((= bit "G") ;xoa giua 2 duong bao
    (princ"\n<<< Chon duong bao ngoai >>> ")
    (setq ssN (ssget "_:S" '((0 . "LWPOLYLINE,CIRCLE,ELLIPSE"))))
    (princ"\n<<< Chon duong bao trong >>> ")
    (setq ssT (ssget "_:S" '((0 . "LWPOLYLINE,CIRCLE,ELLIPSE")))
   curT (ssname ssT 0)
   ssT (GetssInside ssT)
   ssN (GetssInside ssN))
    (if (and ssT (> (sslength ssT) 0) ssN (> (sslength ssN) 0) )
      (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssT)))
 (if (ssmemb e ssN) (ssdel e ssN)))
      )
    (if (ssmemb curT ssN) (ssdel curT ssN))
    (mapcar 'entdel (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssN))) ) ; xoa ss
    )

   ((= bit "N") ;xoa Ngoai duong bao
    (initget "T G")
    (setq bit (getkword "\nXoa Tat ca doi tuong ngoai duong bao, hay chi doi tuong Giao voi duong bao : " ) )
    (princ"\n<<< Chon duong bao >>> ")
    (setq ss (ssget "_:S" '((0 . "LWPOLYLINE,CIRCLE,ELLIPSE")))
   cur (ssname ss 0))
    (if (= bit "T")
      (progn ;xoa Tat ca doi tuong ngoai duong bao
 (setq ssInside (GetssInside ss)
       ssAll (ssget "x" (list (cons 410 (getvar "ctab")))) )
 (if (and ssInside (> (sslength ssInside) 0) )
   (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssInside)))
     (if (ssmemb e ssAll) (ssdel e ssAll)))
   )
 (if (ssmemb cur ssAll) (ssdel cur ssAll))
 (mapcar 'entdel (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssAll))) ) ; xoa ss
 )
      ;chi xoa doi tuong Giao voi duong bao
      (if (and (setq ssOutside (GetssOutside ss))
	(> (sslength ssOutside) 0))
 (mapcar 'entdel (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssOutside))) ) ; xoa ssOutside
 )
      );if
    );;xoa Ngoai duong bao
   );cond

 (mapcar 'setvar vl ov) ; reset Sys Vars
 (command "_.undo" "_end")
 (princ)
)

(defun GetssOutside (ss2 / ptLst cur ssInside lstss1 ss1 ssTouching)  
 (if (and (setq lstss1 (gettouching ss2))
   (setq ss1 (ssadd))
   (mapcar '(lambda (x) (ssadd x ss1)) lstss1)
   )
   (progn ; co ssTouching 
     (break_with ss1 ss2 nil 0)
     (setq cur (ssname ss2 0)
    ssTouching (ssadd)
    ssOutside (ssadd))
     (mapcar '(lambda (x) (ssadd x ssTouching)) (gettouching ss2))
     ;loc ssTouching -> ssOutside
     (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssTouching)))
(if
  (or
    (not(insidep (vlax-curve-getStartPoint e) cur))
    (not(insidep (vlax-curve-getEndPoint e) cur))
    (not(insidep (vlax-curve-getPointAtParam e (/(+(vlax-curve-getStartParam e)(vlax-curve-getEndParam e))2)) cur))
    );or
  (ssadd e ssOutside)
  );if
);foreach
     );progn
   );if
 (if (ssmemb cur ssOutside) (ssdel cur ssOutside))
 ssOutside
 )

(defun GetssInside (ss2 / ptLst cur ssInside lstss1 ss1 ssTouching)
 (setq ptLst (GetPtLst (setq cur (ssname ss2 0)))
ssInside (ssget "_WP" ptLst ) )  
 (if (and (setq lstss1 (gettouching ss2))
   (setq ss1 (ssadd))
   (mapcar '(lambda (x) (ssadd x ss1)) lstss1)
   )
   (progn ; co ssTouching
     (break_with ss1 ss2 nil 0)
     (setq ssTouching (ssadd))
     (mapcar '(lambda (x) (ssadd x ssTouching)) (gettouching ss2))
     ;loc ssTouching -> ssInside
     (or ssInside (setq ssInside (ssadd)) )
     (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssTouching)))
(if
  (and (insidep (vlax-curve-getStartPoint e) cur)
       (insidep (vlax-curve-getEndPoint e) cur)
       (insidep (vlax-curve-getPointAtParam e (/(+(vlax-curve-getStartParam e)(vlax-curve-getEndParam e))2))  cur)
       )
  (ssadd e ssInside)
  );if
);foreach
     );progn
   );if
 (if (ssmemb cur ssInside) (ssdel cur ssInside))
 ssInside
 )

(defun GetPtLst (obj / startparam endparam anginc delta div inc pt ptlst)
 (defun ZClosed (lst)
   (if (and (vlax-curve-isClosed obj)
      (not(equal (car lst)(last lst) 1e-6)))
     (append lst (list (car lst)))
     lst))

 (or (eq (type obj) 'VLA-OBJECT)
   (setq obj (vlax-ename->vla-object obj)))
 (setq typ (vlax-get obj 'ObjectName))
 (if (or (eq typ "AcDbCircle") (eq typ "AcDbEllipse"))
   (progn
     (setq param 0)
     (while (< param (* pi 2))
(setq pt (vlax-curve-getPointAtParam obj param)
      ptlst (cons pt ptlst)
      param (+ (/ (* pi 2) 72) param))
)
     (reverse ptlst)
     )
   (progn ;Pline (eq typ "AcDbPolyline")
     (setq param (vlax-curve-getStartParam obj)
    endparam (vlax-curve-getEndParam obj)
    anginc (* pi (/ 7.5 180.0)))
     (setq tparam param)
     (while (<= param endparam)
(setq pt (vlax-curve-getPointAtParam obj param))
(if (not (equal pt (car ptlst) 1e-12))
  (setq ptlst (cons pt ptlst)))
(if  (and (/= param endparam)
	  (setq blg (abs (vlax-invoke obj 'GetBulge param)))
	  (/= 0 blg))
  (progn
    (setq delta (* 4 (atan blg)) ;included angle
	  inc (/ 1.0 (1+ (fix (/ delta anginc))))
                 arcparam (+ param inc))
    (while (< arcparam (1+ param))
      (setq pt (vlax-curve-getPointAtParam obj arcparam)
                   ptlst (cons pt ptlst)
                   arcparam (+ inc arcparam))))
  )
(setq param (1+ param))
)
     (if (and (apply 'and ptlst)
       (> (length ptlst) 1))
(ZClosed (reverse ptlst))
)
     )
   )
 )



;;  Copyright © 2009, Lee McDonnell
;;  (Contact Lee Mac, CADTutor.net)
(defun insidep  (pt Obj / Obj Tol ang doc spc flag int lin xV yV)
 (defun vlax-list->3D-point (lst flag)
 (if lst
   (cons ((if flag car cadr) lst)
         (vlax-list->3D-point (cdddr lst) flag))))
 (or (eq 'VLA-OBJECT (type Obj))
     (setq Obj (vlax-ename->vla-object Obj)))
 (if (not(vlax-curve-getParamAtPoint Obj pt))
   (progn
 (setq Tol  (/ pi 6) ; Uncertainty
       ang  0.0 flag T)
 (setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object))
       spc (if (zerop (vla-get-activespace doc))
             (if (= (vla-get-mspace doc) :vlax-true)
               (vla-get-modelspace doc)
               (vla-get-paperspace doc))
             (vla-get-modelspace doc)))
 (while (and (< ang (* 2 pi)) flag)
   (setq flag (and
                (setq int
                  (vlax-invoke
                    (setq lin
                      (vla-addLine spc
                        (vlax-3D-point pt)
                          (vlax-3D-point
                            (polar pt ang
                              (if (vlax-property-available-p Obj 'length)
                                (vla-get-length Obj) 1.0)))))
                                 'IntersectWith Obj
                                   acExtendThisEntity))
                (<= 6 (length int))
                (setq xV (vl-sort (vlax-list->3D-point int T) '<)
                      yV (vl-sort (vlax-list->3D-point int nil) '<))
                (or (<= (car xV) (car pt) (last xV))
                    (<= (car yV) (cadr pt) (last yV))))
         ang  (+ ang Tol))
   (vla-delete lin))
 flag
 )
   T
   ))


;;; Author: Copyrightｩ 2006-2008 Charles Alan Butler 
;;; Contact @  www.TheSwamp.org
;;===========================================================================
 ;;  get all objects touching entities in the sscross                         
 ;;  limited obj types to "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
 ;;  returns a list of enames
 ;;===========================================================================
(defun gettouching (sscros / ss lst lstb lstc objl)
   (and
     (setq lstb (vl-remove-if 'listp (mapcar 'cadr (ssnamex sscros)))
           objl (mapcar 'vlax-ename->vla-object lstb)
     )
     (setq ss (ssget "_A" (list (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
			 (cons 410 (getvar "ctab"))))
     )
     (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
     (setq lst (mapcar 'vlax-ename->vla-object lst))
     (mapcar
       '(lambda (x)
          (mapcar
            '(lambda (y)
               (if (not
                     (vl-catch-all-error-p
                       (vl-catch-all-apply
                         '(lambda ()
                            (vlax-safearray->list
                              (vlax-variant-value
                                (vla-intersectwith y x acextendnone)
                              ))))))
                 (setq lstc (cons (vlax-vla-object->ename x) lstc))
               )
             ) objl)
        ) lst)
   )
   lstc
 )
;;; Author: Copyrightｩ 2006-2008 Charles Alan Butler 
;;; Contact @  www.TheSwamp.org
(defun break_with (ss2brk ss2brkwith self Gap / cmd intpts lst masterlist ss ssobjs
                  onlockedlayer ssget->vla-list list->3pair GetNewEntities oc
                  get_interpts break_obj GetLastEnt LastEntInDatabase ss2brkwithList
                 )
 ;; ss2brk     selection set to break
 ;; ss2brkwith selection set to use as break points
 ;; self       when true will allow an object to break itself
 ;;            note that plined will break at each vertex
 ;;
 ;; return list of enames of new objects  
 (vl-load-com)  
 (princ "\nCalculating Break Points, Please Wait.\n")
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;                S U B   F U N C T I O N S                      
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

 ;;  return T if entity is on a locked layer
 (defun onlockedlayer (ename / entlst)
   (setq entlst (tblsearch "LAYER" (cdr (assoc 8 (entget ename)))))
   (= 4 (logand 4 (cdr (assoc 70 entlst))))
 )

 ;;  return a list of objects from a selection set
;|  (defun ssget->vla-list (ss)
   (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss ))))
 )|;
 (defun ssget->vla-list (ss / i ename allobj) ; this is faster, changed in ver 1.7
      (setq i -1)
      (while (setq  ename (ssname ss (setq i (1+ i))))
        (setq allobj (cons (vlax-ename->vla-object ename) allobj))
      )
      allobj
 )

 ;;  return a list of lists grouped by 3 from a flat list
 (defun list->3pair (old / new)
   (while (setq new (cons (list (car old) (cadr old) (caddr old)) new)
                old (cdddr old)))
   (reverse new)
 )

;;=====================================
;;  return a list of intersect points  
;;=====================================
(defun get_interpts (obj1 obj2 / iplist)
 (if (not (vl-catch-all-error-p
            (setq iplist (vl-catch-all-apply
                           'vlax-safearray->list
                           (list
                             (vlax-variant-value
                               (vla-intersectwith obj1 obj2 acextendnone)
                             ))))))
   iplist
 )
)

;;========================================
;;  Break entity at break points in list  
;;========================================
(defun break_obj (ent brkptlst BrkGap / brkobjlst en enttype maxparam closedobj
                 minparam obj obj2break p1param p2param brkpt2 dlst idx brkptS
                 brkptE brkpt result GapFlg result ignore dist tmppt
                 #ofpts 2gap enddist lastent obj2break stdist
                )
 (or BrkGap (setq BrkGap 0.0)) ; default to 0
 (setq BrkGap (/ BrkGap 2.0)) ; if Gap use 1/2 per side of break point

 (setq obj2break ent
       brkobjlst (list ent)
       enttype   (cdr (assoc 0 (entget ent)))
       GapFlg    (not (zerop BrkGap)) ; gap > 0
       closedobj (vlax-curve-isclosed obj2break)
 )
 ;; when zero gap no need to break at end points
 (if (zerop Brkgap)
   (setq spt (vlax-curve-getstartpoint ent)
         ept (vlax-curve-getendpoint ent)
         brkptlst (vl-remove-if '(lambda(x) (or (< (distance x spt) 0.0001)
                                                (< (distance x ept) 0.0001)))
                                brkptlst)
   )
 )
 (if brkptlst
   (progn
 ;;  sort break points based on the distance along the break object
 ;;  get distance to break point, catch error if pt is off end
 ;; ver 2.0 fix - added COND to fix break point is at the end of a
 ;; line which is not a valid break but does no harm
 (setq brkptlst (mapcar '(lambda(x) (list x (vlax-curve-getdistatparam obj2break
                                              ;; ver 2.0 fix
                                              (cond ((vlax-curve-getparamatpoint obj2break x))
                                                  ((vlax-curve-getparamatpoint obj2break
                                                    (vlax-curve-getclosestpointto obj2break x))))))
                           ) brkptlst))
 ;; sort primary list on distance
 (setq brkptlst (vl-sort brkptlst '(lambda (a1 a2) (< (cadr a1) (cadr a2)))))

 (if GapFlg ; gap > 0
   ;; Brkptlst starts as the break point and then a list of pairs of points
   ;;  is creates as the break points
   (progn
     ;;  create a list of list of break points
     ;;  ((idx# stpoint distance)(idx# endpoint distance)...)
     (setq idx 0)
     (foreach brkpt brkptlst

       ;; ----------------------------------------------------------
       ;;  create start break point, then create end break point    
       ;;  ((idx# startpoint distance)(idx# endpoint distance)...)  
       ;; ----------------------------------------------------------
       (setq dist (cadr brkpt)) ; distance to center of gap
       ;;  subtract gap to get start point of break gap
       (cond
         ((and (minusp (setq stDist (- dist BrkGap))) closedobj )
          (setq stdist (+ (vlax-curve-getdistatparam obj2break
                            (vlax-curve-getendparam obj2break)) stDist))
          (setq dlst (cons (list idx
                                 (vlax-curve-getpointatparam obj2break
                                        (vlax-curve-getparamatdist obj2break stDist))
                                 stDist) dlst))
          )
         ((minusp stDist) ; off start of object so get startpoint
          (setq dlst (cons (list idx (vlax-curve-getstartpoint obj2break) 0.0) dlst))
          )
         (t
          (setq dlst (cons (list idx
                                 (vlax-curve-getpointatparam obj2break
                                        (vlax-curve-getparamatdist obj2break stDist))
                                 stDist) dlst))
         )
       )
       ;;  add gap to get end point of break gap
       (cond
         ((and (> (setq stDist (+ dist BrkGap))
                  (setq endDist (vlax-curve-getdistatparam obj2break
                                    (vlax-curve-getendparam obj2break)))) closedobj )
          (setq stdist (- stDist endDist))
          (setq dlst (cons (list idx
                                 (vlax-curve-getpointatparam obj2break
                                        (vlax-curve-getparamatdist obj2break stDist))
                                 stDist) dlst))
          )
         ((> stDist endDist) ; off end of object so get endpoint
          (setq dlst (cons (list idx
                                 (vlax-curve-getpointatparam obj2break
                                       (vlax-curve-getendparam obj2break))
                                 endDist) dlst))
          )
         (t
          (setq dlst (cons (list idx
                                 (vlax-curve-getpointatparam obj2break
                                        (vlax-curve-getparamatdist obj2break stDist))
                                 stDist) dlst))
         )
       )
       ;; -------------------------------------------------------
       (setq idx (1+ IDX))
     ) ; foreach brkpt brkptlst


     (setq dlst (reverse dlst))
     ;;  remove the points of the gap segments that overlap
     (setq idx -1
           2gap (* BrkGap 2)
           #ofPts (length Brkptlst)
     )
     (while (<= (setq idx (1+ idx)) #ofPts)
       (cond
         ((null result) ; 1st time through
          (setq result (list (car dlst)) ; get first start point
                result (cons (nth (1+(* idx 2)) dlst) result))
         )
         ((= idx #ofPts) ; last pass, check for wrap
          (if (and closedobj (> #ofPts 1)
                   (<= (+(- (vlax-curve-getdistatparam obj2break
                           (vlax-curve-getendparam obj2break))
                         (cadr (last BrkPtLst))) (cadar BrkPtLst)) 2Gap))
            (progn
              (if (zerop (rem (length result) 2))
                (setq result (cdr result)) ; remove the last end point
              )
              ;;  ignore previous endpoint and present start point
              (setq result (cons (cadr (reverse result)) result) ; get last end point
                    result (cdr (reverse result))
                    result (reverse (cdr result)))
            )
          )
         )
         ;; Break Gap Overlaps
         ((< (cadr (nth idx Brkptlst)) (+ (cadr (nth (1- idx) Brkptlst)) 2Gap))
          (if (zerop (rem (length result) 2))
            (setq result (cdr result)) ; remove the last end point
          )
          ;;  ignore previous endpoint and present start point
          (setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get present end point
          )
         ;; Break Gap does Not Overlap previous point 
         (t
          (setq result (cons (nth (* idx 2) dlst) result)) ; get this start point
          (setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get this end point
         )
       ) ; end cond stmt
     ) ; while

     (setq dlst     (reverse result)
           brkptlst nil)
     (while dlst ; grab the points only
       (setq brkptlst (cons (list (cadar dlst)(cadadr dlst)) brkptlst)
             dlst   (cddr dlst))
     )
   )
 )
 ;;   -----------------------------------------------------

 ;; (if (equal  a ent) (princ)) ; debug CAB  -------------

 (foreach brkpt (reverse brkptlst)
   (if GapFlg ; gap > 0
     (setq brkptS (car brkpt)
           brkptE (cadr brkpt))
     (setq brkptS (car brkpt)
           brkptE brkptS)
   )
   ;;  get last entity created via break in case multiple breaks
   (if brkobjlst
     (progn
       (setq tmppt brkptS) ; use only one of the pair of breakpoints
       ;;  if pt not on object x, switch objects
       (if (not (numberp (vl-catch-all-apply
                           'vlax-curve-getdistatpoint (list obj2break tmppt))))
         (progn ; find the one that pt is on
           (setq idx (length brkobjlst))
           (while (and (not (minusp (setq idx (1- idx))))
                       (setq obj (nth idx brkobjlst))
                       (if (numberp (vl-catch-all-apply
                                      'vlax-curve-getdistatpoint (list obj tmppt)))
                         (null (setq obj2break obj)) ; switch objects, null causes exit
                         t
                       )
                  )
           )
         )
       )
     )
   )

   (setq closedobj (vlax-curve-isclosed obj2break))
   (if GapFlg ; gap > 0
     (if closedobj
       (progn ; need to break a closed object
         (setq brkpt2 (vlax-curve-getPointAtDist obj2break
                    (- (vlax-curve-getDistAtPoint obj2break brkptE) 0.00001)))
         (command "._break" obj2break "_non" (trans brkpt2 0 1)
                  "_non" (trans brkptE 0 1))
         (and (= "CIRCLE" enttype) (setq enttype "ARC"))
         (setq BrkptE brkpt2)
       )
     )

     (if (and closedobj 
              (not (setq brkptE (vlax-curve-getPointAtDist obj2break
                      (+ (vlax-curve-getdistatparam obj2break
                           ;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001))))
                           ;; ver 2.0 fix
                           (cond ((vlax-curve-getparamatpoint obj2break brkpts))
                                 ((vlax-curve-getparamatpoint obj2break
                                     (vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001)))))
       (setq brkptE (vlax-curve-getPointAtDist obj2break
                      (- (vlax-curve-getdistatparam obj2break
                           ;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001)))
                           ;; ver 2.0 fix
                           (cond ((vlax-curve-getparamatpoint obj2break brkpts))
                                 ((vlax-curve-getparamatpoint obj2break
                                     (vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001)))
      )
   ) ; endif

   ;; (if (null brkptE) (princ)) ; debug

   (setq LastEnt (GetLastEnt))
   (command "._break" obj2break "_non" (trans brkptS 0 1) "_non" (trans brkptE 0 1))
   (and *BrkVerbose* (princ (setq *brkcnt* (1+ *brkcnt*))) (princ "\r"))
   (and (= "CIRCLE" enttype) (setq enttype "ARC"))
   (if (and (not closedobj) ; new object was created
            (not (equal LastEnt (entlast))))
       (setq brkobjlst (cons (entlast) brkobjlst))
   )
 )
 )
 ) ; endif brkptlst

) ; defun break_obj

;;====================================
;;  CAB - get last entity in datatbase
(defun GetLastEnt ( / ename result )
 (if (setq result (entlast))
   (while (setq ename (entnext result))
     (setq result ename)
   )
 )
 result
)
;;===================================
;;  CAB - return a list of new enames
(defun GetNewEntities (ename / new)
 (cond
   ((null ename) (alert "Ename nil"))
   ((eq 'ENAME (type ename))
     (while (setq ename (entnext ename))
       (if (entget ename) (setq new (cons ename new)))
     )
   )
   ((alert "Ename wrong type."))
 )
 new
)

 ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 ;;         S T A R T  S U B R O U T I N E   H E R E              
 ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

   (setq LastEntInDatabase (GetLastEnt))
   (if (and ss2brk ss2brkwith)
   (progn
     (setq oc 0
           ss2brkwithList (ssget->vla-list ss2brkwith))
     (if (> (* (sslength ss2brk)(length ss2brkwithList)) 5000)
       (setq *BrkVerbose* t)
     )
     (and *BrkVerbose*
          (princ (strcat "Objects to be Checked: "
           (itoa (* (sslength ss2brk)(length ss2brkwithList))) "\n")))
     ;;  CREATE a list of entity & it's break points
     (foreach obj (ssget->vla-list ss2brk) ; check each object in ss2brk
       (if (not (onlockedlayer (vlax-vla-object->ename obj)))
         (progn
           (setq lst nil)
           ;; check for break pts with other objects in ss2brkwith
           (foreach intobj  ss2brkwithList
             (if (and (or self (not (equal obj intobj)))
                      (setq intpts (get_interpts obj intobj))
                 )
               (setq lst (append (list->3pair intpts) lst)) ; entity w/ break points
             )
             (and *BrkVerbose* (princ (strcat "Objects Checked: " (itoa (setq oc (1+ oc))) "\r")))
           )
           (if lst
             (setq masterlist (cons (cons (vlax-vla-object->ename obj) lst) masterlist))
           )
         )
       )
     )    
     (and *BrkVerbose* (princ "\nBreaking Objects.\n"))
     (setq *brkcnt* 0) ; break counter
     ;;  masterlist = ((ent brkpts)(ent brkpts)...)
     (if masterlist
       (foreach obj2brk masterlist
         (break_obj (car obj2brk) (cdr obj2brk) Gap)
       )
     )
     )
 )
;;==============================================================
  (and (zerop *brkcnt*) (princ "\nNone to be broken."))
  (setq *BrkVerbose* nil)
 (GetNewEntities LastEntInDatabase) ; return list of enames of new objects
)
     

     

    Cảm ơn anh gia _bach đã search lisp hay cho anh em 4r, lisp này dùng rất hay. Nếu anh gia _bach bổ sung thêm tính năng lisp có thể nhớ lại thao tác lần trước mình ghi kiểu xóa đối tương T,N hoặc G thì lisp rất hoàn thiện.

    • Vote tăng 1

  11. Đã đăng · Trả lời báo cáo

    Nhờ các bạn viết giúp lisp sắp xếp mặt cắt ngang vào block hoặc rectang bên model. lisp có thể sắp xếp theo những dạng như sau:
    1. 2 mặt cắt vào trong 1 block (rectang) khung tên A3, A4 theo 1 hàng từ trái sang phải;

    2. 4 mặt cắt vào trong 1 block (rectang) khung tên A3, A4 theo 2 hàng từ trái sang phải;

    3. 1 mặt cắt vào trong 1 block (rectang) khung tên A3, A4 theo 1 cột từ dưới lên trên hoặc từ trên xuống dưới.

    Cụ thể trong bản vẽ minh họa TEST.dwg

    Trân trọng cảm ơn các bạn đã giúp đỡ!

    • Vote giảm 2

  12. Đã đăng · Trả lời báo cáo

    Vào lúc 2/11/2016 tại 16:23, Danh Cong đã nói:

     

    "Text" bạn nhìn thấy thực chất là các đường dimention kích thước do bác @KetXu đã ẩn đi các đường gióng rồi.

     Muốn thay đổi số sau dấu phẩy hay là chiều cao chữ thì cứ vào "Dimention Style" hiện tại mà thay đổi theo ý thích thôi.  :D :D

    Nhờ bạn hướng dẫn giúp mình muốn cho hiện đường gióng lên thì làm như thế nào vậy?

  13. Đã đăng · Trả lời báo cáo

    8 giờ trước, phongnh đã nói:

    Em có ý kiến thêm, anh chủ topic và anh viết lisp xem thế nào:

    Thêm lựa chọn góc dốc lớn hơn "đánh số độ vào" thay vì như mặc định 30 độ.

    Bạn có thể sửa độ dốc theo độ dốc mình cần tại dòng này:

                (if (>= (abs (/ (cadr l) (car l))) 0.3) ;DO DOC LON HON 30%

    Bạn có thể nhờ bạn viết lisp để hoàn thiện thêm. Mình thì ít khi dùng lisp dạng thế này, tuy chưa hoàn thiện nhưng chỉ cần giải quyết được vấn đề là ok rồi bạn :D

  14. Đã đăng · Trả lời báo cáo

    Mình tìm được trên diễn đàn lisp Insert Block.LSP của bạn Duong Nhat Duy (https://www.cadviet.com/forum/profile/167212-duong-nhat-duy/) với đối tượng là đường polyline và line thì lisp làm việc rất tốt. Giờ mình gặp phải trường hợp đường polyline giao cắt với Spline thì lisp không nhận, mong các giúp đỡ sửa giúp mình lisp này có thể chèn block vào điểm giao cắt giữa Polyline (do đặc thù của công việc nên mình k chuyển từ đường Spline thành Polyline mà giữ nguyên đường spline) 

    Trân trọng cảm ơn các bạn!

  16. Đã đăng · Trả lời báo cáo

    Vào lúc 28/8/2007 tại 08:28, ssg đã nói:

    Chương trình "mini" này chắc hợp ý bạn:

     

      

    
(defun C:OO(/ kc kc1 e msg)
(if (<= (setq kc (getvar "OFFSETDIST")) 0) (setq kc 20))
(setq msg (strcat "\nSpecial offset command\nOffset distance <" (rtos kc) ">:"))
(if (setq kc1 (getreal msg)) (setq kc kc1))
(while (setq e (car (entsel)))
(command "offset" kc e pause "")
(command "change" "L" "" "P" "LA" (getvar "clayer") "LT" (getvar "celtype") "")
)
)
     

     

    Bác có sửa giúp em sửa lại lisp lúc chọn đối tượng muốn offset thành quét một lúc chọn được nhiều đối tượng?

  17. Đã đăng · Trả lời báo cáo

    Hiện tại mình đang làm hoàn công phải gióng cao độ và khoảng cách lẻ rất nhiều bản vẽ như file cad  TEST.dwg, mình đang dùng lisp  LISP GHI CAO DO VA KHOANG CACH LE.rar  để ghi cao độ và khoảng cách lẻ. Nhược điểm của lisp là chỉ chạy từng mặt cắt ngang một. Mình muốn nhờ các bạn viết giúp một lisp có thể xử lý nhiều mặt cắt cùng lúc. Bác nào có thiện chí có thể liên hệ với em qua sđt 0973630004

    • Like 1
    • Vote giảm 1

  18. Đã đăng · Trả lời báo cáo

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

    @hatrongquan88của bạn đây 

    
(defun c:nht (/ EN L LAY LSP P X Y)
  (princ "\nChon duong pline")
  (while (setq en (ssget '((0 . "*POLYLINE"))))
    (foreach en	(vl-remove-if 'listp (mapcar 'cadr (ssnamex en)))
      (setq lay (cdr (assoc 8 (entget en))))
      (setq lsp
	     (mapcar
	       'cdr
	       (vl-remove-if-not '(lambda (x) (= 10 (car x))) (entget en))
	     ) ;_ end of mapcar
      ) ;_ end of setq
      (mapcar
	'(lambda (x y)
	   (setq l (mapcar '- x y))
	   (if (>= (abs (/ (cadr l) (car l))) 0.3) ;DO DOC LON HON 30%
	     (entmakex
	       (append
		 (list (cons 0 "LWPOLYLINE")
		       (cons 100 "AcDbEntity")
		       (cons 100 "AcDbPolyline")
		       (cons 90 2)
		       (cons 8 LAY)
		 ) ;_ end of list
		 (mapcar (function (lambda (p) (cons 10 p))) (LIST X Y))
	       ) ;_ end of append
	     ) ;_ end of entmakex
	   ) ;_ end of if
	 ) ;_ end of lambda
	lsp
	(cdr lsp)
      ) ;_ end of mapcar
      (entdel en)
    ) ;_ end of foreach
  ) ;_ end of while
  (princ)
) ;_ end of defun

     

    Cảm ơn bạn mình đã giải quyết được vấn đề

  19. Đã đăng · Trả lời báo cáo

    Do mình chưa test kỹ, lisp nhận đường polyline. Được voi đòi tiên tí, bạn đã giúp thì giúp cho trót nhé hihi, lisp trên làm việc được từng mặt cắt bạn có thể giúp mình thao tác khi chọn polyline thì mình quét nhiều đường polyline để lisp xử lý nhiều mặt cắt cùng một lúc được k bạn? mình xin cảm ơn

    • Vote giảm 1

  21. Đã đăng · Trả lời báo cáo

    5 phút trước, tien2005 đã nói:

    Ý của Bạn là khi xóa các đoạn thẳng có độ dóc <30% thì có nghĩa là xóa đi đường polyline cũa và vẽ lạ các đường line mới tương ứng có độ dốc >=30% phải không. Sau khi có các line mới thì có cần làm thêm gì không?

    Đúng như ý bạn nói mình muốn xóa đi polyline cũ, sau khi tách được những đoạn có độ đốc bằng và lớn hơn 30% thì mình tính chiều dài của các đoạn có polyline  >= 30% rồi pick ra text là được bạn ạ.

     

  22. Đã đăng · Trả lời báo cáo

    Mình đang làm hồ sơ hoàn công, cần tính độ dốc đường tự nhiên rất nhiều mặt cắt. Mong các bạn viết lisp giúp đỡ với yêu cầu như sau:

    1. Tính độ dốc của nhiều đoạn thẳng ngắn (là đỉnh của đường polyline) trong 1 đường polyline có nhiều đỉnh.

    2. Xóa hết những đoạn thẳng có độ dốc nhỏ hơn 30%

    Chi tiết mình có gửi file đính kèm.

    Cảm ơn các bạn!

    Tinh do doc.dwg

  25. Đã đăng · Trả lời báo cáo

    2 phút trước, huunhantvxdts đã nói:

    Rãnh rỗi viết tí cho vui

    bạn test thế nào nhé

    • dempoint.lsp
      lisp help
    •   
    
(defun c:dempoint (/ sspoint sopoint text)
(prompt "\nChon point can dem")
(While (setq sspoint (acet-ss-to-list (ssget '((0 .  "POINT")))))
(setq sopoint (length sspoint))
(setq text (car (entsel "\nChon text thay the:")))
 (vla-put-textstring (vlax-ename->vla-object text) (rtos sopoint 2 0))
)
(princ)
)

     

    Cảm ơn bạn lisp rất hay đã giải quyết được vấn đề của mình.

×