Đế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
2851 replies to this topic

#2541 Tr.CongSon

Tr.CongSon

    biết lệnh array

  • Members
  • PipPipPip
  • 183 Bài viết
Điểm đánh giá: 40 (tàm tạm)

Đã gửi 23 June 2015 - 10:40 AM

Chào các anh chị,

Em có 4 điểm là 4 đỉnh của hình chữ nhật,em muốn tạo pline (gồm line và arc) qua 4 đỉnh của HCN,sao cho 2 cạnh ngắn của HCN là cung tròn ARC

Em làm (command "pline") thì được nhưng dùng entmake thì không biết tạo như thế nào...

Anh chị có thể code cho em 1 đoạn tham khảo được ko ạ

Em cảm ơn,

(entmake (list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")

.....
.....

)

 Do công ty không cho Up file nên mong mọi người thông cảm.


  • 0

#2542 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

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

Đã gửi 23 June 2015 - 10:48 AM

Khi entmake pline có cung tròn thì rất phức tạp. Trường hợp của bạn chỉ có 2 arc thì cách làm như này là tiện nhất:

Vẽ Pline thỏa mãn >> lấy entget nó >> từ đó suy ra cách entmake.


  • 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.


#2543 quocmanh04tt

quocmanh04tt

    biết lệnh imageclip

  • Members
  • PipPipPipPipPipPipPip
  • 673 Bài viết
Điểm đánh giá: 313 (khá)

Đã gửi 23 June 2015 - 11:14 AM

@ Bác Doan Van Ha: Em nghĩ cũng không đến nỗi phức tạp lắm đâu...! Đây là Entmake PL có ARC:
(defun mpline:bulges (point-list bulge-list)
(entmake (apply (function append)
(cons (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(67 . 0)
'(410 . "Model")
(cons 43 0)
'(100 . "AcDbPolyline")
(cons 90 (length point-list))
'(70 . 0))
(mapcar (function list)
(mapcar (function (lambda (a) (cons 10 a))) point-list)
(mapcar (function (lambda ( B) (cons 42 B))) bulge-list))))))

Trong đó bulge-list giá trị tại các point, được tính (như hình kèm theo) = tan (góc chắn cung / 4).
141736_bulge2arc.png
  • 1

#2544 ketxu

ketxu

    Copier - Paster - Editor

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

Đã gửi 23 June 2015 - 11:17 AM

Chú ý @ nhé bạn quocmanh04tt ^^
  • 0

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


#2545 gia_bach

gia_bach

    biết lệnh adcenter

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

Đã gửi 23 June 2015 - 11:22 AM

Chào các anh chị,

Em có 4 điểm là 4 đỉnh của hình chữ nhật,em muốn tạo pline (gồm line và arc) qua 4 đỉnh của HCN,sao cho 2 cạnh ngắn của HCN là cung tròn ARC

Em làm (command "pline") thì được nhưng dùng entmake thì không biết tạo như thế nào...

Anh chị có thể code cho em 1 đoạn tham khảo được ko ạ

Em cảm ơn,

(entmake (list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")

.....
.....

)

 Do công ty không cho Up file nên mong mọi người thông cảm.

Tham khảo: 

(defun c:addRecArc(/ pt)
  (defun drawRecArc(pt delX delY / pt1 lst-pt lst-bul lst-w)
    (defun 3Dto2D(pt) (list (car pt) (cadr pt)))
    (setq pt1 (polar pt 0 delX)
	  lst-pt (list (3Dto2D pt) (3Dto2D pt1)
		       (3Dto2D (polar pt1 (/ pi 2) delY))
		       (3Dto2D (polar pt (/ pi 2) delY)) )
	  lst-bul (list 0 1 0 1) lst-w (list 0 0 0 0))
    (entmakex
	(apply
	  (function append)
	  (cons
	    (list
	      '(0 . "LWPOLYLINE")
	      '(100 . "AcDbEntity")
	      '(67 . 0)
	      '(100 . "AcDbPolyline")
	      (cons 90 (length lst-pt))
	      '(70 . 1)	      )
	    (mapcar
	      (function list)
	      (mapcar (function (lambda (a) (cons 10 a))) lst-pt)
;;;	      (mapcar (function (lambda (a) (cons 40 a))) lst-w)
;;;	      (mapcar (function (lambda (a) (cons 41 a))) lst-w)
	      (mapcar (function (lambda (a) (cons 42 a))) lst-bul) )  ) )) )
  (setq pt (getpoint "\nInsert point: "))
  (drawRecArc pt 1000 500))

  • 1

#2546 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

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

Đã gửi 23 June 2015 - 11:30 AM

@quocmanh04tt: thứ tự line và arc như nào?


  • 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.


#2547 quocmanh04tt

quocmanh04tt

    biết lệnh imageclip

  • Members
  • PipPipPipPipPipPipPip
  • 673 Bài viết
Điểm đánh giá: 313 (khá)

Đã gửi 23 June 2015 - 11:33 AM

Point nào thì bulge ấy. Đây là đoạn code vẽ thép đai mặt cắt em mới làm:
(defun c:vtd (/ bv r hdai wdai hdam pdv wdam pt0 pt1 pt10 pt11 pt12 pt2 pt3 pt4 pt5 pt6 pt7 pt8 pt9 ptg tan nad:mpline:bulges ra deg)
(defun ra (g) (/ (* g pi) 180))
(defun deg (so) (/ (* 180 so) pi))
(defun mpline:bulges (point-list bulge-list)
(entmake (apply (function append)
(cons (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(67 . 0)
'(410 . "Model")
(cons 43 0)
(if (tblsearch "LAYER" "THEP")
(cons 8 "THEP")
(cons 8 (getvar "Clayer")))
'(100 . "AcDbPolyline")
(cons 90 (length point-list))
'(70 . 0))
(mapcar (function list)
(mapcar (function (lambda (a) (cons 10 a))) point-list)
(mapcar (function (lambda ( B) (cons 42 B))) bulge-list))))))
(defun Polar3 (Pnt KC1 KC2 / P1) (setq P1 (list (+ (car Pnt) KC1) (+ (cadr Pnt) KC2))))
(defun tan (f) (/ (sin f) (cos f)))
(if (not tyle_ve_dai_dam-0)
(setq tyle_ve_dai_dam-0 5))
(setq tyle (getreal (strcat "\nTy le mat cat dam da ve <" (rtos tyle_ve_dai_dam-0) ">: ")))
(if (not tyle)
(setq tyle tyle_ve_dai_dam-0)
(setq tyle_ve_dai_dam-0 tyle))
(setq bv (* 20 tyle)
R (* 10 tyle))
(if (and (setq ptg (getpoint "\nDiem goc mc dam: ")) (setq pt0 (getcorner ptg "\nDiem goc doi dien: ")))
(progn (setq pdv (list (min (car ptg) (car pt0)) (min (cadr ptg) (cadr pt0))))
(setq wdai (- (- (car pt0) (car ptg)) (* 2 bv))
hdai (- (- (cadr pt0) (cadr ptg)) (* 2 bv))
wdam (abs (- (car pt0) (car ptg)))
hdam (abs (- (cadr pt0) (cadr ptg)))
pt10 (Polar3 pdv (- wdam (+ bv r)) bv)
pt2 (polar pt10 (* pi 0.875) (* 2 r (sin (/ pi 8))))
pt1 (polar pt2 (* pi 0.7) bv)
pt3 (Polar3 pt10 r r)
pt4 (Polar3 pt3 0 (- hdam (* (+ bv r) 2)))
pt5 (Polar3 pt4 (* r -1) r)
pt6 (Polar3 pt5 (* (- wdam (* (+ bv r) 2)) -1) 0)
pt7 (polar3 pt6 (* r -1) (* r -1))
pt8 (Polar3 pt7 0 (* (- hdam (* (+ bv r) 2)) -1))
pt9 (polar3 pt8 (* r 1) (* r -1))
pt11 (polar pt3 (* pi 0.625) (* 2 r (sin (/ pi 8))))
pt12 (polar pt11 (ra 144) bv))
(mpline:bulges (list pt1 pt2 pt3 pt4 pt5 pt6 pt7 pt8 pt9 pt10 pt11 pt12)
(list 0
(tan (* (/ pi 16) 3))
0
(tan (/ pi 8))
0
(tan (/ pi 8))
0
(tan (/ pi 8))
0
(tan (* (/ pi 16) 3))
0
0))))
(princ))

  • 0

#2548 Tr.CongSon

Tr.CongSon

    biết lệnh array

  • Members
  • PipPipPip
  • 183 Bài viết
Điểm đánh giá: 40 (tàm tạm)

Đã gửi 23 June 2015 - 02:37 PM

 

Tham khảo: 

(defun c:addRecArc(/ pt)
  (defun drawRecArc(pt delX delY / pt1 lst-pt lst-bul lst-w)
    (defun 3Dto2D(pt) (list (car pt) (cadr pt)))
    (setq pt1 (polar pt 0 delX)
	  lst-pt (list (3Dto2D pt) (3Dto2D pt1)
		       (3Dto2D (polar pt1 (/ pi 2) delY))
		       (3Dto2D (polar pt (/ pi 2) delY)) )
	  lst-bul (list 0 1 0 1) lst-w (list 0 0 0 0))
    (entmakex
	(apply
	  (function append)
	  (cons
	    (list
	      '(0 . "LWPOLYLINE")
	      '(100 . "AcDbEntity")
	      '(67 . 0)
	      '(100 . "AcDbPolyline")
	      (cons 90 (length lst-pt))
	      '(70 . 1)	      )
	    (mapcar
	      (function list)
	      (mapcar (function (lambda (a) (cons 10 a))) lst-pt)
;;;	      (mapcar (function (lambda (a) (cons 40 a))) lst-w)
;;;	      (mapcar (function (lambda (a) (cons 41 a))) lst-w)
	      (mapcar (function (lambda (a) (cons 42 a))) lst-bul) )  ) )) )
  (setq pt (getpoint "\nInsert point: "))
  (drawRecArc pt 1000 500))

Em cảm ơn,đúng ý em rồi ạ

Anh cho em hỏi :cái lst-w  trong code trên sao không sử dung  (hay mã 40,41 này không cần thiết) ,còn  mã dxf ( 42 . 1) là quy định cái đoạn pline là arc đúng ko ạ (nêu (42 . 0) là line ,???.Anh chỉ thêm mã dxf nào chỉnh cái đổ rộng của pline ko anh?

Cái này em tìm trong help mà không thấy ,.

Như vậy đoạn code em làm thế này cũng được a hì. (chưa chỉnh được width)

 

(entmake
(append
(list (cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 8 "2")

 (cons 90 4);;Length listpoint

(cons 70 1)
)
(mapcar '(lambda (p) (cons 10 p)) (list p1 p2))
(list (cons 42 1))
(mapcar '(lambda (p) (cons 10 p)) (list p3 p4))
(list (cons 42 1))
)
)


  • 0

#2549 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

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

Đã gửi 23 June 2015 - 02:45 PM

width: xem 40, 41 và 43. Help có.


  • 1

* 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.


#2550 gia_bach

gia_bach

    biết lệnh adcenter

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

Đã gửi 23 June 2015 - 03:11 PM

Em cảm ơn,đúng ý em rồi ạ

Anh cho em hỏi :cái lst-w  trong code trên sao không sử dung  (hay mã 40,41 này không cần thiết) ,còn  mã dxf ( 42 . 1) là quy định cái đoạn pline là arc đúng ko ạ (nêu (42 . 0) là line ,???.Anh chỉ thêm mã dxf nào chỉnh cái đổ rộng của pline ko anh?

Cái này em tìm trong help mà không thấy ,.

Như vậy đoạn code em làm thế này cũng được a hì. (chưa chỉnh được width)

 

 

DXF 42 còn gọi là Bulge như bài viết cùa QuocManh ....

DXF 40,41 qui định chiều rộng của Pline

Gửi lại Lisp có set chiều rông :

(defun c:addRecArc(/ pt)
  (defun drawRecArc(pt delX delY / pt1 lst-pt lst-bul lst-w)
    (defun 3Dto2D(pt) (list (car pt) (cadr pt)))
    (setq pt1 (polar pt 0 delX)
	  lst-pt (list (3Dto2D pt) (3Dto2D pt1)
		       (3Dto2D (polar pt1 (/ pi 2) delY))
		       (3Dto2D (polar pt (/ pi 2) delY)) )
	  lst-bul (list 0 1 0 1) lst-w (list 0 25 0 25))
    (entmakex
	(apply
	  (function append)
	  (cons
	    (list
	      '(0 . "LWPOLYLINE")
	      '(100 . "AcDbEntity")
	      '(67 . 0)
	      '(100 . "AcDbPolyline")
	      (cons 90 (length lst-pt))
	      '(70 . 1))
	    (mapcar
	      (function list)
	      (mapcar (function (lambda (a) (cons 10 a))) lst-pt)
	      (mapcar (function (lambda (a) (cons 40 a))) lst-w)
	      (mapcar (function (lambda (a) (cons 41 a))) (reverse lst-w))
	      (mapcar (function (lambda (a) (cons 42 a))) lst-bul) )  ) )) )
  (setq pt (getpoint "\nInsert point: "))
  (drawRecArc pt 1000 500))

  • 1

#2551 snowman.hms

snowman.hms

    biết vẽ ellipse

  • Members
  • PipPip
  • 55 Bài viết
Điểm đánh giá: 26 (tàm tạm)

Đã gửi 23 June 2015 - 05:40 PM

;;-----------------------=={ 3-Point Rectangle }==----------------------;;
;;                                                                      ;;
;;  This program enables the user to dynamically construct a rectangle  ;;
;;  defined by three supplied points.                                   ;;
;;                                                                      ;;
;;  The program offers two commands: '3PR' and '3PRD' which represent   ;;
;;  a standard & dynamic version of the program respectively.           ;;
;;                                                                      ;;
;;  Upon issuing either command at the AutoCAD command-line, the user   ;;
;;  is first prompted to specify two points defining one of the two     ;;
;;  pairs of parallel sides of the resulting rectangle.                 ;;
;;                                                                      ;;
;;  Following valid responses to these prompts, the user is then        ;;
;;  prompted for a third point to determine the length and direction    ;;
;;  of the second pair of edges, which are constructed perpendicular    ;;
;;  to the edges defined by the first two points.                       ;;
;;                                                                      ;;
;;  If the dynamic command is used ('3PRD') the program will display a  ;;
;;  real-time preview of the resulting rectangle whilst the user is     ;;
;;  prompted for the third point.                                       ;;
;;                                                                      ;;
;;  The user may exit the program at any time by pressing 'Enter' or    ;;
;;  right-clicking at any prompt.                                       ;;
;;                                                                      ;;
;;  Following valid specification of all three points, the program      ;;
;;  will proceed to construct the defined rectangle using an            ;;
;;  LWPolyline object.                                                  ;;
;;                                                                      ;;
;;  The dynamic version of the program utilises my GrSnap utility to    ;;
;;  enable full Object Snap functionality during the dynamic prompt.    ;;
;;  The latest version and full documentation for this application may  ;;
;;  be found at: http://www.lee-mac.com/grsnap.html                     ;;
;;                                                                      ;;
;;  Finally, this program has been designed to perform successfully     ;;
;;  under all UCS & View settings.                                      ;;
;;----------------------------------------------------------------------;;
;;  Author:  Lee Mac, Copyright © 2013  -  www.lee-mac.com              ;;
;;----------------------------------------------------------------------;;
;;  Version 1.0    -    2013-12-27                                      ;;
;;                                                                      ;;
;;  First release.                                                      ;;
;;----------------------------------------------------------------------;;

(defun c:3pr  nil (3p-rec nil)) ;; Standard version
(defun c:3prd nil (3p-rec  t )) ;; Dynamic version

;;----------------------------------------------------------------------;;

(defun 3p-rec ( dyn / *error* gr1 gr2 lst msg ocs osf osm pt1 pt2 pt3 pt4 pt5 pt6 str tmp vec )

    (defun *error* ( msg )
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (redraw) (princ)
    )
    
    (if
        (and
            (setq pt1 (getpoint "\nSpecify 1st point: "))
            (setq pt2 (getpoint "\nSpecify 2nd point: " pt1))
            (or   dyn (setq pt3 (getpoint "\nSpecify 3rd point: " pt1)))
            (setq vec (trans (mapcar '- pt2 pt1) 1 0 t)
                  ocs (trans '(0.0 0.0 1.0) 1 0 t)
                  pt4 (trans pt1 1 vec)
                  pt5 (trans pt2 1 vec)
            )
            (if dyn
                (progn
                    (setq osf (LM:grsnap:snapfunction)
                          osm (getvar 'osmode)
                          msg "\nSpecify 3rd point: "
                          str ""
                    )
                    (princ msg)
                    (while
                        (progn
                            (setq gr1 (grread t 15 0)
                                  gr2 (cadr gr1)
                                  gr1 (car  gr1)
                            )
                            (cond
                                (   (or (= 5 gr1) (= 3 gr1))
                                    (redraw)
                                    (osf gr2 osm)
                                    (setq pt6 (trans gr2 1 vec))
                                    (mapcar '(lambda ( a b ) (grdraw a b 1 1))
                                        (setq lst
                                            (list pt1 pt2
                                                (trans (list (car pt6) (cadr pt6) (caddr pt5)) vec 1)
                                                (trans (list (car pt6) (cadr pt6) (caddr pt4)) vec 1)
                                            )
                                        )
                                        (cons (last lst) lst)
                                    )
                                    (= 5 gr1)
                                )
                                (   (= 2 gr1)
                                    (cond
                                        (   (= 6 gr2)
                                            (if (zerop (logand 16384 (setq osm (setvar 'osmode (boole 6 16384 (getvar 'osmode))))))
                                                (princ "\n<Osnap on>")
                                                (princ "\n<Osnap off>")
                                            )
                                            (princ msg)
                                        )
                                        (   (= 8 gr2)
                                            (if (< 0 (strlen str))
                                                (progn
                                                    (princ "\010\040\010")
                                                    (setq str (substr str 1 (1- (strlen str))))
                                                )
                                            )
                                            t
                                        )
                                        (   (< 32 gr2 127)
                                            (setq str (strcat str (princ (chr gr2))))
                                        )
                                        (   (member gr2 '(13 32))
                                            (cond
                                                (   (= "" str) nil)
                                                (   (setq gr2 (LM:grsnap:parsepoint pt1 str))
                                                    (setq osm 16384)
                                                    nil
                                                )
                                                (   (setq tmp (LM:grsnap:snapmode str))
                                                    (setq osm tmp
                                                          str ""
                                                    )
                                                )
                                                (   (setq str "")
                                                    (princ (strcat "\n2D / 3D Point Required." msg))
                                                )
                                            )
                                        )
                                    )
                                )
                            )
                        )
                    )
                    (if (listp gr2)
                        (setq pt6 (trans (osf gr2 osm) 1 vec))
                    )
                )
                (setq pt6 (trans pt3 1 vec))
            )
        )
        (entmake
            (list
               '(000 . "LWPOLYLINE")
               '(100 . "AcDbEntity")
               '(100 . "AcDbPolyline")
               '(090 . 4)
               '(070 . 1)
                (cons 010 (trans pt1 1 ocs))
	        '(042 . 1)                                    ;;Added Bulge -by Snowman.hms
                (cons 010 (trans pt2 1 ocs))
                (cons 010 (trans (list (car pt6) (cadr pt6) (caddr pt5)) vec ocs))
	       '(042 . 1)                                     ;;Added Bulge -by Snowman.hms
                (cons 010 (trans (list (car pt6) (cadr pt6) (caddr pt4)) vec ocs))
                (cons 210 ocs)
            )
        )
    )
    (redraw) (princ)
)

;; Object Snap for grread: Snap Function  -  Lee Mac
;; Returns: [fun] A function requiring two arguments:
;; p - [lst] UCS Point to be snapped
;; o - [int] Object Snap bit code
;; The returned function returns either the snapped point (displaying an appropriate snap symbol)
;; or the supplied point if the snap failed for the given Object Snap bit code.

(defun LM:grsnap:snapfunction ( )
    (eval
        (list 'lambda '( p o / q )
            (list 'if '(zerop (logand 16384 o))
                (list 'if
                   '(setq q
                        (cdar
                            (vl-sort
                                (vl-remove-if 'null
                                    (mapcar
                                        (function
                                            (lambda ( a / b )
                                                (if (and (= (car a) (logand (car a) o)) (setq b (osnap p (cdr a))))
                                                    (list (distance p b) b (car a))
                                                )
                                            )
                                        )
                                       '(
                                            (0001 . "_end")
                                            (0002 . "_mid")
                                            (0004 . "_cen")
                                            (0008 . "_nod")
                                            (0016 . "_qua")
                                            (0032 . "_int")
                                            (0064 . "_ins")
                                            (0128 . "_per")
                                            (0256 . "_tan")
                                            (0512 . "_nea")
                                            (2048 . "_app")
                                            (8192 . "_par")
                                        )
                                    )
                                )
                               '(lambda ( a b ) (< (car a) (car b)))
                            )
                        )
                    )
                    (list 'LM:grsnap:displaysnap '(car q)
                        (list 'cdr
                            (list 'assoc '(cadr q)
                                (list 'quote
                                    (LM:grsnap:snapsymbols
                                        (atoi (cond ((getenv "AutoSnapSize")) ("5")))
                                    )
                                )
                            )
                        )
                        (LM:OLE->ACI
                            (if (= 1 (getvar 'cvport))
                                (atoi (cond ((getenv "Layout AutoSnap Color")) ("117761")))
                                (atoi (cond ((getenv  "Model AutoSnap Color")) ("104193")))
                            )
                        )
                    )
                )
            )
           '(cond ((car q)) (p))
        )
    )
)

;; Object Snap for grread: Display Snap  -  Lee Mac
;; pnt - [lst] UCS point at which to display the symbol
;; lst - [lst] grvecs vector list
;; col - [int] ACI colour for displayed symbol
;; Returns nil

(defun LM:grsnap:displaysnap ( pnt lst col / scl )
    (setq scl (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
          pnt (trans pnt 1 2)
    )
    (grvecs (cons col lst)
        (list
            (list scl 0.0 0.0 (car  pnt))
            (list 0.0 scl 0.0 (cadr pnt))
            (list 0.0 0.0 scl 0.0)
           '(0.0 0.0 0.0 1.0)
        )
    )
)

;; Object Snap for grread: Snap Symbols  -  Lee Mac
;; p - [int] Size of snap symbol in pixels
;; Returns: [lst] List of vector lists describing each Object Snap symbol

(defun LM:grsnap:snapsymbols ( p / -p -q -r a c i l q r )
    (setq -p (- p) q (1+  p)
          -q (- q) r (+ 2 p)
          -r (- r) i (/ pi 6.0)
           a 0.0
    )
    (repeat 12
        (setq l (cons (list (* r (cos a)) (* r (sin a))) l)
              a (- a i)
        )
    )
    (setq c (apply 'append (mapcar 'list (cons (last l) l) l)))
    (list
        (list 1
            (list -p -p) (list p -p) (list p -p) (list p p) (list p p) (list -p p) (list -p p) (list -p -p)
            (list -q -q) (list q -q) (list q -q) (list q q) (list q q) (list -q q) (list -q q) (list -q -q)
        )
        (list 2
            (list -r -q) (list 0  r) (list 0  r) (list r -q)
            (list -p -p) (list p -p) (list p -p) (list 0  p) (list 0  p) (list -p -p)
            (list -q -q) (list q -q) (list q -q) (list 0  q) (list 0  q) (list -q -q)
        )
        (cons 4 c)
        (vl-list* 8 (list -r -r) (list r r) (list r -r) (list -r r) c)
        (list 16
            (list p 0) (list 0 p) (list 0 p) (list -p 0) (list -p 0) (list 0 -p) (list 0 -p) (list p 0)
            (list q 0) (list 0 q) (list 0 q) (list -q 0) (list -q 0) (list 0 -q) (list 0 -q) (list q 0)
            (list r 0) (list 0 r) (list 0 r) (list -r 0) (list -r 0) (list 0 -r) (list 0 -r) (list r 0)
        )
        (list 32
            (list  r r) (list -r -r) (list  r q) (list -q -r) (list  q r) (list -r -q)
            (list -r r) (list  r -r) (list -q r) (list  r -q) (list -r q) (list  q -r)
        )
        (list 64
            '( 0  1) (list  0  p) (list  0  p) (list -p  p) (list -p  p) (list -p -1) (list -p -1) '( 0 -1)
            '( 0 -1) (list  0 -p) (list  0 -p) (list  p -p) (list  p -p) (list  p  1) (list  p  1) '( 0  1)
            '( 1  2) (list  1  q) (list  1  q) (list -q  q) (list -q  q) (list -q -2) (list -q -2) '(-1 -2)
            '(-1 -2) (list -1 -q) (list -1 -q) (list  q -q) (list  q -q) (list  q  2) (list  q  2) '( 1  2)
        )
        (list 128
            (list (1+ -p) 0) '(0 0) '(0 0) (list 0 (1+ -p))
            (list (1+ -p) 1) '(1 1) '(1 1) (list 1 (1+ -p))
            (list -p q) (list -p -p) (list -p -p) (list q -p)
            (list -q q) (list -q -q) (list -q -q) (list q -q)
        )
        (vl-list* 256 (list -r r)  (list r r) (list -r (1+ r)) (list r (1+ r)) c)
        (list 512
            (list -p -p) (list  p -p) (list -p  p) (list p p) (list -q -q) (list  q -q)
            (list  q -q) (list -q  q) (list -q  q) (list q q) (list  q  q) (list -q -q)
        )
        (list 2048
            (list   -p     -p) (list    p      p) (list   -p      p) (list    p     -p)
            (list (+ p 05) -p) (list (+ p 06) -p) (list (+ p 05) -q) (list (+ p 06) -q)
            (list (+ p 09) -p) (list (+ p 10) -p) (list (+ p 09) -q) (list (+ p 10) -q)
            (list (+ p 13) -p) (list (+ p 14) -p) (list (+ p 13) -q) (list (+ p 14) -q)
            (list -p -p) (list p -p) (list p -p) (list p p) (list p p) (list -p p) (list -p p) (list -p -p)
            (list -q -q) (list q -q) (list q -q) (list q q) (list q q) (list -q q) (list -q q) (list -q -q)
        )
        (list 8192 (list r 1) (list -r -q) (list r 0) (list -r -r) (list r q) (list -r -1) (list r r) (list -r 0))
    )
)

;; Object Snap for grread: Parse Point  -  Lee Mac
;; bpt - [lst] Basepoint for relative point input, e.g. @5,5
;; str - [str] String representing point input
;; Returns: [lst] Point represented by the given string, else nil

(defun LM:grsnap:parsepoint ( bpt str / str->lst lst )
 
    (defun str->lst ( str / pos )
        (if (setq pos (vl-string-position 44 str))
            (cons (substr str 1 pos) (str->lst (substr str (+ pos 2))))
            (list str)
        )
    )

    (if (wcmatch str "`@*")
        (setq str (substr str 2))
        (setq bpt '(0.0 0.0 0.0))
    )           

    (if
        (and
            (setq lst (mapcar 'distof (str->lst str)))
            (vl-every 'numberp lst)
            (< 1 (length lst) 4)
        )
        (mapcar '+ bpt lst)
    )
)

;; Object Snap for grread: Snap Mode  -  Lee Mac
;; str - [str] Object Snap modifier
;; Returns: [int] Object Snap bit code for the given modifier, else nil

(defun LM:grsnap:snapmode ( str )
    (vl-some
        (function
            (lambda ( x )
                (if (wcmatch (car x) (strcat (strcase str t) "*"))
                    (progn
                        (princ (cadr x)) (caddr x)
                    )
                )
            )
        )
       '(
            ("endpoint"      " of " 00001)
            ("midpoint"      " of " 00002)
            ("center"        " of " 00004)
            ("node"          " of " 00008)
            ("quadrant"      " of " 00016)
            ("intersection"  " of " 00032)
            ("insert"        " of " 00064)
            ("perpendicular" " to " 00128)
            ("tangent"       " to " 00256)
            ("nearest"       " to " 00512)
            ("appint"        " of " 02048)
            ("parallel"      " to " 08192)
            ("none"          ""     16384)
        )
    )
)

;; OLE -> ACI  -  Lee Mac
;; Args: c - [int] OLE Colour

(defun LM:OLE->ACI ( c )
    (apply 'LM:RGB->ACI (LM:OLE->RGB c))
)

;; OLE -> RGB  -  Lee Mac
;; Args: c - [int] OLE Colour

(defun LM:OLE->RGB ( c )
    (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
)

;; RGB -> ACI  -  Lee Mac
;; Args: r,g,b - [int] Red, Green, Blue values

(defun LM:RGB->ACI ( r g b / c o )
    (if (setq o (vla-getinterfaceobject (LM:acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
        (progn
            (setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
            (vlax-release-object o)
            (if (vl-catch-all-error-p c)
                (prompt (strcat "\nError: " (vl-catch-all-error-message c)))
                c
            )
        )
    )
)

;; Application Object  -  Lee Mac
;; Returns the VLA Application Object

(defun LM:acapp nil
    (eval (list 'defun 'LM:acapp 'nil (vlax-get-acad-object)))
    (LM:acapp)
)

;;----------------------------------------------------------------------;;

(vl-load-com)
(princ
    (strcat
        "\n:: 3P-Rec.lsp | Version 1.0 | \\U+00A9 Lee Mac "
        (menucmd "m=$(edtime,0,yyyy)")
        " www.lee-mac.com ::"
        "\n:: \"3PR\" - Standard | \"3PRD\" - Dynamic ::"
    )
)
(princ)

;;----------------------------------------------------------------------;;
;;                             End of File                              ;;
;;----------------------------------------------------------------------;;

Thay đổi chút xíu 3P-Rectangle của Lee Mac cho phù hợp với ý của bạn :)


  • 1

#2552 snowman.hms

snowman.hms

    biết vẽ ellipse

  • Members
  • PipPip
  • 55 Bài viết
Điểm đánh giá: 26 (tàm tạm)

Đã gửi 23 June 2015 - 06:36 PM

Chuyển rectangle sẵn có sang có arc segment (cạnh nhỏ sẽ chuyển thành arc) 

(defun c:xrec ( / s e i el bl d1 d2)
  
  (if (setq s (ssget '((0 . "LWPOLYLINE") (90 . 4) (-4 . "&=") (70 . 1))))
    (repeat (setq i (sslength s))
      (setq e  (ssname s (setq i (1- i))) el (entget e)
	    vl (_massoc 10 el)  e (vlax-ename->vla-object e))
      
      (if (Rectangle-p el)
	(progn
          (if (LM:Clockwise-p (car vl) (cadr vl) (caddr vl)) (setq bl '(-1 -1)) (setq bl '(1 1)))
	  (setq d1 (vlax-curve-getdistatparam e 1)
		d2 (- (vlax-curve-getdistatparam e 2) d1))
	  (if (<= d1 d2)
	    (mapcar '(lambda (i b) (vla-SetBulge e i b)) '(0 2) bl)
	    (mapcar '(lambda (i b) (vla-SetBulge e i b)) '(1 3) bl) 
	  )
	)
      )
    )
  )
  (princ)
)
;;==============================================================;;
(defun Rectangle-p (el / lst p1 p2 p3 p4)
  (and
    (= "LWPOLYLINE" (cdr (assoc 0 el)))
    (= 1 (cdr (assoc 70 el)))
    (setq lst (_massoc 10 el))
    (= 4 (length lst))
    (vl-every
      '(lambda (x) (zerop x))
      (_massoc 42 el)
    )
    (mapcar '(lambda (v p) (set v p)) '(p1 p2 p3 p4) lst)
    (equal 1 (/ (distance p1 p2) (distance p3 p4)) 1e-9)
    (equal 1 (/ (distance p1 p4) (distance p2 p3)) 1e-9)
    (equal 1 (/ (distance p1 p3) (distance p2 p4)) 1e-9)
  )
)
(defun _massoc (key lst)
  (if (setq itm (assoc key lst))
    (cons (cdr itm) (_massoc key (cdr (member itm lst))))
  )
)

;; Clockwise-p  -  Lee Mac
;; Returns T if p1,p2,p3 are clockwise oriented or collinear
                 
(defun LM:Clockwise-p ( p1 p2 p3 )
    (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
            (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
        )
        1e-8
    )
)

  • 1

#2553 Tr.CongSon

Tr.CongSon

    biết lệnh array

  • Members
  • PipPipPip
  • 183 Bài viết
Điểm đánh giá: 40 (tàm tạm)

Đã gửi 24 June 2015 - 08:27 AM

Thanks anh Gia-bach,a Hạ và a snowman.hms nhiều nhé

Lisp của a Gia_Bach đúng ý em rồi ạ! .(like nhiều vì dễ mót hơn của Snowman ^^) :P

Lisp của a Snowman.hms cao siêu quá,chắc mang về dùng thôi chứ đọc để hiểu ,để mót thì không nổi rồi ^^


  • 0

#2554 quocmanh04tt

quocmanh04tt

    biết lệnh imageclip

  • Members
  • PipPipPipPipPipPipPip
  • 673 Bài viết
Điểm đánh giá: 313 (khá)

Đã gửi 24 June 2015 - 02:11 PM

Lisp 2 cạnh ngắn của HCN luôn là nửa đường tròn, vào điểm giống như vẽ rectrang.

(defun c:cnb  (/ gc:clockwise-p mpline:bulges p1 p2 p3 p4 bul)
  (defun gc:clockwise-p (p1 p2 p3) (< (sin (- (angle p1 p3) (angle p1 p2))) -1e-14))
  (defun mpline:bulges  (point-list bulge-list)
    (entmake (apply (function append)
                    (cons (list '(0 . "LWPOLYLINE")
                                '(100 . "AcDbEntity")
                                '(67 . 0)
                                '(62 . 1)
                                '(100 . "AcDbPolyline")
                                (cons 90 (length point-list))
                                '(70 . 1)
                                (cons 43 0))
                          (mapcar (function list)
                                  (mapcar (function (lambda (a) (cons 10 a))) point-list)
                                  (mapcar (function (lambda ( B) (cons 42 B))) bulge-list))))))
  (if (and (setq p1 (getpoint "\nGoc thu nhat: ")) (setq p3 (getcorner p1 "\nGoc thu hai: ")))
    (progn (setq p2 (list (car p3) (cadr p1))
                 p4 (list (car p1) (cadr p3)))
           (if (gc:clockwise-p p1 p2 p3)
             (setq bul -1)
             (setq bul 1))
           (setq lstbul (if (< (distance p1 p2) (distance p2 p3))
                          (list bul 0 bul 0)
                          (list 0 bul 0 bul)))
           (mpline:bulges (list p1 p2 p3 p4) lstbul)))
  (princ))


  • 1

#2555 quocmanh04tt

quocmanh04tt

    biết lệnh imageclip

  • Members
  • PipPipPipPipPipPipPip
  • 673 Bài viết
Điểm đánh giá: 313 (khá)

Đã gửi 26 June 2015 - 02:20 PM

Các bác cho em hỏi, khi entmake Mleader thì làm sao để user Block (ở content) hiện hành ạ? Mtext thì ok, nhưng block thì phải vào lại mleaderstyle để chọn lại blk (kể cả block của CAD). Mong các bác chỉ giáo!


  • 0

#2556 nhoclangbac

nhoclangbac

    biết vẽ circle

  • Members
  • PipPip
  • 38 Bài viết
Điểm đánh giá: 3 (bình thường)

Đã gửi 26 June 2015 - 04:19 PM

Các bác cho em hỏi, khi entmake Mleader thì làm sao để user Block (ở content) hiện hành ạ? Mtext thì ok, nhưng block thì phải vào lại mleaderstyle để chọn lại blk (kể cả block của CAD). Mong các bác chỉ giáo!

Nhoc có sưu tầm lisp này, anh quocmanh04tt có mót ji thì mót nhé :P

(princ "\nDILEADER (DIL) v. 1.2 by Andrea Andreetti -Loaded-")
(defun c:DILEADER () (C:DIL)) (vl-load-com)
(defun c:DIL (/ Llead Ltext MainDLactive DQobject DragMess PointMethod ASPoint
DQLcursorPosition OKaccept Ltext Input DLactive DL_textsize VLAo DXItemHandle 
DQL_llpoint DQL_urpoint cen)
(setq DL_textsize (getvar "DIMTXT")) (setvar "CMDECHO" 0)
(while (not DQobject) (setq DQobject (nentsel "\nSelect Object...")))
(if DQobject (progn (princ "\nPick Text location...")
(DleaderWhile nil (vlax-ename->vla-object (car DQobject)) nil)
(while (and (/= (car input) 25)		;RIGHT CLICK
(/= (car input) 11) (/= (car input) 12) (/= (car input) 3)		;LEFT CLICK
(not (and (= (car input) 2) (= (cadr input) 32))) ;ESCAPE
(not (and (= (car input) 2) (= (cadr input) 13)))	) ;ENTER
(DleaderWhile nil (vlax-ename->vla-object (car DQobject)) nil)	)))
(princ "\nDleader Finish.") (princ))
;;DLEADER While Loop;;
(defun DleaderWhile (nnn VLAo Lleadprop	/ NewMod Ltext) 
;TEXTEname;VLAobject;LeaderPropreties
(vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-ACAD-Object)))
(setq DXItemHandle (vla-get-Handle VLAo)) (Setq DLactive T)
(while (and DLactive (setq input (grread t 4 4))
(or (= (car input) 5) (= (car input) 3))	) ;Cursor;PickPoint
(if (= (car input) 5) (setq DQLcursorPosition (cadr input)))
(if (and VLAo DQLcursorPosition)
(DLEADER_C&M_OBJECT DQLcursorPosition nnn VLAo cen Lleadprop)	)
(if (= (car input) 3) (progn (setq DLactive nil) (if (and Ltext (not nnn))
(command "._MTEDIT" (cdar (entmod (subst (cons 1 "") (assoc 1 (entget Ltext)) (entget Ltext)))))	)))) ;while
(if (and Ltext DXLeaderHandle DXItemHandle)
(DLEADERPUTXDATA Ltext "DLEADER_TEXT"
(vl-prin1-to-string (list DXLeaderHandle DXItemHandle))	))
(if (and NewMod DXLeaderHandle DXItemHandle)
(DLEADERPUTXDATA NewMod "DLEADER_TEXT"
(vl-prin1-to-string (list DXLeaderHandle DXItemHandle))	))
(vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-ACAD-Object)))
(setq DLactive nil)	)
;;DLEADER While Loop ;;DLEADER UPDATE for REACTOR
(defun Dleader_Updated_By_reactor (cursp cenpoint Lleadprop TXTobj)
(setq int (vlax-curve-getClosestPointTo VLAo cursp))
(setq DL_textsize (vla-get-Height (vlax-ename->vla-object TXTobj)))
(if (and int Lleadprop) (progn (if (> (car cursp) (car int))
(setq v71 1 co1 (list (- (car cursp) DL_textsize) (- (nth 1 cursp) (/ DL_textsize 2))
(nth 2 cursp)) co2 (list (- (car cursp) (/ DL_textsize 3)) (- (nth 1 cursp) (/ DL_textsize 2))
(nth 2 cursp)) LR 1)
(setq v71 3 co1 (list (+ (car cursp) DL_textsize) (- (nth 1 cursp) (/ DL_textsize 2)) 
(nth 2 cursp)) co2 (list (+ (car cursp) (/ DL_textsize 3)) (- (nth 1 cursp) (/ DL_textsize 2)) 
(nth 2 cursp)) LR 3)	)
(repeat 3 (setq Lleadprop (vl-remove (assoc 10 Lleadprop) Lleadprop)))
(setq Lleadprop (entmod (append Lleadprop (list (cons 10 int)) (list (cons 10 co1)) 
(list (cons 10 co2)) )))
(setq Llead (cdar (entmod (subst (cons 71 v71) (assoc 71 Lleadprop) Lleadprop))))
(setq TXTobjdata (entget TXTobj))
(setq Ltext (cdar (entmod (subst (cons 71 LR) (assoc 71 TXTobjdata) TXTobjdata))))
(setq DXLeaderHandle (cdr (assoc 5 (entget Llead)))) (setq int nil Lleadprop nil)	)))
;;DLEADER UPDATE for REACTOR;;DLEADER CREATE & MODIFY OBJECT
(defun DLEADER_C&M_OBJECT (cursp DLtext VLAo cenpoint Lleadprop / FicLine)
(setq int (vlax-curve-getClosestPointTo VLAo cursp))   
;;Create Mtext
(if Ltext (progn (command "._erase" Ltext "") (setq Ltext nil)))
(if (> (car cursp) (car int)) (setq v71 1
co1 (list (- (car cursp) DL_textsize) (- (nth 1 cursp) (/ DL_textsize 2))(nth 2 cursp))
co2 (list (- (car cursp) (/ DL_textsize 3)) (- (nth 1 cursp) (/ DL_textsize 2)) (nth 2 cursp)) )
(setq v71 3
co1 (list (+ (car cursp) DL_textsize) (- (nth 1 cursp) (/ DL_textsize 2)) (nth 2 cursp))
co2 (list (+ (car cursp) (/ DL_textsize 3)) (- (nth 1 cursp) (/ DL_textsize 2)) (nth 2 cursp)) ))  
(if (and int (not DLtext)) (progn
(setq Ltext (entmakex (list (cons 0 "MTEXT") (cons 100 "AcDbEntity")
(cons 100 "AcDbMText") (cons 1 "NOTE") (cons 10 cursp) (cons 40 DL_textsize)
(cons 50 0.0) (cons 71 v71) (cons 72 5))))	))
(if (and int DLtext) (progn
(setq NewMod (entmod(subst (cons 10 cursp)(assoc 10 DLtext) DLtext)))
(setq NewMod (cdar (entmod (subst (cons 71 v71)(assoc 71 NewMod) NewMod))))	))
;;Create Leader
(if (and int (not Lleadprop)) (progn
(if Llead (progn (command "._erase" Llead "") (setq Llead nil)))
(setq Llead (entmakex (list (cons 0 "LEADER") (cons 100 "AcDbEntity")
(cons 100 "AcDbLeader")	(cons 10 int) (cons 10 co1) (cons 10 co2))))
(vla-put-ArrowheadSize (vlax-ename->vla-object Llead) (getvar "DIMASZ"))
(setq DXLeaderHandle (cdr (assoc 5 (entget Llead))))	))  
(if (and int Lleadprop) (progn
(repeat 3 (setq Lleadprop (vl-remove (assoc 10 Lleadprop) Lleadprop)))
(setq Lleadprop (entmod (append Lleadprop (list (cons 10 int)) (list (cons 10 co1)) 
(list (cons 10 co2)) )))
(setq Llead (cdar (entmod (subst (cons 71 v71)(assoc 71 Lleadprop) Lleadprop))))
(setq DXLeaderHandle (cdr (assoc 5 (entget Llead))))	)) )
;;DLEADER CREATE & MODIFY OBJECT;;X D A T A;;
(defun DLEADERPUTXDATA (item xdataname tag / ent type1 valeur)
(setq ent (vlax-ename->vla-object item) type1 (vlax-make-safearray vlax-vbInteger 
(cons 0 1)) Valeur (vlax-make-safearray vlax-vbVariant (cons 0 1)))
(vlax-safearray-put-element type1 0 1001) 
(vlax-safearray-put-element valeur 0 xdataname)
(vlax-safearray-put-element type1 1 1000) (vlax-safearray-put-element valeur 1 tag)
(setq type1  (vlax-make-variant type1) valeur (vlax-make-variant valeur))
(vla-setxdata ent type1 valeur) )
;;X D A T A;;E D I T O R;;
(defun c:DILEDIT (/ sbs Llead Lleadprop vla-QDLitem LtextData valeur type1 Ltexti 
FLtext ent)
(setq sbs nil) (while (not sbs)
(setq Ltexti (nentsel "\nSelect TEXT Object..."))
(if Ltexti (progn (setq ent (vlax-ename->vla-object (setq FLtext (car Ltexti))))
(vla-getxdata ent "DLEADER_TEXT" 'type1 'valeur)
(if valeur (setq sbs (vlax-variant-value (nth 1 (vlax-safearray->list valeur)))))	)))
(if sbs (progn (setq DL_textsize (vla-get-Height (vlax-ename->vla-object FLtext)))
(setq LtextData (entget FLtext)) (setq Llead (handent (car (read sbs))))
(setq Lleadprop (entget Llead))
(setq vla-QDLitem (vlax-ename->vla-object (handent (cadr (read sbs)))))
(DleaderWhile (entget FLtext) vla-QDLitem Lleadprop)	)))
;R E A C T O R S
(defun Dleader_ObjectWasEdited (/ DLobj DLobj_data Llead)
(setq DLobj (cadr (ssgetfirst)))
(if DLobj (progn (setq DLobj (ssname DLobj 0)) (setvar "CMDECHO" 0)
(setq DLobj_data (entget DLobj)) (setq DLobj_5 (cdr (assoc 5 DLobj_data)))
(setq VLAo (vlax-ename->vla-object DLobj)) (if VLAo (progn
(vla-getboundingbox VLAo 'x 'y) (setq DQL_llpoint (vlax-safearray->list x))
(setq DQL_urpoint (vlax-safearray->list y))
(setq cen (polar DQL_llpoint (angle DQL_llpoint DQL_urpoint)
(/ (distance DQL_llpoint DQL_urpoint) 2)))
(setq cen (list (nth 0 cen) (nth 1 cen) (getvar "ELEVATION")))	))
(setq DLallText (ssget "X" '((0 . "MTEXT") (100 . "AcDbMText") (-3 ("DLEADER_TEXT") )))) (if DLallText (progn
(setq sscount (sslength DLallText)) (setq val1 (- sscount 1))
(repeat sscount (setq ent (vlax-ename->vla-object (ssname DLallText val1)))
(Setq cursp (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint ent))))
(vla-getxdata ent "DLEADER_TEXT" 'type1 'valeur)
(setq sbs (vlax-variant-value (nth 1 (vlax-safearray->list valeur))))
(setq Llead (handent (car (read sbs)))) (setq ObjHandle (cadr (read sbs)))
(if (and Llead (eq ObjHandle DLobj_5))
(Dleader_Updated_By_reactor cursp cen (entget Llead) (ssname DLallText val1))	)
(setq val1 (1- val1))	))))))
;;Reactor on ended MOVE
(defun *Dleader_object_Modification* (call-reactor scI /)
(if (member (car scI) (list "GRIP_MOVE" "GRIP_STRETCH" "GRIP_SCALE" 
"GRIP_ROTATE")) (Dleader_ObjectWasEdited)	)) ;;;;;
(defun DLEADER_run_reac ()
(if Dleader_object_Modification (progn (vlr-remove Dleader_object_Modification)
(setq Dleader_object_Modification nil)	))
(setq Dleader_object_Modification (vlr-command-reactor nil
'((:vlr-commandEnded . *Dleader_object_Modification*))	))) ;;;;;
(DLEADER_run_reac)


  • 1

#2557 quocmanh04tt

quocmanh04tt

    biết lệnh imageclip

  • Members
  • PipPipPipPipPipPipPip
  • 673 Bài viết
Điểm đánh giá: 313 (khá)

Đã gửi 26 June 2015 - 05:10 PM

Cám ơn nhoclangbac đã chia sẻ, có nhiều cái để mót, nhưng chưa có cái để giải quyết vấn đề theo nhu cầu đặt ra.


  • 0

#2558 ketxu

ketxu

    Copier - Paster - Editor

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

Đã gửi 26 June 2015 - 08:07 PM

Các bác cho em hỏi, khi entmake Mleader thì làm sao để user Block (ở content) hiện hành ạ? Mtext thì ok, nhưng block thì phải vào lại mleaderstyle để chọn lại blk (kể cả block của CAD). Mong các bác chỉ giáo!

 

Sao đọc mà k hiểu ý hỏi ta ....


  • 0

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


#2559 quocmanh04tt

quocmanh04tt

    biết lệnh imageclip

  • Members
  • PipPipPipPipPipPipPip
  • 673 Bài viết
Điểm đánh giá: 313 (khá)

Đã gửi 27 June 2015 - 04:52 PM

Sao đọc mà k hiểu ý hỏi ta ....

Xin lỗi bác, do em đặt câu hỏi chưa rõ ràng. Chính xác hơn Entmake MLEADERSTYLE (chứ không phải là mleader).
Đây là code:
(defun c:mld (/ createmultileader shtdata)
(defun createmultileader (data $stylename / dic obj)
(if (not (member $stylename
(foreach lstnfo (dictsearch (namedobjdict) "ACAD_MLEADERSTYLE")
(if (= 3 (car lstnfo))
(if (not newlst)
(setq newlst (list lstnfo))
(setq newlst (append (list lstnfo) newlst)))))))
(if (and (setq dic (dictsearch (namedobjdict) "ACAD_MLEADERSTYLE"))
(setq dic (cdr (assoc -1 dic)))
(setq obj (entmakex data)))
(progn (dictremove dic $stylename) (dictadd dic $stylename obj))))
(if (vl-catch-all-error-p (vl-catch-all-apply '(lambda () (vla-put-arrowsymbol $stylename "_Origin2"))))
(not (vl-catch-all-error-p
(vl-catch-all-apply '(lambda () (vla-put-arrowsymbol $stylename acarrowdefault)))))))
(setq shtdata (list (cons 0 "MLEADERSTYLE")
(cons 5 "362")
(cons 102 "{ACAD_REACTORS")
(cons 102 "}")
(cons 100 "AcDbMLeaderStyle")
(cons 179 2)
(cons 170 1)
(cons 171 1)
(cons 172 0)
(cons 90 2)
(cons 40 0.0)
(cons 41 3.14159)
(cons 173 1)
(cons 91 -1056964608)
(cons 92 -2)
(cons 290 1)
(cons 42 2.0)
(cons 291 1)
(cons 43 750.0)
(cons 3 "Standard")
(cons 44 100.0)
(cons 300 "")
(cons 174 5)
(cons 178 5)
(cons 175 1)
(cons 176 0)
(cons 93 -1073741824)
(cons 45 250.0)
(cons 292 0)
(cons 297 0)
(cons 46 4.0)
(cons 94 -1056964608)
(cons 47 0.75)
(cons 49 0.75)
(cons 140 0.75)
(cons 293 1)
(cons 141 0.0)
(cons 294 1)
(cons 177 0)
(cons 142 1.0)
(cons 295 0)
(cons 296 0)
(cons 143 10.0)
(cons 271 0)
(cons 272 9)
(cons 273 9)
(cons 298 1)))
(createmultileader shtdata "SHT")
(princ))

Nếu như này thì khi vẽ mleader cad sẽ hỏi block tên gì?
  • 0

#2560 ketxu

ketxu

    Copier - Paster - Editor

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

Đã gửi 27 June 2015 - 05:58 PM

Mình đang ở ngoài k có CAD để xem, n trong code của bạn chỗ nào chỉ định BlockObj ID ??


  • 0

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