Chuyển đến nội dung
Diễn đàn CADViet
  • Thông báo

    • Nguyen Hoanh

      CADViet đã hoàn tất nâng cấp   14/09/2017

      Chào các bạn, CADViet đã hoàn tất việc nâng cấp lên phiên bản mới. Tất cả các chức năng đã hoạt động theo kỳ vọng của ban quản trị. Nếu có vấn đề gì cần phản hồi, các bản post ở đây nhé: Trân trọng, Nguyễn Hoành.
Jin Yong

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

Các bài được khuyến nghị

Bee    108

Cá tính của tôi không bao giờ chơi khăm người khác, trừ khi nó nằm trong mục "đố vui".

Rất cám ơn Bee và Quocmanh04tt, nhưng tôi chịu, dù cả ngày nay cố gắng GG.

Cái này như quocmanh nói là gốc tọa độ block gốc là không trùng với 0. nên lisp tính toán sai. Em ít khi bị dính trường hợp này nên ko để ý. Mà có khi e còn không biết tạo cái block khác gốc tọa độ này ntn. ^_^

 

Cách sửa nếu chui vào BEDIT thì tất cả block đã chèn sẽ bị nhẩy sai hết. Vì vậy chỉ có cách là nổ block cũ và tạo 1 block mới với tọa độ chuẩn 0.. Sau đó thì lisp mới chèn ngược lại các block đã có trong bản vẽ. Đó là cách đơn giản nhất mà e nghĩ được.

 

Hi vọng ngóng được cách thay đổi tọa độ gốc trong block qua lisp của mọi người mà ko phải làm cách trên.

 

^_^

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
quocmanh04tt    385

@Bác Hạ: Thử dùng code này xem có được không??? (Dùng biện pháp nổ).

(defun c:tt (/ ble bln els i lst ss typ)

(if (setq ss (ssget '((0 . "INSERT"))))

(progn (repeat (setq i (sslength ss))

(setq ble (ssname ss (setq i (1- i)))

bln (cdr (assoc 2 (entget ble)))

lst nil)

(foreach e (mapcar 'vlax-vla-object->ename

(vlax-safearray->list (vlax-variant-value (vla-Explode (vlax-ename->vla-object ble)))))

(setq els (entget e)

typ (cdr (assoc 0 els)))

(cond ((= "LINE" typ)

(setq lst (cons (list typ (cdr (assoc 10 els)) (cdr (assoc 11 els))) lst)))

((= "LWPOLYLINE" typ)

(setq lst (cons (list typ (mapcar 'cdr (vl-remove-if-not '(lambda (x) (eq (car x) 10)) els))) lst)))

((member typ '("POINT" "TEXT")) (setq lst (cons (list typ (cdr (assoc 10 els))) lst))))

(entdel e))

(mapcar 'print (cons bln lst)))

(textscr)))

(princ))

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Doan Van Ha    2.676

Cám ơn chú. Bác đã chọn giải pháp nổ này từ hôm qua rồi, mặc dầu cái bụng không ưa tí nào, vì cảm thấy bất lực trước một vấn đề không quá khó (?).

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
quocmanh04tt    385

Nếu cái bụng của bác ưa code của Giles ở trên thì sửa hàm Blk2Coord như sau:

Thêm: (setq bsp (cdr (assoc 10 (entget (tblobjname "BLOCK" (cdr (assoc 2 (entget ref))))))))

*** Line sửa:

((= "LINE" typ)
           (setq lst (cons (list typ
                                 (mapcar '+ ins (mxv mat
(mapcar '(lambda (x y)(- x y)) (cdr (assoc 10 elst)) bsp)))
                                 (mapcar '+ ins (mxv mat (mapcar '(lambda (x y)(- x y)) (cdr (assoc 11 elst)) bsp))))
                           lst)))

*** LW:

((= "LWPOLYLINE" typ)
           (setq lst (cons (list typ
                                 (mapcar '(lambda (p) (mapcar '+ ins (mxv mat p)))
                                        
(mapcar '(lambda (pp) (mapcar '(lambda (x y) (- x y)) pp bsp))
                                                 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (eq (car x) 10)) elst)))))
                           lst)))

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Danh Cong    110

Các bác cũng cho em hỏi ngu tí ạ: Em muốn thay đổi giá trị hệ "Mét" hay "Milimeter" trong thiết lập Units thì biến hệ thống của nó là gì ạ . Em ko mò mẫm ko ra...

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
thanhduan2407    227

Chào các bác!

Em đang tập làm quen và muốn nắm bắt được phương thức sử dụng hàm Grread kết hợp hàm Grdraw để hiển thị cho trực quan mà đang loay hoay mãi.

Em đang viết chương trình nội suy từ 2 điểm đã biết tọa độ. Khi chọn xong 2 điểm có độ cao, khi di chuyển con chuột đến đâu thì hiển thị độ cao điểm nội suy đến đó. Khi Pick vào màn hình thì nó sẽ ghi Text và cho mình tiếp tục chọn điểm tiếp theo để Pick (lại tiếp tục di chuyển con chuột và hiển thị độ cao điểm nội suy). Thêm một phương thức nữa là có thể sử dụng được Osnap khi chọn điểm Pick (Em biết phần này không dễ dàng chút nào nhưng cứ mạn phép xin được chỉ giáo điều đó)

Em chỉ làm được đến phần Pick vào màn hình thì nó ghi kết quả nội suy độ cao chứ không cho chọn liên tiếp. Rất mong các bác chỉ giáo cho phương thức thực hiện với ạ! Em cảm ơn các bác nhiều!

(vl-load-com)
(defun c:00 (/ CAOCHU	CAODO1 CAODO2 CAODO3 CHIEUCAO ENAMET1 ENAMET2
	       PT1A PT2A PTGR PT_I SLE TDO1 TDO2 TEXT X1 X2 Y1 Y2
	      )
  (defun *error* (msg)
    (if	Olmode
      (setvar 'osmode Olmode)
    )
    (if	(not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
      (princ (strcat "\nError: " msg))
    )
    (princ)
  )
  (setq Olmode (getvar "OSMODE"))
  (setvar "OSMODE" 0)
  (_layer2 "TNS" 6)
  (setq sle 2)

  (if
    (and
      (setq EnameT1
	     (car
	       (entsel "\nCh\U+1ECDn Text th\U+1EE9 nh\U+1EA5t: ")
	     )
      )
      (setq EnameT2 (car (entsel "\nCh\U+1ECDn Text th\U+1EE9 hai ")))
    )
     (progn
       (setq Tdo1 (TD:Text-Base EnameT1))
       (setq Caodo1 (cdr (assoc 1 (entget EnameT1))))
       (setq x1 (car Tdo1))
       (setq y1 (cadr Tdo1))
       (setq Caochu (cdr (assoc 40 (entget EnameT1))))
       (setq Pt1A (list x1 y1 (atof Caodo1)))

       (setq Tdo2 (TD:Text-Base EnameT2))
       (setq Caodo2 (cdr (assoc 1 (entget EnameT2))))
       (setq x2 (car Tdo2))
       (setq y2 (cadr Tdo2))
       (setq Pt2A (list x2 y2 (atof Caodo2)))
       (prompt "\nV\U+1ECB tr\U+00ED ch\U+00E8n : ")
       (setvar "OSMODE" 0)
       (while (member (car (setq ptgr (grread 't 5 0))) '(5 2))
	 (if text
	   (progn
	     (setq PntPick (trans (cadr ptgr) 1 0))
	     (if (= (CheckPntbetween2Pnt
		      Pt1A
		      Pt2A
		      PntPick
		    )
		    1
		 )
	       (setq Caodo3
		      (NSG2D Pt1A Pt2A PntPick)
	       )
	       (setq Caodo3
		      (NSN2D Pt1A Pt2A PntPick)
	       )
	     )
	     (vlax-put text
		       'InsertionPoint
		       (mapcar '+ PntPick '(0.1 0.1 0.0))
	     )
	     (vlax-put
	       text
	       'TextString
	       (rtos Caodo3 2 3)
	     )
	     (redraw)
	     (grdraw Pt1A PntPick 7 1)
	     (grdraw Pt2A PntPick 7 1)
	   )
	   (setq text (vlax-ename->vla-object
			(MakeText Pt2A
				  (rtos (caddr Pt2A) 2 3)
				  Caochu
				  0
				  "L"
				  "TNS"
				  nil
				  nil
			)
		      )
	   )
	 )
       )
     )
  )
  (redraw)
  (setvar "OSMODE" Olmode)
  (princ)
)

(defun NSG2D (P1 P2 P / D D1 D2 DH DHZ PT1 PT2 PT3 Z1 Z2 Z3);;;;NOI SUY GIUA 2 DIEM
  (setq pt1 (TachXY P1))
  (setq pt2 (TachXY P2))
  (setq pt3 (TachXY P))
  (setq Z1 (caddr P1))
  (setq Z2 (caddr P2))
  (setq d1 (distance pt1 pt3))
  (setq d2 (distance pt2 pt3))
  (setq d (+ d1 d2))
  (setq dh (- Z2 Z1))
  (setq dhz (* dh (/ d1 d)))
  (setq Z3 (+ Z1 dhz))
  Z3
)




(defun NSN2D (P1 P2 P /	D13 D23	DELTAZ12 DELTAZ13 KC12 KC13 KC23 PT1
	      PT2 PT3 Z3
	     ) ;;;;NOI SUY NGOAI 2 DIEM
  (setq d13 (distance (TachXY P1) (TachXY P)))
  (setq d23 (distance (TachXY P2) (TachXY P)))
  (if (< d13 d23)
    (progn
      (setq pt1 P1)
      (setq pt2 P2)
      (setq pt3 P)
    )
    (progn
      (setq pt1 P2)
      (setq pt2 P1)
      (setq pt3 P)
    )
  )
  (setq KC12 (distance (TachXY Pt1) (TachXY Pt2)))
  (setq KC13 (distance (TachXY Pt1) (TachXY Pt3)))
  (setq KC23 (distance (TachXY Pt2) (TachXY Pt3)))
  (setq DeltaZ12 (- (caddr Pt1) (caddr Pt2)))
  (setq DeltaZ13 (/ (* KC13 DeltaZ12) KC12))
  (setq Z3 (+ (caddr Pt1) DeltaZ13))
  Z3
)





(defun TachXY (Pnt /)
  (setq Pt (list (car Pnt) (cadr Pnt)))
  pt
)





;;;;LAY TOA DO TEXT
(defun TD:Text-Base (ent / MA71 MA72 X11)
  (setq Ma10 (cdr (assoc 10 (entget ent))))
  (setq Ma11 (cdr (assoc 11 (entget ent))))
  (setq X11 (car Ma11))
  (setq Ma71 (cdr (assoc 71 (entget ent))))
  (setq Ma72 (cdr (assoc 72 (entget ent))))
  (if (or (and (= Ma71 0) (= Ma72 0) (= X11 0))
	  (and (= Ma71 0) (= Ma72 3))
	  (and (= Ma71 0) (= Ma72 5))
      )
    Ma10
    Ma11
  )
)

(defun _layer2 (name colour)
  (if (null (tblsearch "LAYER" name))
    (entmake
      (list
	'(0 . "LAYER")
	'(100 . "AcDbSymbolTableRecord")
	'(100 . "AcDbLayerTableRecord")
	'(70 . 0)
	(cons 2 name)
	(cons 62 colour)
      )
    )
  )
)


(defun MakeText
       (point string Height Ang justify Layer Style Color / Lst)
 ; Ang: Radial
  (setq	Lst	(list '(0 . "TEXT")
		      (cons 10 point)
		      (cons 40 Height)
		      (cons 8
			    (if	Layer
			      Layer
			      (getvar "CLAYER")
			    )
		      )
		      (cons 1 string)
		      (if Ang
			(cons 50 Ang)
		      )
		      (cons 7
			    (if	Style
			      Style
			      (getvar "Textstyle")
			    )
		      )
		      (cons 62
			    (if	Color
			      Color
			      256
			    )
		      )
		)
	justify	(strcase justify)
  )
  (cond
    ((= justify "C")
     (setq Lst (append Lst (list (cons 72 1) (cons 11 point))))
    )
    ((= justify "L")
     (setq
       Lst
	(append Lst (list (cons 72 0) (cons 73 0) (cons 10 point)))
     )
    )
    ((= justify "R")
     (setq Lst (append Lst (list (cons 72 2) (cons 11 point))))
    )
    ((= justify "M")
     (setq Lst (append Lst (list (cons 72 4) (cons 11 point))))
    )
    ((= justify "TL")
     (setq
       Lst
	(append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))
     )
    )
    ((= justify "TC")
     (setq
       Lst
	(append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))
     )
    )
    ((= justify "TR")
     (setq
       Lst
	(append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))
     )
    )
    ((= justify "ML")
     (setq
       Lst
	(append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))
     )
    )
    ((= justify "MC")
     (setq
       Lst
	(append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))
     )
    )
    ((= justify "MR")
     (setq
       Lst
	(append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))
     )
    )
    ((= justify "BL")
     (setq
       Lst
	(append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))
     )
    )
    ((= justify "BC")
     (setq
       Lst
	(append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))
     )
    )
    ((= justify "BR")
     (setq
       Lst
	(append Lst (list (cons 72 2) (cons 11 point) (cons 73 1)))
     )
    )
  )
  (entmakex Lst)
)


;;;;KIEM TRA DIEM NAM GIUA 2 DIEM
(defun CheckPntbetween2Pnt
       (P1 P2 P / KC1 KC12 KC2 OBJL_NEW P1A P2A PT VLALINE)
  (setq P1a (TachXY P1))
  (setq P2a (TachXY P2))
  (setq ObjL_New (MakeLine P1a P2a nil nil nil nil nil))
  (setq VlaLine (vlax-ename->vla-object ObjL_New))
  (setq Pt (vlax-curve-getClosestPointTo VlaLine P T))
  (setq KC1 (distance P1a Pt))
  (setq KC2 (distance P2a Pt))
  (setq KC12 (distance P1a P2a))
  (entdel ObjL_New)
  (if (equal (+ KC1 KC2) KC12 0.001)
    (setq KQ 1)
    (setq KQ 2)
  )
  KQ
)

(defun MakeLine	(PT1 PT2 Linetype LTScale Layer Color xdata)
  (entmakex (list '(0 . "LINE")
		  (cons	8
			(if Layer
			  Layer
			  (getvar "Clayer")
			)
		  )
		  (cons	6
			(if Linetype
			  Linetype
			  "bylayer"
			)
		  )
		  (cons	48
			(if LTScale
			  LTScale
			  1
			)
		  )
		  (cons	62
			(if Color
			  Color
			  256
			)
		  )
		  (cons 10 PT1)
		  (cons 11 PT2)
		  (cons	-3
			(if xdata
			  (list xdata)
			  nil
			)
		  )
	    )
  )
)




http://www.mediafire.com/file/c7bxd0xwwi35agh/NOI+SUY+DIEM+DO+CAO.LSP

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
thanhduan2407    227

Xem và nghiên cứu bài này: http://www.cadviet.com/forum/topic/68466-da-xong-lisp-su-dung-osnap-khi-dang-dung-ham-grread/

Đơn giản thì bài của bác Hạ, nhiều hơn nữa thì bài của KangKung.

Cảm ơn bác Quocmanh04tt!

Em cũng đã nghiên cứu rồi nhưng  vẫn chưa nắm được phương thức. Chắc nó nằm ở chỗ kiểm soát vòng lặp.

Em muốn kết thúc bằng phím Enter hoặc chuột phải.

Có lẽ em cần thời gian mò thêm, rất mong dc các bác chỉ giáo.

Cảm ơn bác Quocmanh04tt nhiều!

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
quocmanh04tt    385

1. Trước hết tìm hiểu về hàm Grread: (nó đọc giá trị từ thiết bị nhập vào (chuột, bàn phím...)
Kết quả trả về là 1 danh sách:
* Đối với chuột: (code point)
- Khi rê chuột: (5 pt) => pt là điểm.
- Khi nhấn phím trái chuột: (3 pt)
- Khi nhấn phím phải: (25 code)
- Pick chọn vào các menu, button... ra nhiều kết quả khác (có code để test ở dưới).
* Đối với bàn phím: (2 key) => trong đó key là mã ký tự bàn phím.
* Shift + Phím phải chuột: => '(11 1000)
* Thiết bị khác chưa dùng nên chưa biết (ví dụ bảng vẽ...)
2. Phân tích vòng lặp của bạn:
- Vòng while chỉ tiếp tục khi phần tử đầu của danh sách trả về là 5 hoặc 2 (tức là khi rê chuột và nhấn bàn phím)
- Khi nhấn phím trái (pick point) khi đó (car ptgr) = 3
- Khi gõ ký tự từ bàn phím: (car ptgr) = 2, (cadr ptgr) sẽ là mã ký tự chứ không phải point => Lỗi.
3. Đoạn code sửa lại vòng lặp (Phím phải hoặc Enter đều kết thúc lệnh)
*** Bổ sung thêm nhập từ bàn phím:
- Phím h, hoặc H: Chiều cao chữ sẽ tăng 1.05 lần...
- Phím s, hoặc S: Chiều cao chữ sẽ giảm 0.95 lần...

;; Them
(setq tmp t)
(setq text (vlax-ename->vla-object (MakeText Pt2A (rtos (caddr Pt2A) 2 3) Caochu 0 "L" "TNS" nil nil)))
;; Sua
(while (and tmp (setq ptgr (grread 't 12 0)))
(cond ;; Re chuot - Dragging
((eq (car ptgr) 5)
(setq PntPick (trans (cadr ptgr) 1 0))
(if text
(progn (if (= (CheckPntbetween2Pnt Pt1A Pt2A PntPick) 1)
(setq Caodo3 (NSG2D Pt1A Pt2A PntPick))
(setq Caodo3 (NSN2D Pt1A Pt2A PntPick)))
(vlax-put text 'InsertionPoint (mapcar '+ PntPick '(0.1 0.1 0.0)))
(vlax-put text 'TextString (rtos Caodo3 2 3))
(redraw)
(grdraw Pt1A PntPick 7 1)
(grdraw Pt2A PntPick 7 1))
(setq text (vlax-ename->vla-object
(MakeText PntPick (rtos (caddr Pt2A) 2 3) Caochu 0 "L" "TNS" nil nil)))))
;; Tang chieu cao chu: Nhan Phim H=72;h=104
((or (equal ptgr '(2 72)) (equal ptgr '(2 104)))
(setq Caochu (* Caochu 1.05))
(vlax-put text 'Height caochu))
;; Giam chieu cao chu: Nhan Phim S=72;s=104
((or (equal ptgr '(2 83)) (equal ptgr '(2 115)))
(setq Caochu (* Caochu 0.95))
(vlax-put text 'Height caochu))
;; Phim trai chuot - Picked point
((eq (car ptgr) 3) (setq text nil) (redraw))
;; Phim phai chuot hoac Enter - Right click or Enter
((or (eq (car ptgr) 25) (equal ptgr '(2 13))) (setq tmp nil) (and text (vla-delete text)))))

4. Còn đây là code để test grread:
- Sau khi gọi lệnh => rê chuột, phím trái, phím phải để xem kết quả dưới dòng command.
- Thả chuột, gõ ký tự từ bàn phím và xem kết quả.
(defun c:tt (/ grr tmp)
;; Test Grread - QuocManh04tt.
(setq tmp t)
(while (and tmp (setq grr (grread 't 15 0)))
(cond ((eq (car grr) 5) (princ "\nDI CHUOT, KET QUA grread: ") (princ grr))
((eq (car grr) 3) (princ "\nPHIM TRAI CHUOT, KET QUA grread: ") (princ grr))
((eq (car grr) 25) (princ "\nPHIM PHAI CHUOT, KET QUA grread: ") (princ grr))
((equal grr '(11 1000)) (princ "\nShift+Phim phai chuot, KET QUA grread: ") (princ grr))
((eq (car grr) 2)
(princ (strcat "\nBAN DA NHAN PHIM ["
(cond ((eq (cadr grr) 6) "F3")
((eq (cadr grr) 25) "F4")
((eq (cadr grr) 5) "F5")
((eq (cadr grr) 4) "F6")
((eq (cadr grr) 7) "F7")
((eq (cadr grr) 15) "F8")
((eq (cadr grr) 2) "F9")
((eq (cadr grr) 21) "F10")
((eq (cadr grr) 151) "F11")
((eq (cadr grr) 31) "F12")
((eq (cadr grr) 9) "Tab")
((eq (cadr grr) 8) "Back")
((eq (cadr grr) 32) "Space")
((eq (cadr grr) 13) "Enter")
(t (chr (cadr grr))))
"] KET QUA grread: "))
(princ grr))
(t (princ "\n") (princ grr))))
(princ))
  • Vote tăng 2

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
thanhduan2407    227

1. Trước hết tìm hiểu về hàm Grread: (nó đọc giá trị từ thiết bị nhập vào (chuột, bàn phím...)

Kết quả trả về là 1 danh sách:

* Đối với chuột: (code point)

- Khi rê chuột: (5 pt) => pt là điểm.

- Khi nhấn phím trái chuột: (3 pt)

- Khi nhấn phím phải: (25 code)

- Pick chọn vào các menu, button... ra nhiều kết quả khác (có code để test ở dưới).

* Đối với bàn phím: (2 key) => trong đó key là mã ký tự bàn phím.

* Shift + Phím phải chuột: => '(11 1000)

* Thiết bị khác chưa dùng nên chưa biết (ví dụ bảng vẽ...)

2. Phân tích vòng lặp của bạn:

- Vòng while chỉ tiếp tục khi phần tử đầu của danh sách trả về là 5 hoặc 2 (tức là khi rê chuột và nhấn bàn phím)

- Khi nhấn phím trái (pick point) khi đó (car ptgr) = 3

- Khi gõ ký tự từ bàn phím: (car ptgr) = 2, (cadr ptgr) sẽ là mã ký tự chứ không phải point => Lỗi.

3. Đoạn code sửa lại vòng lặp (Phím phải hoặc Enter đều kết thúc lệnh)

*** Bổ sung thêm nhập từ bàn phím:

- Phím h, hoặc H: Chiều cao chữ sẽ tăng 1.05 lần...

- Phím s, hoặc S: Chiều cao chữ sẽ giảm 0.95 lần...

;; Them

(setq tmp t)

(setq text (vlax-ename->vla-object (MakeText Pt2A (rtos (caddr Pt2A) 2 3) Caochu 0 "L" "TNS" nil nil)))

;; Sua

(while (and tmp (setq ptgr (grread 't 12 0)))

(cond ;; Re chuot - Dragging

((eq (car ptgr) 5)

(setq PntPick (trans (cadr ptgr) 1 0))

(if text

(progn (if (= (CheckPntbetween2Pnt Pt1A Pt2A PntPick) 1)

(setq Caodo3 (NSG2D Pt1A Pt2A PntPick))

(setq Caodo3 (NSN2D Pt1A Pt2A PntPick)))

(vlax-put text 'InsertionPoint (mapcar '+ PntPick '(0.1 0.1 0.0)))

(vlax-put text 'TextString (rtos Caodo3 2 3))

(redraw)

(grdraw Pt1A PntPick 7 1)

(grdraw Pt2A PntPick 7 1))

(setq text (vlax-ename->vla-object

(MakeText PntPick (rtos (caddr Pt2A) 2 3) Caochu 0 "L" "TNS" nil nil)))))

;; Tang chieu cao chu: Nhan Phim H=72;h=104

((or (equal ptgr '(2 72)) (equal ptgr '(2 104)))

(setq Caochu (* Caochu 1.05))

(vlax-put text 'Height caochu))

;; Giam chieu cao chu: Nhan Phim S=72;s=104

((or (equal ptgr '(2 83)) (equal ptgr '(2 115)))

(setq Caochu (* Caochu 0.95))

(vlax-put text 'Height caochu))

;; Phim trai chuot - Picked point

((eq (car ptgr) 3) (setq text nil) (redraw))

;; Phim phai chuot hoac Enter - Right click or Enter

((or (eq (car ptgr) 25) (equal ptgr '(2 13))) (setq tmp nil) (and text (vla-delete text)))))

4. Còn đây là code để test grread:

- Sau khi gọi lệnh => rê chuột, phím trái, phím phải để xem kết quả dưới dòng command.

- Thả chuột, gõ ký tự từ bàn phím và xem kết quả.

(defun c:tt (/ grr tmp)

;; Test Grread - QuocManh04tt.

(setq tmp t)

(while (and tmp (setq grr (grread 't 15 0)))

(cond ((eq (car grr) 5) (princ "\nDI CHUOT, KET QUA grread: ") (princ grr))

((eq (car grr) 3) (princ "\nPHIM TRAI CHUOT, KET QUA grread: ") (princ grr))

((eq (car grr) 25) (princ "\nPHIM PHAI CHUOT, KET QUA grread: ") (princ grr))

((equal grr '(11 1000)) (princ "\nShift+Phim phai chuot, KET QUA grread: ") (princ grr))

((eq (car grr) 2)

(princ (strcat "\nBAN DA NHAN PHIM ["

(cond ((eq (cadr grr) 6) "F3")

((eq (cadr grr) 25) "F4")

((eq (cadr grr) 5) "F5")

((eq (cadr grr) 4) "F6")

((eq (cadr grr) 7) "F7")

((eq (cadr grr) 15) "F8")

((eq (cadr grr) 2) "F9")

((eq (cadr grr) 21) "F10")

((eq (cadr grr) 151) "F11")

((eq (cadr grr) 31) "F12")

((eq (cadr grr) 9) "Tab")

((eq (cadr grr) 8) "Back")

((eq (cadr grr) 32) "Space")

((eq (cadr grr) 13) "Enter")

(t (chr (cadr grr))))

"] KET QUA grread: "))

(princ grr))

(t (princ "\n") (princ grr))))

(princ))

Không biết gì nói lời cảm ơn bác Quocmanh04tt!

Lần nào cũng được bác tư vấn và cho lời giải thật tuyệt.

Lần trước em hay được bác Doan Van Ha giúp và bác ấy cũng rất tuyệt. Nhiệt tình và tài giỏi. Em cũng đang mò mẫm từng bước một thôi.

Cũng nhân tiện đây, bác Quocmanh có thêm được cái bắt điểm nữa không ạ?

Nếu nó không dễ thì thôi ạ! Em dùng cái này cũng rất tuyệt vời rồi.

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
quocmanh04tt    385

Không biết gì nói lời cảm ơn bác Quocmanh04tt!

Lần nào cũng được bác tư vấn và cho lời giải thật tuyệt.

Lần trước em hay được bác Doan Van Ha giúp và bác ấy cũng rất tuyệt. Nhiệt tình và tài giỏi. Em cũng đang mò mẫm từng bước một thôi.

Cũng nhân tiện đây, bác Quocmanh có thêm được cái bắt điểm nữa không ạ?

Nếu nó không dễ thì thôi ạ! Em dùng cái này cũng rất tuyệt vời rồi.

- Cái Osnap cứ dựa vào bài của KangKung dễ thôi mà! Cứ chép mấy cái hàm con phục vụ osnap vào trong lisp (Viết mấy hàm con này mới khó, chứ chép vào thì có gì mà dễ với khó...???)

- Tạm hiểu thế này: khi mình di chuột đến đâu thì thì có cái hàm con nó từ tìm các điểm (theo chế độ OSNAP đã bật), sau đó mình thay điểm trả về của thao tác di chuột bằng điểm OSNAP tìm được -> OK.

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
thanhduan2407    227

 

Các bác cho em hỏi 1 xíu ạ!

Em muốn xuất tọa độ Mtext (nếu nó có các kiểu căn chỉnh) mà vẫn lấy dc tọa độ chuẩn của nó thì như nào nhỉ? Em dùng:
(vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint (vlax-ename->vla-object (car (entsel))))))
Nhưng nó ko đúng. Toàn bắt điểm góc trái trên.
(Thường thì MText khi phá khối (Explode) thì nó thành DText, nó phải cùng 1 điểm chèn phải ko ạ?)
Mong các bác chỉ giáo em với! Em cảm ơn.

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Danh Cong    110

Help chắc có thể giúp được gì cho anh :)

...............InsertionPoint

Variant (three-element array of doubles); read-write

A 3D WCS coordinate representing the insertion point. 

 

Remarks 

 

MText: Specifies the location for a corner of the text boundary. Use the AttachmentPoint property to specify which corner of the text boundary is to be positioned at this insertion point. 

 

Text: This property is read-only except for text whose Alignment property is set to acAlignmentLeft, acAlignmentAligned, or acAlignmentFit. To position text whose justification is other than left, aligned, or fit, use the TextAlignmentPoint property. 

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
thanhduan2407    227

Help chắc giúp được gì cho anh :)

 

...............InsertionPoint

 

Variant (three-element array of doubles); read-write

A 3D WCS coordinate representing the insertion point. 

 

Remarks 

 

MText: Specifies the location for a corner of the text boundary. Use the AttachmentPoint property to specify which corner of the text boundary is to be positioned at this insertion point. 

 

Text: This property is read-only except for text whose Alignment property is set to acAlignmentLeft, acAlignmentAligned, or acAlignmentFit. To position text whose justification is other than left, aligned, or fit, use the TextAlignmentPoint property. 

Cảm ơn Danh Công!

Vừa nói hỏi Ketxu thì được biết: Điểm chèn MText khi phá vỡ (Explode) thành DText sẽ khác nhau.  Phải rút kinh nghiệm vấn đề này.

P/s: Thì nào mình xuất các kiểu vẫn chỉ là 1 vị trí. ^^

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
cuongtk2    40

Cái này như quocmanh nói là gốc tọa độ block gốc là không trùng với 0. nên lisp tính toán sai. Em ít khi bị dính trường hợp này nên ko để ý. Mà có khi e còn không biết tạo cái block khác gốc tọa độ này ntn. ^_^

 

Cách sửa nếu chui vào BEDIT thì tất cả block đã chèn sẽ bị nhẩy sai hết. Vì vậy chỉ có cách là nổ block cũ và tạo 1 block mới với tọa độ chuẩn 0.. Sau đó thì lisp mới chèn ngược lại các block đã có trong bản vẽ. Đó là cách đơn giản nhất mà e nghĩ được.

 

Hi vọng ngóng được cách thay đổi tọa độ gốc trong block qua lisp của mọi người mà ko phải làm cách trên.

 

^_^

Nếu tạo block mà không pick point thì mặc định tạo block có điểm chèn là 0,0,0. Khi dùng pick point thì đỉnh sẽ so sánh với điểm pick vì điểm này sẽ là gốc tọa độ của block.

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
thanhduan2407    227

Chào các bác!

Em mày mò và vọc được 1 lisp của Lee_Mac về việc đồng bộ hóa bán kính đường tròn trong nhóm đường tròn được lựa chọn.

Tuy nhiên, với số lượng ít thì chương trình có thể chạy được (em Test thử với 170 đường tròn thì OK) nhưng khi con số lớn hơn 1 chút (VD: 300 đường tròn) thì Cad đơ và thoát. Rất mong được các bác chỉ giáo để gỡ rối ạ!

Em cảm ơn!

(defun c:radlink (/ idx lst sel)
  (foreach rtr (cdar (vlr-reactors :vlr-object-reactor))
    (if	(= "radlink" (vlr-data rtr))
      (vlr-remove rtr)
    )
  )
  
  (if (setq sel (ssget "_:L" '((0 . "CIRCLE"))))
    (progn
      (repeat (setq idx (sslength sel))
	(setq lst (cons	(vlax-ename->vla-object
			  (ssname sel (setq idx (1- idx)))
			)
			lst
		  )
	)
      )
      (radlink-callback
	(car lst)
	(vlr-object-reactor
	  lst
	  "radlink"
	  '((:vlr-modified . radlink-callback))
	)
	nil
      )
    )
  )
  (princ)
)
(defun radlink-updateradius (obj rad)
    (if	(and (vlax-read-enabled-p obj)
	     (not (equal (vla-get-radius obj) rad 1e-8))
	     (vlax-write-enabled-p obj)
	)
      (vla-put-radius obj rad)
    )
  )
(defun radlink-callback	(own rtr arg / rad)
  
  (if (and (vlax-read-enabled-p own) (setq rad (vla-get-radius own)))
    (foreach obj (vlr-owners rtr) (radlink-updateradius obj rad))
  )
)

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
thanhduan2407    227

Chào các bác!

Em có nghiên cứu cách tạo ra File và lưu dưới dạng UTF-8 nhưng khi tạo ra rồi, dùng lisp mở nó ra và ghi Text vào đó, khi mở lên nó lại dạng ANSI. Em muốn nó phải là UTF-8.

Thêm chút nữa, nếu em không dùng write-line nữa mà (vlax-invoke stm 'write .....) thì có cách nào để xuống dòng không ạ? Các Text cứ nối với nhau.

P/s: Em đã làm được rồi nhé! (Nhưng là Unicode)

 

(defun C:00 (/ FSO I LT1 STM TXT)
  (setq i 0)
  (setq lt1 "")
  (while (< i 10)
    (setq lt1 (strcat lt1 (rtos (1+ i) 2 0) "\r\n"))
    (setq i (1+ i))
  )
  (setq txt
         (getfiled
           "Export to KML"
           ""
           "KML"
           1
         )
  )
  (WriteUnicode txt lt1 "w")
  (princ)
)
 
 
(defun WriteUnicode (path text mode / fso stream file result)
  (setq mode (if (member mode '("a" "A"))
               "a"
               "w"
             )
  )
  (vl-catch-all-apply
    '(lambda (/ format)
       (setq fso (vlax-create-object "Scripting.FileSystemObject"))
       (cond
         ((or (null (findfile path)) (eq "w" mode))
          (setq stream
                 (vlax-invoke
                   fso 'CreateTextFile path -1
                   ;; 0 (false) = don't overwrite , -1 (true) = overwrite
                   -1
                   ;; 0 (false) = ascii, -1 (true) = unicode 
)
          )
          (setq file (vlax-invoke fso 'GetFile path))
         )
         ((setq file (vlax-invoke fso 'GetFile path))
          (setq stream
                 (vlax-invoke
                   file
                   'OpenAsTextStream
                   2
                   ;; 1 = read, 2 = write, 8 = append
                   -1
                   ;; 0 = ascii, -1 = unicode, -2 system default
                 )
          )
         )
       )
       (vlax-invoke stream 'Write text)
       (vlax-invoke stream 'Close)
       (setq result (vlax-get file 'Size))
     )
  )
 
  (if file
    (vlax-release-object file)
  )
  (if stream
    (vlax-release-object stream)
  )
  (if fso
    (vlax-release-object fso)
  )
  result
)

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
cuongtk2    40

1.Bạn xuất ra dạng unicode làm gì khi lisp không hỗ trợ unicode tiếng Việt?

2.Nếu bạn mở file bằng notepad thì sẽ thấy có các dòng.

3.String không có các dòng mà chỉ có các ký tự xuống dòng "\n"

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
thanhduan2407    227

1.Bạn xuất ra dạng unicode làm gì khi lisp không hỗ trợ unicode tiếng Việt?

2.Nếu bạn mở file bằng notepad thì sẽ thấy có các dòng.

3.String không có các dòng mà chỉ có các ký tự xuống dòng "\n"

Cảm ơn bác!

Em đã làm được rồi bác à!

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Doan Van Ha    2.676

Nghĩ mãi chưa ra nên đưa lên đây nhờ mọi người.

Tôi có 1 list, ví dụ là:

(a b 0 0 c d e 0 0 0 f g 0 h 0 0 i j)

Làm sao để nhóm nó thành các list con, ví dụ trong trường hợp này là:

((b 0 0 c) (e 0 0 0 f) (g 0 h) (h 0 0 i))

Giải thích:

Nhóm list mẹ thành các list con thỏa mãn 2 điều kiện:

- Các phần từ bằng 0 nếu liên tiếp nhau thì sẽ được nhóm vào 1 list con.

- Bổ sung phần tử đầu và phần tử cuối là 2 phần tử tương ứng nằm kề với nhóm đó trong list mẹ, vào list con tương ứng.

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Tot77    501

Làm dùm bác, hơi lỉnh kỉnh nhưng xài tạm.

<code>

(defun test()
(setq l '(a b 0 0 c d e 0 0 0 f g 0 h 0 0 i j))
(setq l1 (cons 1 (append l (list 1))))

(setq l1 (reverse (cdr (reverse (cdr (vl-remove-if '(lambda(x) (if (and (setq vt (vl-position x l1)) (/= 0 vt) (/=  vt (length l1)))
                                                          (and (/= 0 (nth (1- vt) l1)) (/= 0 (nth (1+ vt) l1)) ))) l1))))))
(setq i 0
            l2 nil
            lc nil)
(repeat (length l1)
    (cond ((and (= 0 (nth i l1)) (/= 0 (nth (1+ i) l1)))
                    (setq l2 (append l2 (list (nth i l1) (nth (1+ i) l1)))
                                lc (append lc (list l2))
                              l2 nil))
                ((and (/= 0 (nth i l1)) (/= 0 (nth (1+ i) l1))))
                (t    (setq l2 (append l2 (list (nth i l1)))))
                )
    (setq i (1+ i))
)
lc
)

</code>

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
hiepttr    523

Khó hiểu ^^
Chắc bác í lắm việc 

Em viết kiểu bi bô cũng chạy mà bác :D

;;;Nhom list
(defun NHOM (lst / lst1 lst2 kq)
(setq lst2 lst
	  lst (TRIM_FRONT lst))
(while (> (length lst) 1)
	(setq lst1 (First_Group lst)
	  kq (cons lst1 kq)
	  lst (TRIM_FRONT (trim_n lst (length lst1)))
	)
	(if (= (car lst) 0) 
		(setq lst (cons (car (trim_n (reverse lst2) (length lst))) lst))
	)
)
(reverse kq)
)
;;;Ham TRIM_FRONT:
(defun TRIM_FRONT (lst)
(while (and (> (length lst) 1) (/= (car lst) 0) (/= (cadr lst) 0))
	(setq lst (cdr lst))
)
lst
)
;;;Ham First_Group:
(defun First_Group (lst / lst1 lst2)
(setq lst1 (list (car lst))
	  lst2 (cdr lst))
(while 
	(= (car lst2) 0)
	(setq lst1 (append lst1 (list 0))
		  lst2 (cdr lst2)
	)
)
(if lst2 (setq lst1 (append lst1 (list (car lst2)))))
lst1
)
;;;Ham cat n phan tu dau cua lst
(defun trim_n (lst n)
(repeat n
	(setq lst (cdr lst))
)
)
  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Tue_NV    3.841

Nghĩ mãi chưa ra nên đưa lên đây nhờ mọi người.

Tôi có 1 list, ví dụ là:

(a b 0 0 c d e 0 0 0 f g 0 h 0 0 i j)

Làm sao để nhóm nó thành các list con, ví dụ trong trường hợp này là:

((b 0 0 c) (e 0 0 0 f) (g 0 h) (h 0 0 i))

....

 

Xin góp thêm đoạn code nữa :

 

(defun Kq (lst / lst-member Len L1 res)
(while (setq lst-member (member 0 lst))
     (setq Len (length lst-member)) 
     (while (= 0 (car lst-member)) 
   (setq L1 (append L1 (list (car lst-member))))
   (setq lst-member (cdr lst-member))
     )
(if lst-member (setq L1 (append L1 (list (car lst-member)))))
 
(if (< Len (length lst)) (setq L1 (append (list (nth (- (length lst) len 1) lst)) L1 )))
        (setq res (append res (list L1)) L1 nil)
   (setq lst lst-member)
 )
  Res
)
  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Tạo một tài khoản hoặc đăng nhập để nhận xét

Bạn cần phải là một thành viên để lại một bình luận

Tạo tài khoản

Đăng ký một tài khoản mới trong cộng đồng của chúng tôi. Điều đó dễ mà.

Đăng ký tài khoản mới

Đăng nhập

Bạn có sẵn sàng để tạo một tài khoản ? Đăng nhập tại đây.

Đăng nhập ngay


×