Đến nội dung


Hình ảnh
- - - - -

[Nhờ Chỉnh Sửa] Lisp Dải Taluy


  • Please log in to reply
16 replies to this topic

#1 031113

031113

    biết zoom

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

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

Em đang sử dụng lisp rải taluy này rất dễ dùng nhưng có một nhược điểm là mỗi lần vào cad nó lại xuất hiện thông báo của autocad messenger, vậy em muốn nhờ các bác bỏ dùm em cái thông báo đó với ạ. và nếu được giúp em thêm hiệu chỉnh block phần taluy mình vừa vẽ lại thì tốt quá. Em xin cảm ơn trước

 

http://www.cadviet.c...chieu_taluy.lsp


  • 0

#2 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

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

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

File tiếng Tàu hả bạn?


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


#3 031113

031113

    biết zoom

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

Đã gửi 24 June 2015 - 09:04 AM

Em không rõ ạ, em mở thử thì không nhặn dạng được font chữ nhưng em add lisp vào cad thì nó có một bảng thông báo tiếng việt , bác add thử và xem dùm em với
  • 0

#4 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

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

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

À! Đây là lisp của 1 member rất quen trên CadViet. Bạn gọi cho anh ấy xem.

P/S: @thanhduan lại có chiêu mã hóa thành tiếng Tàu hay nhỉ! Bày xem 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.


#5 ndtnv

ndtnv

    biết lệnh minsert

  • Members
  • PipPipPipPipPipPip
  • 437 Bài viết
Điểm đánh giá: 384 (khá)

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

À! Đây là lisp của 1 member rất quen trên CadViet. Bạn gọi cho anh ấy xem.

P/S: @thanhduan lại có chiêu mã hóa thành tiếng Tàu hay nhỉ! Bày xem nào!

Vấn đề này đã thảo luận ở đây

http://www.cadviet.c...file-lisp-file/


  • 1

#6 ketxu

ketxu

    Copier - Paster - Editor

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

Đã gửi 24 June 2015 - 10:54 AM

Protected lisp với key # thôi :) Để mở khóa và sửa giúp bạn cũng đơn giản, nhưng ở đây có @ rồi nên không sờ vào ^^

Về việc muốn tắt alert thì bạn cho dòng này :

(setvar 'QAFLAGS  4)

vào bất kỳ lisp nào startup của bạn


  • 2

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


#7 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

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

Đã gửi 24 June 2015 - 11:25 AM

Ý kiến bổ sung: Bạn nên suy nghĩ kỹ xem có nên làm theo đề xuất của anh Ketxu không nhé, bởi khi đã đặt như thế thì mọi lisp khác đều bị mất autocad messenger (chỉ princ ra screen chứ không alert kiểu dialog), mà nhiều khi những dòng alert này lại rất quan trọng khi dùng lisp.


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


#8 031113

031113

    biết zoom

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

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

Dạ bác cứ chỉnh giúp em với ạ em muốn như vậy dùng cho tiện thôi ạ, mong các bác giúp đỡ
  • 0

#9 031113

031113

    biết zoom

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

Đã gửi 24 June 2015 - 05:30 PM

Protected lisp với key # thôi :) Để mở khóa và sửa giúp bạn cũng đơn giản, nhưng ở đây có @ rồi nên không sờ vào ^^
Về việc muốn tắt alert thì bạn cho dòng này :
(setvar 'QAFLAGS  4)
vào bất kỳ lisp nào startup của bạn

dạ em cũng thử liên lạc với bác chủ rồi nhưng không được, có gì bác giúp em với. em cảm ơn ạ
  • 0

#10 ketxu

ketxu

    Copier - Paster - Editor

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

Đã gửi 24 June 2015 - 08:04 PM

Quan điểm của ketxu về alert dialog hơi khác 1 chút ^^

@OP : rất tiếc, mình k làm được nếu anh Duân k đồng ý. Có SĐT trên đó rồi mà ^^  


  • 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


#11 quocmanh04tt

quocmanh04tt

    biết lệnh imageclip

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

Đã gửi 24 June 2015 - 10:39 PM

Protect kiểu này thì quá đan rổ. Không cần dùng cái gì ngoài CAD.


  • 0

#12 031113

031113

    biết zoom

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

Đã gửi 25 June 2015 - 12:01 AM

EM liên lạc qua số điện thoại mà không được ạ :(
  • 0

#13 031113

031113

    biết zoom

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

Đã gửi 25 June 2015 - 06:21 PM

Ai giúp em vơi ạ
  • 0

#14 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 995 Bài viết
Điểm đánh giá: 223 (khá)

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

Của bạn đây! Mình đang ở vùng biên giới nên ko có mạng internet.

(vl-load-com)
(defun C:VTL( /  ObjPline LtsTaluy LtsLDai LtsLNgan e1 e2 e3 e4 ang1 ang2 ang3 ang4 Pnt10N Pnt10D Pnt11N Pnt11D Chon)
(defun *error* ( msg )
(if Olmode (setvar 'osmode Olmode))
(if (not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
    (princ (strcat "\nError: " msg))
)
(princ)
)
(setq Olmode (getvar "OSMODE"))

(or *CDTLN* (setq *CDTLN* 1))
(setq CDTLN (getreal (strcat "\nChi\U+1EC1u d\U+00E0i c\U+1EE7a v\U+1EA1ch nh\U+1ECF < "
			  (rtos *CDTLN* 2 2)
			 " > :"
		    )
	 )
)
(if (not CDTLN) (setq CDTLN *CDTLN*) (setq *CDTLN* CDTLN))

(or *CDTLD* (setq *CDTLD* 2))
(setq CDTLD (getreal (strcat "\nChi\U+1EC1u d\U+00E0i c\U+1EE7a v\U+1EA1ch d\U+00E0i < "
			  (rtos *CDTLD* 2 2)
			 " > :"
		    )
	 )
)
(if (not CDTLD) (setq CDTLD *CDTLD*) (setq *CDTLD* CDTLD))

  
(or *Sovachngan* (setq *Sovachngan* 2))
(setq Sovachngan (getint (strcat "\nS\U+1ED1 v\U+1EA1ch nh\U+1ECF gi\U+1EEFa 2 v\U+1EA1ch l\U+1EDBn: < "
			  (rtos *Sovachngan* 2 0)
			 " > :"
		  )
	 )
)
(if (not Sovachngan) (setq Sovachngan *Sovachngan*) (setq *Sovachngan* Sovachngan))

(while (setq ObjPline (car (entsel "\nCh\U+1ECDn Pline: ")))
  	(setq VlaObjPL (vlax-ename->vla-object ObjPline))
        (setq LtsTaluy (VTLL CDTLN CDTLD Sovachngan ObjPline))
	(setq LtsLDai (car LtsTaluy))
	(setq LtsLNgan (cadr LtsTaluy))
  	 (setq Chon (strcase (getstring "\n(Ghi ch\U+00FA: U - L\U+00E0m l\U+1EA1i, C - \U+0110\U+1ED5i chi\U+1EC1u v\U+1EA1ch, G\U+00F5 b\U+1EA5t k\U+1EF3 \U+0111\U+1EC3 ti\U+1EBFp t\U+1EE5c) ")))
         (cond
           ((= Chon  "U")
	     (progn
	        (foreach e1 LtsLDai
			(entdel e1)
		)
	        (foreach e2 LtsLNgan
			(entdel e2)
		)
	     )
	    )
	   ((= Chon  "C")
	     (progn
	        (foreach e3 LtsLDai
		  	(progn
				(setq Pnt10D (cdr (assoc 10 (entget e3))))
			  	(setq ang3 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPL (vlax-curve-getParamAtPoint VlaObjPL Pnt10D))))
			  	(setq Pnt11D (polar Pnt10D (- ang3 (/ pi 2) )  CDTLD))
		  		(entmod (subst (cons 11 Pnt11D) (assoc 11 (entget e3)) (entget e3) ))
			)
		)
	        (foreach e4 LtsLNgan
		  	(progn
				(setq Pnt10N (cdr (assoc 10 (entget e4))))
			  	(setq ang4 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPL (vlax-curve-getParamAtPoint VlaObjPL Pnt10N))))
			  	(setq Pnt11N (polar Pnt10N (- ang4 (/ pi 2) ) CDTLN))
		  		(entmod (subst (cons 11 Pnt11N) (assoc 11 (entget e4)) (entget e4) ))
			)
		)
	     )
	    )
	   ((or (/= Chon  "U") (/= Chon  "C"))
	     (setq Chon nil)
	    )
	 )
   )
(setvar "OSMODE" Olmode)
(princ)
)

(defun VTLL (CDTLN CDTLD Sovachngan ObjPline / CDTLD CDDoan n d1 d2 CDaiPLine ang2 Ptd Lts1 Lts2 LtsPntNgan Pnt1  EnameLD )
(MakeLayer_ "TALUY" 7)
(setq CDDoan (* (+ Sovachngan 1) CDTLN ))
(setq VlaObjPline (vlax-ename->vla-object ObjPline))
(setq CDaiPLine (vla-get-length VlaObjPline))
(setq n (fix (/ CDaiPLine CDDoan)))
(setq d1 0)
(setq Lts1 (list))
(setq LtsEnameLD (list))
(setq LtsEnameLN (list))
(while (< d1 CDaiPLine)
	(progn
		(setq Ptd (vlax-curve-getPointAtDist VlaObjPline d1))
		(setq d1 (+ d1 CDDoan))
	  	(setq ang2 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPline (vlax-curve-getParamAtPoint VlaObjPline Ptd))))
	  	(entmake (list (cons 0 "LINE") (cons 8 "TALUY") (cons 10  Ptd) (cons 11 (polar Ptd (+ ang2 (/ pi 2) ) CDTLD))))
	  	(setq EnameLD (entlast))
	  	(setq LtsEnameLD (append LtsEnameLD (list EnameLD)))
	  	(setq Lts1 (append Lts1 (list Ptd)))
	)
)
(setq d2 0)
(setq Lts2 (list))
(setq m (fix (/ CDaiPLine CDTLN)))
(while (< d2 CDaiPLine)
	(progn
		(setq Ptn (vlax-curve-getPointAtDist VlaObjPline d2))
		(setq d2 (+ d2 CDTLN))
	  	(setq Lts2 (append Lts2 (list Ptn)))
	)
)
(setq LtsPntNgan (LM:ListDifference Lts2 Lts1))
(foreach Pnt1 LtsPntNgan
  	(setq ang3 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPline (vlax-curve-getParamAtPoint VlaObjPline Pnt1))))
  	(entmake (list (cons 0 "LINE") (cons 10  Pnt1) (cons 8 "TALUY") (cons 11 (polar Pnt1 (+ ang3 (/ pi 2) ) CDTLN))))
  	(setq EnameLN (entlast))
  	(setq LtsEnameLN (append LtsEnameLN (list EnameLN)))
)
(setq DsTaluy (list LtsEnameLD LtsEnameLN))
DsTaluy
)


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

(defun C:VTL2 (  / Olmode Sovachngan  *Sovachngan* CDVN *CDVN*  CDDoan ObjPline1 ObjPL2 ObjPline2 VlaObjPline1 CDaiPLine1 VlaObjPline2
		   n d1 d2 LtsEnameLD LtsEnameLN Lts1 Lts2 LtsPntNgan   PntInObjPline2 PntInObjPline3 ang_1 ang_2 P3
	       )
(MakeLayer_ "TALUYN" 1)
(MakeLayer_ "TALUYD" 7)
;;;;;;;;;LUU OSNAP KHI BREAK, CANCEL, EXIT
(defun *error* ( msg )
(if Olmode (setvar 'osmode Olmode))
(if (not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
    (princ (strcat "\nError: " msg))
)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq Olmode (getvar "OSMODE"))
;;;(setq Sovachngan 1)

(or *Sovachngan* (setq *Sovachngan* 1))
(setq Sovachngan (getint (strcat "\nNhap so vach ngan giua 2 vach dai: < "
			  (rtos *Sovachngan* 2 0)
			 " > :"
		    )
	 )
)
(if (not Sovachngan) (setq Sovachngan *Sovachngan*) (setq *Sovachngan* Sovachngan))
  
(or *CDVN* (setq *CDVN* 2.5))
(setq CDVN (getreal (strcat "\nNh\U+1EADp kho\U+1EA3ng c\U+00E1ch gi\U+1EEFa c\U+00E1c v\U+1EA1ch: < "
			  (rtos *CDVN* 2 2)
			 " > :"
		    )
	 )
)
(if (not CDVN) (setq CDVN *CDVN*) (setq *CDVN* CDVN))
(setq CDDoan (* (+ Sovachngan 1) CDVN ))


  
(setq ObjPline1 (car (entsel "\nChon duong thu nhat: ")))
(setq ObjPL2  (entsel "\nChon duong thu hai: "))
(setq ObjPline2 (car ObjPL2))
;;;(setq PickPoint (cdr ObjPL2))

(setq VlaObjPline1 (vlax-ename->vla-object ObjPline1))
(setq CDaiPLine1 (vla-get-length VlaObjPline1))


(setq VlaObjPline2 (vlax-ename->vla-object ObjPline2))
  
(setq n (fix (/ CDaiPLine1 CDDoan)))
(setq d1 0)
(setq Lts1 (list))
(setq LtsEnameLD (list))
(setq LtsEnameLN (list))
(while (< d1 CDaiPLine1)
	(progn
		(setq Ptd (vlax-curve-getPointAtDist VlaObjPline1 d1))
		(setq d1 (+ d1 CDDoan))
	  	(setq ang_1 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPline1 (vlax-curve-getParamAtPoint VlaObjPline1 Ptd))))
	  	(if (setq PntInObjPline2 (TDKDGN Ptd ObjPline2 (polar Ptd (+ ang_1 (/ pi 2) ) CDVN)))
		    (progn
	  	    	(entmake (list (cons 0 "LINE") (cons 8 "TALUYD") (cons 10  Ptd) (cons 11 PntInObjPline2)))
	  	    	(setq EnameLD (entlast))
	  		(setq LtsEnameLD (append LtsEnameLD (list EnameLD)))
	  		(setq Lts1 (append Lts1 (list Ptd)))
		    )
		)
	)
)
(setq d2 0)
(setq Lts2 (list))
(setq m (fix (/ CDaiPLine1 CDVN)))
(while (< d2 CDaiPLine1)
	(progn
		(setq Ptn_N (vlax-curve-getPointAtDist VlaObjPline1 d2))
		(setq d2 (+ d2 CDVN))
	  	(setq Lts2 (append Lts2 (list Ptn_N)))
	)
)
(setq LtsPntNgan (LM:ListDifference Lts2 Lts1))
(foreach Pnt1 LtsPntNgan
  	(setq ang_2 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPline1 (vlax-curve-getParamAtPoint VlaObjPline1 Pnt1))))
  	(if (setq PntInObjPline3 (TDKDGN Pnt1 ObjPline2 (polar Pnt1 (+ ang_2 (/ pi 2) ) CDVN)))
	    (progn
	  	(setq P3 (list (/ (+ (car Pnt1) (car PntInObjPline3)) 2) (/ (+ (cadr Pnt1) (cadr PntInObjPline3)) 2)))
	  	(entmake (list (cons 0 "LINE") (cons 10  Pnt1) (cons 8 "TALUYN") (cons 11 P3)))
	    )
	)
)
(princ)
)





;;;HAM LAY RA CAC PHAN TU KHAC NHAU TRONG DANH SACH 1 SO VOI DANH SACH 2 (TO - CON) (LEN L1 > LEN L2)
;;;(LM:ListDifference '(1 2 3 4 5) '(2 4 6)  )
(defun LM:ListDifference ( l1 l2 )
  (if l1
    (if (member (car l1) l2)
      (LM:ListDifference (cdr l1) l2)
      (cons (car l1) (LM:ListDifference (cdr l1) l2))
    )
  )
)


;;;;;;;;;;;;;;;acextendnone	Do not extend either object
;;;;;;;;;;;;;;;acextendthisentity	Extend obj1 to meet obj2
;;;;;;;;;;;;;;;acextendotherentity	Extend obj2 to meet obj1
;;;;;;;;;;;;;;;acextendboth	Extend both objects

(defun LM:Intersections ( obj1 obj2 mode / l r )
    (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
    (repeat (/ (length l) 3)
        (setq r (cons (list (car l) (cadr l) (caddr l)) r)
              l (cdddr l)
        )
    )
    (reverse r)
)

(defun MakeXline (pt vec)
  (entmakex (list (cons 0 "XLINE")
                  (cons 100 "AcDbEntity")
                  (cons 100 "AcDbXline")
                  (cons 10 pt)
                  (cons 11 vec)
	    )
  )
)

(defun TDKDGN (P1 ObjPline1 Pnt / Vla:ObjPline1   EnameXline Vla:Xline LtsPnt ) ;;;TIM DIEM KEO DAI GAN NHAT
(setq Vla:ObjPline1 (vlax-ename->vla-object ObjPline1))
(setq P2 (mapcar '- Pnt P1))
(MakeXline P1 P2)
(setq EnameXline (entlast))
(setq Vla:Xline (vlax-ename->vla-object EnameXline))
(setq LtsPnt (LM:Intersections Vla:ObjPline1  Vla:Xline acextendboth))
(entdel EnameXline)
(setq PntNear (car (vl-sort LtsPnt '(lambda(x y) (< (distance x P1) (distance y P1))))))
PntNear
)


(defun C:DCTL( / ss LtsEnameLine P1 P2  PVG1 PVG2 CDLine);;;DAO CHIEU TALUY
(setq VLA:ObjPline (vlax-ename->vla-object (car (entsel "\nChon Polyline can dao chieu Taluy:"))))
(Alert "\nQuet chon Line")
(setq ss (ssget (list (cons 0 "LINE"))))
(setq LtsEnameLine (acet-ss-to-list ss))
(setq i 0)
(foreach EnameL LtsEnameLine
	(setq P1 (acet-dxf 10 (entget EnameL)))
	(setq P2 (acet-dxf 11 (entget EnameL)))
	(if (and (setq Pgiao (last (LM:Intersections (vlax-ename->vla-object EnameL) VLA:ObjPline acextendnone ))) (equal (LineVGtPline VLA:ObjPline EnameL) 1 0.0000000001))
	    (progn
	    	(setq CDLine (vla-get-length (vlax-ename->vla-object EnameL)))
	    	(cond ((equal P1 Pgiao 0.00000001)
		      	      (progn
			    	(setq angL10 (angle '(0 0) (Vlax-curve-getfirstderiv VLA:ObjPline (vlax-curve-getParamAtPoint VLA:ObjPline Pgiao))))
				(setq P2A (polar Pgiao (+ angL10 (* -1.0 (PointLeftRightPline VLA:ObjPline P2)  (/ pi 2))) CDLine))
			      	(entmod (subst (cons 11 P2A) (assoc 11 (entget EnameL)) (entget EnameL) ))
			      )
		      )
		      ((equal P2 Pgiao 0.00000001)
		      	      (progn
			    	(setq angL11 (angle '(0 0) (Vlax-curve-getfirstderiv VLA:ObjPline (vlax-curve-getParamAtPoint VLA:ObjPline Pgiao))))
				(setq P1A (polar Pgiao (+ angL11 (* -1.0 (PointLeftRightPline VLA:ObjPline P1)  (/ pi 2))) CDLine))
			      	(entmod (subst (cons 10 P1A) (assoc 10 (entget EnameL)) (entget EnameL) ))
			      )
		      )
		    )
		 )
	)
)
(princ)
)


  
(defun LineVGtPline (VLA:ObjPline ObjLine / PVG Pd1 Pd2 GocP1P2  VLA:ObjPline VLA:ObjLine PntGiao );;;;XET LINE VUONG GOC VOI POLYLINE HAY KHONG?
	(setq P1 (acet-dxf 10 (entget ObjLine)))
	(setq P2 (acet-dxf 11 (entget ObjLine)))
  	(setq GocP1P2 (angle P1 P2))
  	(setq GocP2P1 (angle P2 P1))
  	(setq VLA:ObjLine (vlax-ename->vla-object ObjLine))
        (setq PntGiao (last (LM:Intersections VLA:ObjLine VLA:ObjPline acextendnone)))
  	(setq Goctaidiemgiao (angle '(0 0) (Vlax-curve-getfirstderiv VLA:ObjPline (vlax-curve-getParamAtPoint VLA:ObjPline PntGiao))))
  	(setq KQVG nil)
	(if (or (equal (+ Goctaidiemgiao (/ pi 2)) GocP1P2 0.00000000001) (equal (- Goctaidiemgiao (/ pi 2)) GocP1P2 0.00000000001)
	        (equal (+ Goctaidiemgiao (/ pi 2)) GocP2P1 0.00000000001) (equal (- Goctaidiemgiao (/ pi 2)) GocP2P1 0.00000000001))
	    (setq KQVG 1)
	    (setq KQVG 0)
        )
  KQVG
)


(defun PointLeftRightPline (ObjPline Pnt / PVG Pd1 Pd2);;;;XET DIEM NAM TRAI HAY PHAI PLINE
    (setq PVG (vlax-curve-getClosestPointTo ObjPline Pnt)
          Pd1 (vlax-curve-getpointAtParam ObjPline (fix (vlax-curve-getparamatPoint ObjPline PVG)))
          Pd2 (vlax-curve-getpointAtParam ObjPline (1+ (fix (vlax-curve-getparamatPoint ObjPline PVG))))
    )
    (setq Kqua nil)
    (if (or (equal (cos (+ (/ pi 2) (angle Pd1 Pd2))) (cos (angle Pnt PVG)) 0.00000001)
   	    (equal (sin (+ (/ pi 2) (angle Pd1 Pd2))) (sin (angle Pnt Pd1)) 0.00000001)
	)
        (setq Kqua -1)
        (setq Kqua 1)
    )
    Kqua
)





  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#15 031113

031113

    biết zoom

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

Đã gửi 26 June 2015 - 01:01 AM

Của bạn đây! Mình đang ở vùng biên giới nên ko có mạng internet.

Em cảm ơn bác :)
  • 0

#16 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

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

Đã gửi 26 June 2015 - 09:55 AM

 

Của bạn đây! Mình đang ở vùng biên giới nên ko có mạng internet.

(vl-load-com)
(defun C:VTL( /  ObjPline LtsTaluy LtsLDai LtsLNgan e1 e2 e3 e4 ang1 ang2 ang3 ang4 Pnt10N Pnt10D Pnt11N Pnt11D Chon)
(defun *error* ( msg )
(if Olmode (setvar 'osmode Olmode))
(if (not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
    (princ (strcat "\nError: " msg))
)
(princ)
)
(setq Olmode (getvar "OSMODE"))

(or *CDTLN* (setq *CDTLN* 1))
(setq CDTLN (getreal (strcat "\nChi\U+1EC1u d\U+00E0i c\U+1EE7a v\U+1EA1ch nh\U+1ECF < "
			  (rtos *CDTLN* 2 2)
			 " > :"
		    )
	 )
)
(if (not CDTLN) (setq CDTLN *CDTLN*) (setq *CDTLN* CDTLN))

(or *CDTLD* (setq *CDTLD* 2))
(setq CDTLD (getreal (strcat "\nChi\U+1EC1u d\U+00E0i c\U+1EE7a v\U+1EA1ch d\U+00E0i < "
			  (rtos *CDTLD* 2 2)
			 " > :"
		    )
	 )
)
(if (not CDTLD) (setq CDTLD *CDTLD*) (setq *CDTLD* CDTLD))

  
(or *Sovachngan* (setq *Sovachngan* 2))
(setq Sovachngan (getint (strcat "\nS\U+1ED1 v\U+1EA1ch nh\U+1ECF gi\U+1EEFa 2 v\U+1EA1ch l\U+1EDBn: < "
			  (rtos *Sovachngan* 2 0)
			 " > :"
		  )
	 )
)
(if (not Sovachngan) (setq Sovachngan *Sovachngan*) (setq *Sovachngan* Sovachngan))

(while (setq ObjPline (car (entsel "\nCh\U+1ECDn Pline: ")))
  	(setq VlaObjPL (vlax-ename->vla-object ObjPline))
        (setq LtsTaluy (VTLL CDTLN CDTLD Sovachngan ObjPline))
	(setq LtsLDai (car LtsTaluy))
	(setq LtsLNgan (cadr LtsTaluy))
  	 (setq Chon (strcase (getstring "\n(Ghi ch\U+00FA: U - L\U+00E0m l\U+1EA1i, C - \U+0110\U+1ED5i chi\U+1EC1u v\U+1EA1ch, G\U+00F5 b\U+1EA5t k\U+1EF3 \U+0111\U+1EC3 ti\U+1EBFp t\U+1EE5c) ")))
         (cond
           ((= Chon  "U")
	     (progn
	        (foreach e1 LtsLDai
			(entdel e1)
		)
	        (foreach e2 LtsLNgan
			(entdel e2)
		)
	     )
	    )
	   ((= Chon  "C")
	     (progn
	        (foreach e3 LtsLDai
		  	(progn
				(setq Pnt10D (cdr (assoc 10 (entget e3))))
			  	(setq ang3 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPL (vlax-curve-getParamAtPoint VlaObjPL Pnt10D))))
			  	(setq Pnt11D (polar Pnt10D (- ang3 (/ pi 2) )  CDTLD))
		  		(entmod (subst (cons 11 Pnt11D) (assoc 11 (entget e3)) (entget e3) ))
			)
		)
	        (foreach e4 LtsLNgan
		  	(progn
				(setq Pnt10N (cdr (assoc 10 (entget e4))))
			  	(setq ang4 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPL (vlax-curve-getParamAtPoint VlaObjPL Pnt10N))))
			  	(setq Pnt11N (polar Pnt10N (- ang4 (/ pi 2) ) CDTLN))
		  		(entmod (subst (cons 11 Pnt11N) (assoc 11 (entget e4)) (entget e4) ))
			)
		)
	     )
	    )
	   ((or (/= Chon  "U") (/= Chon  "C"))
	     (setq Chon nil)
	    )
	 )
   )
(setvar "OSMODE" Olmode)
(princ)
)

(defun VTLL (CDTLN CDTLD Sovachngan ObjPline / CDTLD CDDoan n d1 d2 CDaiPLine ang2 Ptd Lts1 Lts2 LtsPntNgan Pnt1  EnameLD )
(MakeLayer_ "TALUY" 7)
(setq CDDoan (* (+ Sovachngan 1) CDTLN ))
(setq VlaObjPline (vlax-ename->vla-object ObjPline))
(setq CDaiPLine (vla-get-length VlaObjPline))
(setq n (fix (/ CDaiPLine CDDoan)))
(setq d1 0)
(setq Lts1 (list))
(setq LtsEnameLD (list))
(setq LtsEnameLN (list))
(while (< d1 CDaiPLine)
	(progn
		(setq Ptd (vlax-curve-getPointAtDist VlaObjPline d1))
		(setq d1 (+ d1 CDDoan))
	  	(setq ang2 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPline (vlax-curve-getParamAtPoint VlaObjPline Ptd))))
	  	(entmake (list (cons 0 "LINE") (cons 8 "TALUY") (cons 10  Ptd) (cons 11 (polar Ptd (+ ang2 (/ pi 2) ) CDTLD))))
	  	(setq EnameLD (entlast))
	  	(setq LtsEnameLD (append LtsEnameLD (list EnameLD)))
	  	(setq Lts1 (append Lts1 (list Ptd)))
	)
)
(setq d2 0)
(setq Lts2 (list))
(setq m (fix (/ CDaiPLine CDTLN)))
(while (< d2 CDaiPLine)
	(progn
		(setq Ptn (vlax-curve-getPointAtDist VlaObjPline d2))
		(setq d2 (+ d2 CDTLN))
	  	(setq Lts2 (append Lts2 (list Ptn)))
	)
)
(setq LtsPntNgan (LM:ListDifference Lts2 Lts1))
(foreach Pnt1 LtsPntNgan
  	(setq ang3 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPline (vlax-curve-getParamAtPoint VlaObjPline Pnt1))))
  	(entmake (list (cons 0 "LINE") (cons 10  Pnt1) (cons 8 "TALUY") (cons 11 (polar Pnt1 (+ ang3 (/ pi 2) ) CDTLN))))
  	(setq EnameLN (entlast))
  	(setq LtsEnameLN (append LtsEnameLN (list EnameLN)))
)
(setq DsTaluy (list LtsEnameLD LtsEnameLN))
DsTaluy
)


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

(defun C:VTL2 (  / Olmode Sovachngan  *Sovachngan* CDVN *CDVN*  CDDoan ObjPline1 ObjPL2 ObjPline2 VlaObjPline1 CDaiPLine1 VlaObjPline2
		   n d1 d2 LtsEnameLD LtsEnameLN Lts1 Lts2 LtsPntNgan   PntInObjPline2 PntInObjPline3 ang_1 ang_2 P3
	       )
(MakeLayer_ "TALUYN" 1)
(MakeLayer_ "TALUYD" 7)
;;;;;;;;;LUU OSNAP KHI BREAK, CANCEL, EXIT
(defun *error* ( msg )
(if Olmode (setvar 'osmode Olmode))
(if (not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
    (princ (strcat "\nError: " msg))
)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq Olmode (getvar "OSMODE"))
;;;(setq Sovachngan 1)

(or *Sovachngan* (setq *Sovachngan* 1))
(setq Sovachngan (getint (strcat "\nNhap so vach ngan giua 2 vach dai: < "
			  (rtos *Sovachngan* 2 0)
			 " > :"
		    )
	 )
)
(if (not Sovachngan) (setq Sovachngan *Sovachngan*) (setq *Sovachngan* Sovachngan))
  
(or *CDVN* (setq *CDVN* 2.5))
(setq CDVN (getreal (strcat "\nNh\U+1EADp kho\U+1EA3ng c\U+00E1ch gi\U+1EEFa c\U+00E1c v\U+1EA1ch: < "
			  (rtos *CDVN* 2 2)
			 " > :"
		    )
	 )
)
(if (not CDVN) (setq CDVN *CDVN*) (setq *CDVN* CDVN))
(setq CDDoan (* (+ Sovachngan 1) CDVN ))


  
(setq ObjPline1 (car (entsel "\nChon duong thu nhat: ")))
(setq ObjPL2  (entsel "\nChon duong thu hai: "))
(setq ObjPline2 (car ObjPL2))
;;;(setq PickPoint (cdr ObjPL2))

(setq VlaObjPline1 (vlax-ename->vla-object ObjPline1))
(setq CDaiPLine1 (vla-get-length VlaObjPline1))


(setq VlaObjPline2 (vlax-ename->vla-object ObjPline2))
  
(setq n (fix (/ CDaiPLine1 CDDoan)))
(setq d1 0)
(setq Lts1 (list))
(setq LtsEnameLD (list))
(setq LtsEnameLN (list))
(while (< d1 CDaiPLine1)
	(progn
		(setq Ptd (vlax-curve-getPointAtDist VlaObjPline1 d1))
		(setq d1 (+ d1 CDDoan))
	  	(setq ang_1 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPline1 (vlax-curve-getParamAtPoint VlaObjPline1 Ptd))))
	  	(if (setq PntInObjPline2 (TDKDGN Ptd ObjPline2 (polar Ptd (+ ang_1 (/ pi 2) ) CDVN)))
		    (progn
	  	    	(entmake (list (cons 0 "LINE") (cons 8 "TALUYD") (cons 10  Ptd) (cons 11 PntInObjPline2)))
	  	    	(setq EnameLD (entlast))
	  		(setq LtsEnameLD (append LtsEnameLD (list EnameLD)))
	  		(setq Lts1 (append Lts1 (list Ptd)))
		    )
		)
	)
)
(setq d2 0)
(setq Lts2 (list))
(setq m (fix (/ CDaiPLine1 CDVN)))
(while (< d2 CDaiPLine1)
	(progn
		(setq Ptn_N (vlax-curve-getPointAtDist VlaObjPline1 d2))
		(setq d2 (+ d2 CDVN))
	  	(setq Lts2 (append Lts2 (list Ptn_N)))
	)
)
(setq LtsPntNgan (LM:ListDifference Lts2 Lts1))
(foreach Pnt1 LtsPntNgan
  	(setq ang_2 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPline1 (vlax-curve-getParamAtPoint VlaObjPline1 Pnt1))))
  	(if (setq PntInObjPline3 (TDKDGN Pnt1 ObjPline2 (polar Pnt1 (+ ang_2 (/ pi 2) ) CDVN)))
	    (progn
	  	(setq P3 (list (/ (+ (car Pnt1) (car PntInObjPline3)) 2) (/ (+ (cadr Pnt1) (cadr PntInObjPline3)) 2)))
	  	(entmake (list (cons 0 "LINE") (cons 10  Pnt1) (cons 8 "TALUYN") (cons 11 P3)))
	    )
	)
)
(princ)
)





;;;HAM LAY RA CAC PHAN TU KHAC NHAU TRONG DANH SACH 1 SO VOI DANH SACH 2 (TO - CON) (LEN L1 > LEN L2)
;;;(LM:ListDifference '(1 2 3 4 5) '(2 4 6)  )
(defun LM:ListDifference ( l1 l2 )
  (if l1
    (if (member (car l1) l2)
      (LM:ListDifference (cdr l1) l2)
      (cons (car l1) (LM:ListDifference (cdr l1) l2))
    )
  )
)


;;;;;;;;;;;;;;;acextendnone	Do not extend either object
;;;;;;;;;;;;;;;acextendthisentity	Extend obj1 to meet obj2
;;;;;;;;;;;;;;;acextendotherentity	Extend obj2 to meet obj1
;;;;;;;;;;;;;;;acextendboth	Extend both objects

(defun LM:Intersections ( obj1 obj2 mode / l r )
    (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
    (repeat (/ (length l) 3)
        (setq r (cons (list (car l) (cadr l) (caddr l)) r)
              l (cdddr l)
        )
    )
    (reverse r)
)

(defun MakeXline (pt vec)
  (entmakex (list (cons 0 "XLINE")
                  (cons 100 "AcDbEntity")
                  (cons 100 "AcDbXline")
                  (cons 10 pt)
                  (cons 11 vec)
	    )
  )
)

(defun TDKDGN (P1 ObjPline1 Pnt / Vla:ObjPline1   EnameXline Vla:Xline LtsPnt ) ;;;TIM DIEM KEO DAI GAN NHAT
(setq Vla:ObjPline1 (vlax-ename->vla-object ObjPline1))
(setq P2 (mapcar '- Pnt P1))
(MakeXline P1 P2)
(setq EnameXline (entlast))
(setq Vla:Xline (vlax-ename->vla-object EnameXline))
(setq LtsPnt (LM:Intersections Vla:ObjPline1  Vla:Xline acextendboth))
(entdel EnameXline)
(setq PntNear (car (vl-sort LtsPnt '(lambda(x y) (< (distance x P1) (distance y P1))))))
PntNear
)


(defun C:DCTL( / ss LtsEnameLine P1 P2  PVG1 PVG2 CDLine);;;DAO CHIEU TALUY
(setq VLA:ObjPline (vlax-ename->vla-object (car (entsel "\nChon Polyline can dao chieu Taluy:"))))
(Alert "\nQuet chon Line")
(setq ss (ssget (list (cons 0 "LINE"))))
(setq LtsEnameLine (acet-ss-to-list ss))
(setq i 0)
(foreach EnameL LtsEnameLine
	(setq P1 (acet-dxf 10 (entget EnameL)))
	(setq P2 (acet-dxf 11 (entget EnameL)))
	(if (and (setq Pgiao (last (LM:Intersections (vlax-ename->vla-object EnameL) VLA:ObjPline acextendnone ))) (equal (LineVGtPline VLA:ObjPline EnameL) 1 0.0000000001))
	    (progn
	    	(setq CDLine (vla-get-length (vlax-ename->vla-object EnameL)))
	    	(cond ((equal P1 Pgiao 0.00000001)
		      	      (progn
			    	(setq angL10 (angle '(0 0) (Vlax-curve-getfirstderiv VLA:ObjPline (vlax-curve-getParamAtPoint VLA:ObjPline Pgiao))))
				(setq P2A (polar Pgiao (+ angL10 (* -1.0 (PointLeftRightPline VLA:ObjPline P2)  (/ pi 2))) CDLine))
			      	(entmod (subst (cons 11 P2A) (assoc 11 (entget EnameL)) (entget EnameL) ))
			      )
		      )
		      ((equal P2 Pgiao 0.00000001)
		      	      (progn
			    	(setq angL11 (angle '(0 0) (Vlax-curve-getfirstderiv VLA:ObjPline (vlax-curve-getParamAtPoint VLA:ObjPline Pgiao))))
				(setq P1A (polar Pgiao (+ angL11 (* -1.0 (PointLeftRightPline VLA:ObjPline P1)  (/ pi 2))) CDLine))
			      	(entmod (subst (cons 10 P1A) (assoc 10 (entget EnameL)) (entget EnameL) ))
			      )
		      )
		    )
		 )
	)
)
(princ)
)


  
(defun LineVGtPline (VLA:ObjPline ObjLine / PVG Pd1 Pd2 GocP1P2  VLA:ObjPline VLA:ObjLine PntGiao );;;;XET LINE VUONG GOC VOI POLYLINE HAY KHONG?
	(setq P1 (acet-dxf 10 (entget ObjLine)))
	(setq P2 (acet-dxf 11 (entget ObjLine)))
  	(setq GocP1P2 (angle P1 P2))
  	(setq GocP2P1 (angle P2 P1))
  	(setq VLA:ObjLine (vlax-ename->vla-object ObjLine))
        (setq PntGiao (last (LM:Intersections VLA:ObjLine VLA:ObjPline acextendnone)))
  	(setq Goctaidiemgiao (angle '(0 0) (Vlax-curve-getfirstderiv VLA:ObjPline (vlax-curve-getParamAtPoint VLA:ObjPline PntGiao))))
  	(setq KQVG nil)
	(if (or (equal (+ Goctaidiemgiao (/ pi 2)) GocP1P2 0.00000000001) (equal (- Goctaidiemgiao (/ pi 2)) GocP1P2 0.00000000001)
	        (equal (+ Goctaidiemgiao (/ pi 2)) GocP2P1 0.00000000001) (equal (- Goctaidiemgiao (/ pi 2)) GocP2P1 0.00000000001))
	    (setq KQVG 1)
	    (setq KQVG 0)
        )
  KQVG
)


(defun PointLeftRightPline (ObjPline Pnt / PVG Pd1 Pd2);;;;XET DIEM NAM TRAI HAY PHAI PLINE
    (setq PVG (vlax-curve-getClosestPointTo ObjPline Pnt)
          Pd1 (vlax-curve-getpointAtParam ObjPline (fix (vlax-curve-getparamatPoint ObjPline PVG)))
          Pd2 (vlax-curve-getpointAtParam ObjPline (1+ (fix (vlax-curve-getparamatPoint ObjPline PVG))))
    )
    (setq Kqua nil)
    (if (or (equal (cos (+ (/ pi 2) (angle Pd1 Pd2))) (cos (angle Pnt PVG)) 0.00000001)
   	    (equal (sin (+ (/ pi 2) (angle Pd1 Pd2))) (sin (angle Pnt Pd1)) 0.00000001)
	)
        (setq Kqua -1)
        (setq Kqua 1)
    )
    Kqua
)




Hề hề hề,

Lên biên giới buôn CAD hay buôn lisp vậy bác Duân ơi????


  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#17 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 995 Bài viết
Điểm đánh giá: 223 (khá)

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

 

Hề hề hề,

Lên biên giới buôn CAD hay buôn lisp vậy bác Duân ơi????

 

Nhớ bác lắm bác @Phamthanhbinh à! Xin lỗi bác vì thời gian em vắng bóng. Hic hic


  • 1



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn