Đến nội dung


Hình ảnh
* * * - - 17 Bình chọn

Hỏi về Lisp (thuật toán, ý tưởng, coding,...)


  • Please log in to reply
2854 replies to this topic

#1501 ThuyLinh313

ThuyLinh313

    biết lệnh mtext

  • Members
  • PipPipPipPip
  • 288 Bài viết
Điểm đánh giá: 142 (tàm tạm)

Đã gửi 31 January 2013 - 10:37 AM

Lisp của LM cũng là convert. Nếu không convert thì về nguyên tắc vẫn có thể thực hiện được với các hình có biên gồm các cạnh thẳng. với hình có biên cong thì quá khó VoHoan ạ
  • 0

#1502 ThuyLinh313

ThuyLinh313

    biết lệnh mtext

  • Members
  • PipPipPipPip
  • 288 Bài viết
Điểm đánh giá: 142 (tàm tạm)

Đã gửi 02 February 2013 - 10:21 AM

Lisp lấy Sendkeys từ VB, mà hình như MS không hỗ trợ phân biệt các phím shift trái và shift phải cho VB phải không các bạn?
  • 0

#1503 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5682 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 02 February 2013 - 01:10 PM

Có phân biệt LShift và RShift cho VB (bỏ chữ đương nhiên ^^), còn cái bạn hỏi hàm sendkey của VBScript thì MS có liệt kê các phím dùng được rồi, theo mình là không
  • 1

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#1504 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5449 Bài viết
Điểm đánh giá: 2625 (tuyệt vời)

Đã gửi 26 February 2013 - 10:54 AM

Tôi có 1 Block_Dynamic, có gán tham số "Move" cho cụm đối tượng trong
Circle (xem hình 1). Dùng lisp thì có thể Insert Block này vào bản vẽ.

Bây giờ, cũng dùng lisp, làm sao vừa Insert Block này vào bản vẽ vừa Move cụm trong Circle lên 1 đoạn x như hình 2?

Ai biết code xin chỉ giùm.

Link của Block_Dynamic: http://www.cadviet.c...ock_dynamic.dwg

67029_block_dynamic_1.png


  • 0

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#1505 Thaistreetz

Thaistreetz

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 903 Bài viết
Điểm đánh giá: 505 (tốt)

Đã gửi 26 February 2013 - 11:52 AM

Lee mac nó viết hàm này rá»i.
Leemac no viet ham nay roi.
cadviet dang bi loi tieng viet chu minh khong co tinh viet khong dau nhe
  • 2

Hình đã gửi
IN HIM, I TRUST. THE TRUST IN MY GOD


#1506 ThuyLinh313

ThuyLinh313

    biết lệnh mtext

  • Members
  • PipPipPipPip
  • 288 Bài viết
Điểm đánh giá: 142 (tàm tạm)

Đã gửi 26 February 2013 - 05:14 PM

Vào trang cá nhân của lee là thấy ngay trong mục hàm con smile.png

Rất hay! Chắc là cái này rồi: http://lee-mac.com/d...kfunctions.html
Hàm bạn cần là: Set Dynamic Property Value.

PS: Diễn đàn bị sao thế nhỉ? mình không bị lỗi như Thaistreetz, vẫn gõ tiếng việt được nhưng gõ xong 1 từ thì con trỏ lại tự động nhảy về đầu dòng. bực thế!


  • 1

#1507 Nguyen Hoanh

Nguyen Hoanh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 4105 Bài viết
Điểm đánh giá: 4495 (đỉnh cao)

Đã gửi 26 February 2013 - 05:20 PM

Lee mac nó viết hàm này rá»i.
Leemac no viet ham nay roi.
cadviet dang bi loi tieng viet chu minh khong co tinh viet khong dau nhe

 

 

Vào trang cá nhân của lee là thấy ngay trong mục hàm con smile.png

Rất hay! Chắc là cái này rồi: http://lee-mac.com/d...kfunctions.html
Hàm bạn cần là: Set Dynamic Property Value.

PS: Diễn đàn bị sao thế nhỉ? mình không bị lỗi như Thaistreetz, vẫn gõ tiếng việt được nhưng gõ xong 1 từ thì con trỏ lại tự động nhảy về đầu dòng. bực thế!

 

Hai bạn đang dùng trình duyệt gì, phiên bản bao nhiêu?
 


  • 0

#1508 Thaistreetz

Thaistreetz

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 903 Bài viết
Điểm đánh giá: 505 (tốt)

Đã gửi 26 February 2013 - 09:06 PM

Em su dung dien thoai nokia Lumia bac Hoanh a. UCweb browser, vao cadviet giao dien di dong
  • 0

Hình đã gửi
IN HIM, I TRUST. THE TRUST IN MY GOD


#1509 ThuyLinh313

ThuyLinh313

    biết lệnh mtext

  • Members
  • PipPipPipPip
  • 288 Bài viết
Điểm đánh giá: 142 (tàm tạm)

Đã gửi 27 February 2013 - 08:09 AM

Mình dùng Opera 12.11, windows XP sp3. Chiều hôm qua post bài thì bị hiện tượng như mình nêu. Hôm nay viết bài này thì lại không bị như vậy nữa rồi smile.png


  • 0

#1510 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5449 Bài viết
Điểm đánh giá: 2625 (tuyệt vời)

Đã gửi 10 March 2013 - 07:51 PM

Tôi vừa cài Win8 32bit, offic2013, cad2007 thì xãy ra trường hợp này:

- Trong Notepad, đặt font thuộc mã TCVN3, viết một số từ tiếng Việt, sau đó lưu thì máy bảo không phải mã ANSI nên không lưu được.

- Trong Notepad++, đặt font thuộc mã TCVN3, viết một số từ tiếng Việt thì nó nhảy sang từ khác.

Ví dụ:

- Tôi viết 3 từ "Móng", "Đia", "Tiếp" thì lưu lisp trên Notepad không được.

- Tôi cũng viết 3 từ đó trên Notepad++ thì nó tự động nhảy sang "M?ng", "Đ?a", "Ti?p".

Sự việc trên chỉ xãy ra với 1 số từ chứ không phải tất cả.

Ai biết tại sao xin chỉ giùm. Thanks!


  • 0

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#1511 tien2005

tien2005

    biết lệnh properties

  • Members
  • PipPipPipPip
  • 257 Bài viết
Điểm đánh giá: 94 (tàm tạm)

Đã gửi 11 March 2013 - 12:15 PM

Tôi vừa cài Win8 32bit, offic2013, cad2007 thì xãy ra trường hợp này:

- Trong Notepad, đặt font thuộc mã TCVN3, viết một số từ tiếng Việt, sau đó lưu thì máy bảo không phải mã ANSI nên không lưu được.

- Trong Notepad++, đặt font thuộc mã TCVN3, viết một số từ tiếng Việt thì nó nhảy sang từ khác.

Ví dụ:

- Tôi viết 3 từ "Móng", "Đia", "Tiếp" thì lưu lisp trên Notepad không được.

- Tôi cũng viết 3 từ đó trên Notepad++ thì nó tự động nhảy sang "M?ng", "Đ?a", "Ti?p".

Sự việc trên chỉ xãy ra với 1 số từ chứ không phải tất cả.

Ai biết tại sao xin chỉ giùm. Thanks!

 

 

Cái này lúc mình dùng W7 Ulti tì bị lỗi, chuyển qua bản W7 Pro thì không bị nữa. Bạn tìm bản W8 khác thử lại xem


  • 1

#1512 tientracdia

tientracdia

    biết lệnh scale

  • Members
  • PipPipPip
  • 147 Bài viết
Điểm đánh giá: -11 (hơi kém)

Đã gửi 12 March 2013 - 11:59 AM

Mình có sưu tầm lisp trên Cadviet  là SWB_1 : Copy đối đượng trong vùng ( Hình chữ nhật )

Làm thế nào sao khi lisp chọn các đối tượng đó xong, Lisp copy , save as đặt tên mới trong cùng thư mục file chọn để copy trước đó.

File lisp :

(defun c:SWB (/ ov vl bit ss cur ssInside ssOutside ssN ssT ssAll curT plSet) ;SWB -> Sellect 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
    )
  (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
  (command "_.undo" "_m")
  (initget "T N G")
  (setq	bit (getkword "\nBan muon chon Trong hay Ngoai duong bao, hay Giua 2 duong bao <T/N/G>: " ) )
  (cond
    ((= bit "T") ;chon 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))
       (sssetfirst ssInside ssInside)
       )
     )
    
    ((= bit "G") ;chon 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))
     (sssetfirst ssN ssN)
     )

    ((= bit "N") ;chon Ngoai duong bao
     (initget "T G")
     (setq bit (getkword "\nChon Tat ca doi tuong ngoai duong bao, hay chi doi tuong Giao voi duong bao <T/G>: " ) )
     (princ"\n<<< Chon duong bao >>> ")
     (setq ss (ssget "_:S" '((0 . "LWPOLYLINE,CIRCLE,ELLIPSE")))
	   cur (ssname ss 0))
     (if (= bit "T")
       (progn ;chon 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))
	 (sssetfirst ssAll ssAll)
	 )
       ;chi chon doi tuong Giao voi duong bao
       (if (and (setq ssOutside (GetssOutside ss))
		(> (sslength ssOutside) 0))
	 (sssetfirst ssOutside ssOutside)
	 )
       );if
     );;chon Ngoai duong bao
    );cond

  (mapcar 'setvar vl ov) ; reset Sys Vars
  ;(command "zoom" "e")
  ;(command ".copy" "");_copyclip
  ;_pasteorig dan theo toa do
  ;(setq savefile (getfiled "Chon file .dwg:" "" "dwg" 1))
  ;(c:vca1)
  (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
)

Rất mong được các bạn giúp


  • 0

#1513 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5449 Bài viết
Điểm đánh giá: 2625 (tuyệt vời)

Đã gửi 13 March 2013 - 06:34 PM

Bản vẽ A đang mở. Bản vẽ B đang đóng. Trong B có chứa 1 số Block Attribute.

Việc lấy các block trong B để chèn vào A thì OK rồi.

Nhưng việc lấy các Att của từng block trong B thì sao tôi mần hoài không được.

Ai biết xin chỉ giùm với?


  • 0

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#1514 gia_bach

gia_bach

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1436 Bài viết
Điểm đánh giá: 1426 (rất tốt)

Đã gửi 14 March 2013 - 01:49 PM

Bản vẽ A đang mở. Bản vẽ B đang đóng. Trong B có chứa 1 số Block Attribute.

Việc lấy các block trong B để chèn vào A thì OK rồi.

Nhưng việc lấy các Att của từng block trong B thì sao tôi mần hoài không được.

Ai biết xin chỉ giùm với?

Hà tham khảo hàm get_attLst trích trong Lisp Block Attributes Extraction

 (defun get_attLst (fullFileName blkName / acver attlst dbxdoc res)
  (setq dbxdoc (vla-GetInterfaceObject (vlax-get-acad-object)
   (if (< (setq acVer (atoi (getvar "ACADVER"))) 16) "ObjectDBX.AxDbDocument"
     (strcat "ObjectDBX.AxDbDocument." (itoa acVer)))))
  (vla-open dbxdoc fullFileName)
  (vlax-for lay (vla-get-Layouts dbxdoc)
    (vlax-for obj (vla-get-Block lay)
      (if (and (eq (vla-get-ObjectName obj) "AcDbBlockReference")
        (vla-get-HasAttributes obj)
        (eq (vla-get-Name obj) blkname)  )
 (progn
   (setq attLst (list))
   (foreach att (vlax-invoke obj 'GetAttributes)
     (setq attLst (cons (vla-get-TextString Att) attLst)) )
   (setq res (cons (reverse attLst) res))) )))
  (vlax-release-object dbxdoc)
  res)

 

cách sử dụng :

 (defun c:test(/ blkname fil sfile) 
  (if (and
 (setq blkname "HA" ; doi ten block cho phu hop "KTA3Bia" "KTA3ngang"
       sfile(getfiled "File to get Attributes"  (getvar "dwgprefix")  "dwg" 16))
 (setq fil (findfile sfile)))
    (princ (vl-princ-to-string (get_attLst fil blkname))))
  (princ))

 


  • 2

#1515 duy782006

duy782006

    PHẠM QUỐC DUY

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 2155 Bài viết
Điểm đánh giá: 1360 (rất tốt)

Đã gửi 27 March 2013 - 03:08 PM

Mình muốn xin hai hàm con dùng thuần lisp:

1.Tạo danh sách các kiểu đối tượng tạo thành block. Có bao nhiêu thì kê bấy nhiêu trùng cũng kê lại.

2.Tạo danh sách tọa độ đỉnh của pline.

Cám ơn các bác đã quan tâm.


  • 0

Cứ ngỡ trần gian là cõi thật.Cho nên tất bật đến bây giờ.
Tạo hộp thoại bằng lisp My blog QUY ĐỊNH ĐẶT TÊN TOPIC TRONG CHUYÊN MỤC LISPD http://ktsduy.wordpress.com/
Để cám ơn chỉ cần nhấn rep_up.png
(Là nhấn vào nút đó phía bài viết của người ta í chứ đừng có nhè cái hình này mà nhấn miết đi nha :-D


#1516 hochoaivandot

hochoaivandot

    biết dimradius

  • Members
  • PipPipPipPipPip
  • 310 Bài viết
Điểm đánh giá: 107 (tàm tạm)

Đã gửi 27 March 2013 - 03:41 PM

 

(defun GetVer (e / i L)
(setq i 0 L nil)
(repeat (fix (+ (vlax-curve-getEndParam e) 1))
(setq L (append L (list (vlax-curve-getPointAtParam e i))))
(setq i (1+ i))
)
L
)
 

 

 
Có thể dùng cho tấc cả các loại Pline. Tác giả hình như là ssg!
 
 

Tạo danh sách tọa độ đỉnh của pline.


  • 1

Dương Bá Diệp

 

www.cadonline.duyxuyen.vn 

 

Thành viên nhóm CADMAGIC

 


#1517 duy782006

duy782006

    PHẠM QUỐC DUY

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 2155 Bài viết
Điểm đánh giá: 1360 (rất tốt)

Đã gửi 27 March 2013 - 03:48 PM

Mình không muốn dùng vl...  !


  • 0

Cứ ngỡ trần gian là cõi thật.Cho nên tất bật đến bây giờ.
Tạo hộp thoại bằng lisp My blog QUY ĐỊNH ĐẶT TÊN TOPIC TRONG CHUYÊN MỤC LISPD http://ktsduy.wordpress.com/
Để cám ơn chỉ cần nhấn rep_up.png
(Là nhấn vào nút đó phía bài viết của người ta í chứ đừng có nhè cái hình này mà nhấn miết đi nha :-D


#1518 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5682 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 27 March 2013 - 04:14 PM

Quy trình :
Giả sử e là ename của Block, Pline ...
Entnext e = đối tượng/ vertex con đầu tiên trong e (e1)
Entnext e1 = đối tượng/ vertex thứ 2 (e2)
.....
en là thằng cuối
e n+1 sẽ có type là Sequend
=>
Sử dụng hàm while kết hợp với entnext duyệt đến khi nào gặp Sequend thì bác đã có trong tay toàn bộ đối tượng con hoặc vertex trong đối tượng mẹ. Lúc này thì tuỷ bác chém list đó

Hi vọng có ích và bác viết ngon
  • 1

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#1519 ThuyLinh313

ThuyLinh313

    biết lệnh mtext

  • Members
  • PipPipPipPip
  • 288 Bài viết
Điểm đánh giá: 142 (tàm tạm)

Đã gửi 27 March 2013 - 04:22 PM

vl thì cũng là lisp mà. Thuần lisp nghĩa là Autolisp chăng? (các hàm vl là các hàm Visual lisp). Mình tò mò không hiểu điều gì ngăn cản bạn sử dụng Visual lisp?

- câu 1 của bạn hơi khó hiểu.

- câu 2 thì bạn có thể dùng code này

(defun Pline-list-point (en / dxf dxf-etg dxf-etg-m name etg lst)
 (defun dxf (code en) (cdr (assoc code (entget en))))
 (defun dxf-etg (code etg) (cdr (assoc code etg)))
 (defun dxf-etg-m (code etg / lst )
  (foreach asoc etg
   (if (= code (car asoc)) (setq lst (append lst (list (cdr asoc)))))) lst)
 (setq etg (entget en)) 
 (cond ((= (setq name (dxf-etg 0 etg)) "LWPOLYLINE")
        (setq lst (dxf-etg-m 10 etg))
        (if (= (dxf-etg 70 etg) 1) (setq lst (append lst (list (car lst)))) lst))
       ((= name "POLYLINE")
        (while (= (dxf 0 (setq en (entnext en))) "VERTEX")
         (setq lst (append lst (list (dxf 10 en))))) lst)
       ((= name "LINE") (list (dxf-etg 10 etg) (dxf-etg 11 etg)))))

  • 1

#1520 duy782006

duy782006

    PHẠM QUỐC DUY

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 2155 Bài viết
Điểm đánh giá: 1360 (rất tốt)

Đã gửi 27 March 2013 - 04:24 PM

Đang đánh lộn với thằng entnext mà chưa thông.

Ví dụ viết:

 

(setq en (cdr (assoc -2 (tblsearch "block" (cdr (assoc 2 (entget (car (entsel)))))))))
(setq en (entnext en))
(setq endd (cdr (assoc 0 (entget en))))
(princ endd) 
Thì nó ném ra được tên của 1 đối tượng trong block đó.
 
Mình chưa dùng đến while ban đầu thử nghiệm dùng repeat hai lần như sau:
(setq en (cdr (assoc -2 (tblsearch "block" (cdr (assoc 2 (entget (car (entsel)))))))))
(repeat 2
(setq en (entnext en))
(setq endd (cdr (assoc 0 (entget en))))
(princ endd) 
)
Thì lỗi. 

  • 0

Cứ ngỡ trần gian là cõi thật.Cho nên tất bật đến bây giờ.
Tạo hộp thoại bằng lisp My blog QUY ĐỊNH ĐẶT TÊN TOPIC TRONG CHUYÊN MỤC LISPD http://ktsduy.wordpress.com/
Để cám ơn chỉ cần nhấn rep_up.png
(Là nhấn vào nút đó phía bài viết của người ta í chứ đừng có nhè cái hình này mà nhấn miết đi nha :-D