Nhờ viết Lsp xuất toạ độ tâm block

[Nhờ viết Lsp xuất toạ độ tâm block]

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

Cảm ơn bác Duân và Phạm Yến đã viết và chia sẻ! Mình vừa tải về nhưng lúc chạy thử thì báo lỗi! Thật làm phiền các bạn lần nữa nhé

Bạn ấy gửi thiếu hàm!
 

(defun C:00 (/ DEM I LTSBL LTSDONG SSBL TDO)
;;;;;;;XUAT TOA DO BLOCK
  (vl-load-com)
  (setvar "CMDECHO" 0)
  (setq ssBl (ssget (list (cons 0 "INSERT"))))
  (if ssBl
    (progn
      (setq LtsBl (acet-ss-to-list ssBl))
      (setq LtsDong nil)
      (setq i 1)
      (foreach eBl LtsBl
	(setq Tdo (cdr (assoc 10 (entget eBl))))
	(setq LtsDong (append LtsDong
			      (list (list (rtos i 2 0)
					  (rtos (cadr Tdo) 2 3)
					  (rtos (car Tdo) 2 3)
					  (rtos (caddr Tdo) 2 3)
				    )
			      )
		      )
	)
	(setq i (1+ i))
      )

      (setq Dem (length LtsDong))
      (alert
	(strcat	"\nC\U+00F3 t\U+1EA5t c\U+1EA3 "
		(rtos Dem 2 0)
		" \U+0111\U+01B0\U+1EE3c xu\U+1EA5t t\U+1ECDa \U+0111\U+1ED9"
	)
      )
      (if (/= Dem 0)
	(progn
	  (if (vlax-get-or-create-object "Excel.Application")
	    (WriteToExcel LtsDong)
	    (WriteToCSV LtsDong)
	  )
	)
      )
    )
  )

  (princ)
)
(defun WriteToExcel (lst_data / col row x xlApp xlCells)
  (setq	xlApp	(vlax-get-or-create-object "Excel.Application")
	xlCells	(vlax-get-property
		  (vlax-get-property
		    (vlax-get-property
		      (vlax-invoke-method
			(vlax-get-property xlApp "Workbooks")
			"Add"
		      )
		      "Sheets"
		    )
		    "Item"
		    1
		  )
		  "Cells"
		)
  )
  (setq row 1)
  (foreach pt lst_data
    (setq col 1)
    (foreach coor pt
      (vlax-put-property xlCells 'Item row col coor)
      (setq col (1+ col))
    )
    (setq row (1+ row))
  )
  (vla-put-visible xlApp :vlax-true)
  (mapcar
    (function (lambda (x)
		(vl-catch-all-apply
		  (function (lambda ()
			      (if x
				(vlax-release-object x)
			      )
			    )
		  )
		)
	      )
    )
    (list xlCells xlApp)
  )
  (gc)
  (gc)
)

(defun WriteToCSV (lst_data / fl)
  (if (setq fl (getfiled "Output File" "" "csv" 1))
    (if	(setq fl (open fl "w"))
      (progn
	(foreach pt lst_data
	  (write-line
	    (LM:lst->str pt ",")
	    fl
	  )
	)
	(close fl)
      )
    )
  )
  (princ)
)
 ;|«Visual LISP© Format Options»
(200 2 60 2 nil "end of " 80 9 0 0 0 T T T T)
;*** DO NOT add text below the comment! ***|;

 

[Vấn đề mở nhanh các thư mục đường dẫn]

Bạn thay đường dẫn tới thư mục đó là xong!

(defun C:00()
(startapp "explorer" Path)
 (princ)
 )

 

[[Trợ giúp] - Lisp chèn, xoay block theo đường Plinle]

Chương trình này mình viết cũng lâu rồi. Nay có người hỏi nên quay video lại.

https://youtu.be/6rF29-wEp1M

 

Để lại địa chỉ Email mình sẽ gửi tặng.

Ai tham gia diễn đàn Trắc Địa Pro thì biết. Đừng ai nói mình copy sao chép nhé!

[Hướng dẫn lập trình Lisp]

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

Không khó như vậy đâu. Bạn phải nhận Đức liệu cho đủ. Rồi tính toán thành 8 điểm tương ứng. Sau đó rồi vẽ ra thôi.

Tham khảo thêm lệnh polar, angle là có thể tạo ra 1 lisp  đơn giản cho mình. Sau đó bổ sung thêm những thứ linh tinh như layer, nét vẽ.

Tuy nhiên mình thấy vẽ cầu thì nên vẽ bằng block động thì đơn giản hơn.

Viết lisp tạo block động khó không anh? Em nghĩ code sẽ rất dài. 
Thường thì em tạo block động trên Cad thôi.

 

[Xử lý khi in bản vẽ cad Text bị nhòe (do co chiều rộng để đủ khung BV)]

Bạn thử chui vào Block Editor ktra xem chữ có Z không? Những chữ nhoè thử dùng lệnh flatten. Cũng thử thay đổi factor trong properties xem sao,

[EM XIN GIÚP ĐỠ LISP THỐNG KÊ TỌA ĐỘ ĐIỂM]

5 giờ trước, thiep đã nói:

Đối tượng Table đó Thanhduan. Ok anh sẽ gửi cho đoạn mã lisp tạo table, bao gồm:

- Set text vào cell

- Set chiều cao row

- Set chiều rộng colomn

- Set màu đường lưới

- Merge các cell

Em cảm ơn bác nhiều!

[Hướng dẫn lập trình Lisp]

Đây là chương trình vẽ cầu

(defun C:VC (/ HUONGCAU KC LINE1 LINE2 MIDP12 MP1 MP2 OBJPL1 OBJPL2 P1 P2 P3 P4 P5)
;;;;VE CAU
  (MakeLayer_ "4_Giaothong_CAU" 7)
  (or *WidthPline* (setq *WidthPline* 0.50))
  (setq
    WidthPline
     (getreal
       (strcat "\nNh\U+1EADp \U+0111\U+1ED9 d\U+00E0y Width c\U+1EA7u   <"
	       (rtos *WidthPline* 2 2)
	       ">: "
       )
     )
  )
  (if (not WidthPline)
    (setq WidthPline *WidthPline*)
    (setq *WidthPline* WidthPline)
  )
  (or *Rau* (setq *Rau* 2.0))
  (setq
    Rau	(getdist
	  (strcat "\nNh\U+1EADp chi\U+1EC1u d\U+00E0i r\U+00E2u   <"
		  (rtos *Rau* 2 2)
		  ">: "
	  )
	)
  )
  (if (not Rau)
    (setq Rau *Rau*)
    (setq *Rau* Rau)
  )
  (setq P1 (getpoint "\nCh\U+1ECDn \U+0111i\U+1EC3m th\U+1EE9 nh\U+1EA5t: "))
  (setq P2 (getpoint P1 "\nCh\U+1ECDn \U+0111i\U+1EC3m th\U+1EE9 hai: "))
  (setq	P3 (getpoint
	     "\nCh\U+1ECDn \U+0111i\U+1EC3m th\U+1EE9 3 t\U+00EDnh \U+0111\U+1ED9 r\U+1ED9ng c\U+1EA7u: "
	   )
  )
  (setq HuongCau (CCW P1 P2 P3))
  (setq MidP12 (mid P1 P2))
  (MakeLine P1 P2 nil nil "4_Giaothong_CAU" nil nil)
  (setq Line1 (entlast))
  (setq	KC (distance P3
		     (vlax-curve-getClosestPointTo (vlax-ename->vla-object Line1) (trans P3 1 0))
	   )
  )
  (cond	((= HuongCau 1)
	 (Progn
	   (setq P4 (Polar P1 (+ (angle P1 P2) (/ (* 3 Pi) 4)) Rau))
	   (setq P5 (Polar P2 (+ (angle P1 P2) (/ Pi 4)) Rau))
	   (MakeLWPolyline (list P4 P1 P2 P5) nil nil nil "4_Giaothong_CAU" nil nil)
	   (setq ObjPl1 (entlast))
	   (setq Mp1 (Polar P1 (+ (angle P1 P2) (/ (* 3 Pi) 2)) (/ KC 2)))
	   (setq Mp2 (Polar P2 (+ (angle P1 P2) (/ (* 3 Pi) 2)) (/ KC 2)))
	   (MakeLine Mp1 Mp2 nil nil "4_Giaothong_CAU" nil nil)
	   (setq Line2 (entlast))
	 )
	)
	((= HuongCau -1)
	 (Progn
	   (setq P4 (Polar P1 (+ (angle P2 P1) (/ Pi 4)) Rau))
	   (setq P5 (Polar P2 (+ (angle P2 P1) (/ (* 3 Pi) 4)) Rau))
	   (MakeLWPolyline (list P4 P1 P2 P5) nil nil nil "4_Giaothong_CAU" nil nil)
	   (setq ObjPl1 (entlast))
	   (setq Mp1 (Polar P1 (+ (angle P2 P1) (/ (* 3 Pi) 2)) (/ KC 2)))
	   (setq Mp2 (Polar P2 (+ (angle P2 P1) (/ (* 3 Pi) 2)) (/ KC 2)))
	 )
	)
  )
  (vla-mirror
    (vlax-ename->vla-object ObjPl1)
    (vlax-3D-point Mp1)
    (vlax-3D-point Mp2)
  )
  (setq ObjPl2 (entlast))
  (vla-put-constantwidth (vlax-ename->vla-object ObjPl1) WidthPline)
  (vla-put-constantwidth (vlax-ename->vla-object ObjPl2) WidthPline)
  (entdel Line1)
  (entdel Line2)
  (Princ)
)

(defun C:VCC (/ HUONGCAU KC LINE1 LINE2 MIDP12 MP1 MP2 OBJPL1 OBJPL2 P1 P2 P3 P4 P5)
;;;;VE CONG
  (MakeLayer_ "4_Giaothong_CAU" 7)
  (or *WidthPline* (setq *WidthPline* 0.50))
  (setq
    WidthPline
     (getreal
       (strcat "\nNh\U+1EADp \U+0111\U+1ED9 d\U+00E0y Width c\U+1EA7u   <"
	       (rtos *WidthPline* 2 2)
	       ">: "
       )
     )
  )
  (if (not WidthPline)
    (setq WidthPline *WidthPline*)
    (setq *WidthPline* WidthPline)
  )
  (or *Rau* (setq *Rau* 0.5))
  (setq
    Rau	(getdist
	  (strcat "\nNh\U+1EADp chi\U+1EC1u d\U+00E0i r\U+00E2u   <"
		  (rtos *Rau* 2 2)
		  ">: "
	  )
	)
  )
  (if (not Rau)
    (setq Rau *Rau*)
    (setq *Rau* Rau)
  )
  (if (> Rau 0.5)
    (setq Rau 0.5)
  )
  (setq P1 (getpoint "\nCh\U+1ECDn \U+0111i\U+1EC3m th\U+1EE9 nh\U+1EA5t: "))
  (setq P2 (getpoint P1 "\nCh\U+1ECDn \U+0111i\U+1EC3m th\U+1EE9 hai: "))
  
  (setq HuongCau (CCW P1 P2 P2))
  (setq MidP12 (mid P1 P2))
  (MakeLine P1 P2 nil nil "4_Giaothong_CAU" nil nil)
  (setq Line1 (entlast))
  (setq	KC (distance P2
		     (vlax-curve-getClosestPointTo (vlax-ename->vla-object Line1) (trans P2 1 0))
	   )
  )
  (cond	((= HuongCau 1)
	 (Progn
	   (setq P4 (Polar P1 (+ (angle P1 P2) (/ (* 3 Pi) 4)) Rau))
	   (setq P5 (Polar P2 (+ (angle P1 P2) (/ Pi 4)) Rau))
	   (MakeLWPolyline (list P4 P1 P2 P5) nil nil nil "4_Giaothong_CAU" nil nil)
	   (setq ObjPl1 (entlast))
	   (setq Mp1 (Polar P1 (+ (angle P1 P2) (/ (* 3 Pi) 2)) (/ KC 2)))
	   (setq Mp2 (Polar P2 (+ (angle P1 P2) (/ (* 3 Pi) 2)) (/ KC 2)))
	   (MakeLine Mp1 Mp2 nil nil "4_Giaothong_CAU" nil nil)
	   (setq Line2 (entlast))
	 )
	)
	((= HuongCau -1)
	 (Progn
	   (setq P4 (Polar P1 (+ (angle P2 P1) (/ Pi 4)) Rau))
	   (setq P5 (Polar P2 (+ (angle P2 P1) (/ (* 3 Pi) 4)) Rau))
	   (MakeLWPolyline (list P4 P1 P2 P5) nil nil nil "4_Giaothong_CAU" nil nil)
	   (setq ObjPl1 (entlast))
	   (setq Mp1 (Polar P1 (+ (angle P2 P1) (/ (* 3 Pi) 2)) (/ KC 2)))
	   (setq Mp2 (Polar P2 (+ (angle P2 P1) (/ (* 3 Pi) 2)) (/ KC 2)))
	 )
	)
  )
  (vla-mirror
    (vlax-ename->vla-object ObjPl1)
    (vlax-3D-point Mp1)
    (vlax-3D-point Mp2)
  )
  (setq ObjPl2 (entlast))
  (vla-put-constantwidth (vlax-ename->vla-object ObjPl1) WidthPline)
  (vla-put-constantwidth (vlax-ename->vla-object ObjPl2) WidthPline)
  (entdel Line1)
  (entdel Line2)
  (Princ)
)



(defun mid (p1 p2)
  (mapcar '(lambda (x1 x2) (/ (+ x1 x2) 2.0)) p1 p2)
)
(defun LM:ss->ent (ss / i l)
  (if ss
    (repeat (setq i (sslength ss))
      (setq l (cons (ssname ss (setq i (1- i))) l))
    )
  )
)

(defun CV:List-to-ss (lst / ss)
  (setq ss (ssadd))
  (foreach item	lst
    (or	(= (type item) 'Ename)
	(setq item (vlax-vla-object->ename item))
    )
    (setq ss (ssadd item ss))
  )
  ss
)
;;;(LM:UniqueFuzz (list 1 2 3 4 4 4 5 5 5 3 6 7 7 7 7  9) 0.0001)
(defun LM:UniqueFuzz (l f)
  (if l
    (cons (car l)
	  (LM:UniqueFuzz
	    (vl-remove-if
	      (function (lambda (x) (equal x (car l) f)))
	      (cdr l)
	    )
	    f
	  )
    )
  )
)
(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 MakeLWPolyline
		      (listpoint closed Linetype LTScale Layer Color xdata / Lst)
  (setq	Lst (list (cons 0 "LWPOLYLINE")
		  (cons 100 "AcDbEntity")
		  (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 100 "AcDbPolyline")
		  (cons 90 (length listpoint))
		  (cons	70
			(if closed
			  1
			  0
			)
		  )
	    )
  )
  (foreach PP listpoint
    (setq Lst (append Lst (list (cons 10 PP))))
  )
  (if xdata
    (setq Lst (append lst (list (cons -3 (list xdata)))))
  )
  (entmakex Lst)
)
(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
			)
		  )
	    )
  )
)


;;;;;; XET DIEM BEN TRAI HAY PHAI DOAN THANG;;;;;;;;;;;;;;;;;;;
(defun CCW (P1 P2 P / CCW1 D DX DX0 DY DY0)
  (setq	dX  (- (car P) (car P1))
	dY  (- (cadr P) (cadr P1))
	dX0 (- (car P2) (car P1))
	dY0 (- (cadr P2) (cadr P1))
	d   (- (* dX dY0) (* dY dX0))
  )
  (if (>= d 0)
    (setq CCW1 1)
    (setq CCW1 -1)
  )
  CCW1
)

 

[EM XIN GIÚP ĐỠ LISP THỐNG KÊ TỌA ĐỘ ĐIỂM]

14 giờ trước, thiep đã nói:

Lisp này giúp cho những ai làm công tác đo đạc giải thửa, quy hoạch đất đai, tư vấn thăm dò khoáng sản...

 

Không biết bảng toạ độ bác là Table hay các line rời rạc ạ? Nếu là Table thì bác cho em xin đoạn lisp tạo table được không ạ? Em muốn tham khảo 1 vài nguồn để học tập.

Nếu bác cho phép thì bác gửi vào Email của em là: heaven2407@gmail.com

Em cảm ơn bác nhiều.

[Nhờ viết lisp (nối đường line có điều kiên)]

2 phút trước, Doan Van Ha đã nói:

Dùng 2 hàm này khá nguy hiểm. Tuy là equal nhưng bản chất chưa hẳn equal:

(equal ang1 ang2 (* pi (/ delta180 180.0)))
(equal (* 2 pi) (abs (- ang1 ang2)) (* pi (/ delta180 180.0)))

Dạ. Cháu cảm ơn bác Hạ nhiều.

[Nhờ viết lisp (nối đường line có điều kiên)]

Sao lại nhập 180 độ?  179 hay 181 so với 180 là chênh 1 độ. Nó bảo nhập góc chênh thì nhập 1,2,3.....chứ

Nó áp dụng với LWPolyline.

[Nhờ viết lisp (nối đường line có điều kiên)]

Của bạn đây! Áp dụng với Polyline. 

(defun C:XDTHPL	(/ LTSPLINE SSPLINE X) ;;;XDTHPL
  (defun *error* (msg)
    (if	Olmode
      (setvar 'osmode Olmode)
    )
    (if	(not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
      (princ (strcat "\nError: " msg))
    )
    (princ)
  )
  (command "undo" "begin")
  (setq Olmode (getvar "OSMODE"))
  (setvar "OSMODE" 0)
  (setq	Gocchenh
	 (LM:GetXWithDefault
	   getreal
	   "\nNh\U+1EADp g\U+00F3c ch\U+00EAnh v\U+1EDBi 180 \U+0111\U+1ED9 (1,2,3...10 \U+0111\U+1ED9) \U+0111\U+01B0\U+1EE3c coi l\U+00E0 th\U+1EB3ng h\U+00E0ng:  "
	   '*Gocchenh0*
	   0.0
	 )
  )
  (setq ssPline (ssget '((0 . "*POLYLINE"))))
  (if ssPline
    (progn
      (setq LtsPline (LM:ss->ent ssPline))
      (mapcar '(lambda (x) (XDTHPL x Gocchenh)) LtsPline)
    )
  )
  (setvar "OSMODE" Olmode)
  (command "undo" "end")
  (princ)
)

(defun XDTHPL (pl delta180 / ANG1 ANG2 BUL1 BUL2 BULST CERALST1	CERALST2 ELST ELST1 ELST2 ELST3	I K M N	NBUL OBUL PLOB PLST PLST1 RA REC1 VTT1 VTT2)
  (setq	plst  (acet-geom-vertex-list pl)
	plob  (vlax-ename->vla-object pl)
	elst  (entget pl)
	bulst (list)
	plst1 plst
	elst1 (list)
	elst2 (list)
	elst3 (list)
  )
  (foreach a elst
    (if	(= (car a) 42)
      (setq bulst (append bulst (list (cdr a))))
    )
  )
  (setq	k (vl-position (cons 10 (reverse (cdr (reverse (car plst))))) elst)
	i 0
  )
  (while (< i k)
    (setq elst1	(append elst1 (list (nth i elst)))
	  i	(1+ i)
    )
  )
  (foreach vrt (if (= (cdr (assoc 70 elst)) 1)
		 (reverse (cdr (reverse plst)))
		 plst
	       )
    (setq k (vl-position (cons 10 (reverse (cdr (reverse vrt)))) elst))
    (setq elst2	(append	elst2
			(list
			  (list (nth k elst) (nth (+ k 1) elst) (nth (+ k 2) elst) (nth (+ k 3) elst))
			)
		)
    )
  )
  (setq m (cdr (assoc 90 elst)))
  (foreach vrt plst
    (setq i (vl-position vrt plst))
    (if	(> i 0)
      (progn
	(setq vtt1 (vlax-curve-getFirstDeriv
		     plob
		     (vlax-curve-getParamAtPoint plob (nth (1- i) plst))
		   )
	)
	(setq vtt2 (vlax-curve-getFirstDeriv plob (vlax-curve-getParamAtPoint plob vrt)))
	(setq bul1 (nth (1- i) bulst)
	      bul2 (nth i bulst)
	)
	(setq ang1 (angle '(0 0 0) vtt1)
	      ang2 (angle '(0 0 0) vtt2)
	)
	(if (and (= bul1 0.0)
		 (= bul2 0.0)
		 (or (equal ang1 ang2 (* pi (/ delta180 180.0)))
		     (equal (* 2 pi) (abs (- ang1 ang2)) (* pi (/ delta180 180.0)))
		 )
		 (nth (1+ i) plst)
	    )
	  (setq	plst1 (vl-remove vrt plst1)
		m     (1- m)
	  )
	)

	(if (and (/= bul2 0.0) (/= bul1 0.0))
	  (progn
	    (setq ceralst1 (bulgecenter bul1 (nth (1- i) plst) (nth i plst))
		  ceralst2 (bulgecenter bul2 (nth i plst) (nth (1+ i) plst))
	    )
	    (if	(and (equal (car ceralst1) (car ceralst2) 1e-8)
		     (equal (last Ceralst1) (last ceralst2) 1e-8)
		)
	      (setq plst1 (vl-remove vrt plst1)
		    m	  (1- m)
	      )
	    )
	  )
	)
      )
    )
  )
  (if (= (cdr (assoc 70 elst)) 1)
    (setq plst1 (reverse (cdr (reverse plst1))))
  )
  (foreach vrt plst1
    (foreach rec elst2
      (if (equal (cdar rec) (reverse (cdr (reverse vrt))) 1e-8)
	(setq elst3 (append elst3 (list rec)))
      )
    )
  )
  (foreach rec elst3
    (if	(/= (setq obul (cdr (last rec))) 0.0)
      (progn
	(setq k	   (vl-position rec elst3)
	      n	   (vl-position obul bulst)
	      ra   (car (bulgecenter obul (nth n plst) (nth (1+ n) plst)))
	      nbul (bulge ra (nth k plst1) (nth (1+ k) plst1))
	)
	(if (< obul 0)
	  (setq nbul (- 0 nbul))
	)
	(setq rec1  (subst (cons 42 nbul) (assoc 42 rec) rec)
	      elst3 (subst rec1 rec elst3)
	)
      )
    )
  )
  (foreach rec elst3
    (setq elst1 (append elst1 rec))
  )
  (setq elst (append elst1 (list (cons 210 '(0.0 0.0 1.0)))))
  (setq elst (subst (cons 90 m) (assoc 90 elst) elst))
  (entmod elst)
)
(defun LM:ss->ent (ss / i l)
  (if ss
    (repeat (setq i (sslength ss))
      (setq l (cons (ssname ss (setq i (1- i))) l))
    )
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun BulgeCenter (bulge p1 p2 / delta chord radius center)
  (setq	delta	(* (atan bulge) 4)
	chord	(distance p1 p2)
	radius	(/ chord (sin (/ delta 2)) 2)
	center	(polar p1 (+ (angle p1 p2) (/ (- pi delta) 2)) radius)
	Ceralst	(list center radius)
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun bulge (cen p1 p2 / anp)
  (setq	anp (atan (/ (distance p1 p2) 2 (distance cen (midpt p1 p2))))
	bul (/ (sin (/ anp 2)) (cos (/ anp 2)))
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun midpt (p1 p2)
  (setq pt (mapcar '(lambda (x y) (/ (+ x y) 2)) p1 p2))
)

(defun LM:GetXWithDefault (_function _prompt _symbol _default / _toString)
  ;; © Lee Mac 2010

  (setq	_toString
	 (lambda (x)
	   (cond
	     ((eq getangle _function) (angtos x))
	     ((eq 'REAL (type x)) (rtos x))
	     ((eq 'INT (type x)) (itoa x))
	     (x)
	   )
	 )
  )

  (set _symbol
       (
	(lambda	(input)
	  (if (or (not input) (eq "" input))
	    (eval _symbol)
	    input
	  )
	)
	 (_function (strcat _prompt
			    "<"
			    (_toString (set _symbol
					    (cond ((eval _symbol))
						  (_default)
					    )
				       )
			    )
			    "> : "
		    )
	 )
       )
  )
)

 

[Ảnh của thành viên]

Diễn đàn mình lâu lắm rồi không thấy ai ló mặt. 

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

54 phút trước, quocmanh04tt đã nói:

Làm luôn! dần dà chi nữa…! kkk...

Dạ, tại em phải đi làm. Lúc nào rảnh mới ngồi xem được. Em vẫn còn gà mờ về table này lắm. 
Việc Mergecell này là khi đã có Table rồi. Em muốn vẽ Table từ tệp cấu trúc dữ liệu. Chắc phải nghiên cứu dài dài mới làm được bác ạ.

Không biết bác @quocmanh04tt có đoạn code mẫu nào cho em học tập được không ạ?

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

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

 

@thanhduan2407Để mergecell bạn dùng hàm này xử lý cho từng thằng

(vl-catch-all-apply
		   (function (lambda () (vla-MergeCells VlaObj minRow maxRow minCol maxCol )))
		 )

minRow maxRow minCol maxCol là số hàng, cột để xác định phạm vi các ô cần merge

Cảm ơn bác đã trả lời. Em sẽ tìm hiểu dần.

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

Các bác cho em hỏi chút ạ!

Em rất muốn tạo bảng Table như trong hình nhưng đang vướng 1 số chỗ. Rất mong các bác cho em lời tư vấn hoặc giới thiệu cho em một vài hàm hoặc 1 số trang web có tài liệu em nghiên cứu. Việc tạo table với cấu trúc file đơn giản như STT X Y Z CODE thì em nghiên cứu hàm Addtable của Lee-Mac em làm được rồi. Nhưng cấu trúc file phức tạp như trong hình thì hơi khó. Rất mong các bác tương trợ. Cảm ơn các bác nhiều.

https://i844.photobucket.com/albums/ab7/thanhduan2407/Screenshot_1_zpsj03s9mz8.jpg

[[NHẮN TÌM ĐỒNG ĐỘI] Tìm người yêu thích lập trình CAD]

Cho anh tham gia và học hỏi với @ketxu

[đo khoảng cách từ đoạn thẳng 1 kéo dài đến đoạn thẳng 2]

Mình viết hơi dài nhưng tạm dùng

(defun C:00 (/ A DELTA LTSINTERS LTSSORT OBJKHUNG OBJLINE P1 P1A P1B P2	P2A P2B	PMID S1	S2 VBADIM )
  (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)
  (setq	ObjKhung
	 (car
	   (LM:SelectIf
	     "\nCh\U+1ECDn khung: "
	     (lambda (x) (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car x))))))
	     entsel
	     nil
	   )
	 )
  )
  (setq	ObjLine
	 (car
	   (LM:SelectIf
	     "\nCh\U+1ECDn Line: "
	     (lambda (x) (eq "LINE" (cdr (assoc 0 (entget (car x))))))
	     entsel
	     nil
	   )
	 )
  )
  (setq	Delta (LM:GetXWithDefault
		getdist
		"\nNh\U+1EADp s\U+1ED1 b\U+1ECB tr\U+1EEB: "
		'*Delta*
		5.0
	      )
  )
  (setq P1A (cdr (assoc 10 (entget ObjLine))))
  (setq P2A (cdr (assoc 11 (entget ObjLine))))
  (setq	LtsInters (LM:Intersections
		    (vlax-ename->vla-object ObjLine)
		    (vlax-ename->vla-object ObjKhung)
		    acextendthisentity
		  )
  )
  (setq LtsSort (SortAB (append LtsInters (list P1A P2A))))
  (if (< (vl-position P1A LtsSort) (vl-position P2A LtsSort))
    (progn
      (setq P1 P1A)
      (setq P2 P2A)
    )
    (progn
      (setq P1 P2A)
      (setq P2 P1A)
    )
  )
  (if (/= (vl-position P1 LtsSort) 0)
    (progn
      (setq P1B (nth (- (vl-position P1 LtsSort) 1) LtsSort))
      (setq P2B (nth (+ (vl-position P2 LtsSort) 1) LtsSort))
      (setq S1 (distance P1 P1B))
      (setq S2 (distance P2 P2B))
      (if (< S1 S2)
	(progn

	  (setq Pmid (mid2Pnt P1 P1B))
	  (makedimrot P1 P1B Pmid (GochuongBac P1 P1B))
	  (setq VbaDIM (vlax-ename->vla-object (entlast)))
	  (setq a (- (vla-get-Measurement VbaDIM) Delta))
	  (vla-put-TextOverride VbaDIM (rtos a 2 2))
	)
	(progn
	  (setq Pmid (mid2Pnt P2 P2B))
	  (makedimrot P2 P2B Pmid (GochuongBac P2 P2B))
	  (setq VbaDIM (vlax-ename->vla-object (entlast)))
	  (setq a (- (vla-get-Measurement VbaDIM) Delta))
	  (vla-put-TextOverride VbaDIM (rtos a 2 2))
	)
      )
    )
  )
  (setvar "OSMODE" Olmode)
  (princ)
)

(defun makedimrot (p1 p2 locpt dimang / elist)
  (setq	elist (list
		'(0 . "DIMENSION")
		'(100 . "AcDbEntity")
		(cons '8 (getvar "clayer"))
		'(100 . "AcDbDimension")
		(cons '10 locpt)
		'(11 0.0 0.0 0.0)
		'(12 0.0 0.0 0.0)
		'(70 . 32)
		'(52 . 0.0)
		'(53 . 0.0)
		'(54 . 0.0)
		'(51 . 0.0)
		'(210 0.0 0.0 1.0)
		(cons '3 (getvar "dimstyle"))
		'(100 . "AcDbAlignedDimension")
		(cons '13 p1)
		(cons '14 p2)
		(cons '50 dimang)
		'(100 . "AcDbRotatedDimension")
	      )
  )
  (entmake elist)
)

(defun mid2Pnt (p1 p2)
  (mapcar '(lambda (x1 x2) (/ (+ x1 x2) 2.0)) p1 p2)
)
(defun GochuongBac (P1 P2 / Goc)
  (setq Goc (angle P1 P2))
  (if (or (<= 0 Goc (/ pi 2))
	  (<= (/ (* 3 pi) 2) Goc (* 2 pi))
      )
    (setq GocOK Goc)
    (setq GocOK (+ Goc pi))
  )
  GocOK
)
(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)
)
(defun SortAB (lstPnt /)
  (setq	Lts-Sort
	 (vl-sort (vl-sort lstPnt
			   '(lambda (e1 e2) (< (cadr e1) (cadr e2)))
		  )
		  '(lambda (e1 e2) (< (car e1) (car e2)))
	 )
  )
  Lts-Sort
)
(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 LM:SelectIf (msg pred func keyw / sel)
  (setq pred (eval pred))
  (while
    (progn
      (setvar 'ERRNO 0)
      (if keyw
	(apply 'initget keyw)
      )
      (setq sel (func msg))
      (cond
	((= 7 (getvar 'ERRNO))
	 (princ
	   "\nB\U+1EA1n ch\U+1ECDn sai r\U+1ED3i! H\U+00E3y ch\U+1ECDn l\U+1EA1i."
	 )
	)
	((eq 'STR (type sel))
	 nil
	)
	((vl-consp sel)
	 (if (and pred (not (pred sel)))
	   (princ "")
	 )
	)
      )
    )
  )
  sel
)
(defun LM:GetXWithDefault (_function _prompt _symbol _default / _toString)
  ;; © Lee Mac 2010

  (setq	_toString
	 (lambda (x)
	   (cond
	     ((eq getangle _function) (angtos x))
	     ((eq 'REAL (type x)) (rtos x))
	     ((eq 'INT (type x)) (itoa x))
	     (x)
	   )
	 )
  )

  (set _symbol
       (
	(lambda	(input)
	  (if (or (not input) (eq "" input))
	    (eval _symbol)
	    input
	  )
	)
	 (_function (strcat _prompt
			    "<"
			    (_toString (set _symbol
					    (cond ((eval _symbol))
						  (_default)
					    )
				       )
			    )
			    "> : "
		    )
	 )
       )
  )
)

 

[Virus acad.fas]

Em đã diệt thành công!

 

Hướng dẫn Diệt Virus Prlst.fas Và Acad.fas

Khi mở 1 file bản vẽ, virus sẽ copy 2 file acad.fas và prlst.fas vào thư mục hệ thống và thư mục chứa file bản vẽ. Sửa 2 file acad2007.lsp và acad2007doc.lsp trong thư mục "C:\Program Files\AutoCAD 2007\Support" để tự động lây nhiễm sang thư mục khác.

Cách diệt:

Bước 1: - Tìm và xóa hết các file acad.fas và prlst.fas trong tất cả các ổ đĩa máy tính.

Bước 2: - Tải về công cụ tại đây: http://www.mediafire.com/file/bmtto8vurt4hjfp/Diet_virus_acad.fas_va_prlst.fas.rar

 

Bước 3: - Giải nén và chép đè 2 file acad2007.lsp , acad2007doc.lsp trong thư mục tải về vào thư mục cài đặt autocad theo đường dẫn sau:

a) với windows 32bit: C:\Program Files\AutoCAD 2007\Support

b) với windows 64bit: C:\Program Files(x86)\AutoCAD 2007\Support

Ghi chú: với các phiên bản Autocad khác thì mở file acad20xx.lsp , acad20xxdoc.lsp bằng phần mềm soạn thảo Notepad sửa lại nội dung 2 file acad20xx.lsp , acad20xxdoc.lsp trong thư mục trên như sau:

Chép đoạn mã diệt virus ở cuối 2 file acad2007.lsp , acad2007doc.lsp và dán vào 2 file  acad20xx.lsp , acad20xxdoc.lsp tương ứng, lưu lại.

[Xin lisp chuyển mỗi đối tượng sang mỗi layer khác nhau.]

Đây nhé bạn!
 

(defun C:00 (/ i)
  (setq i 1)
  (while (< i 256)
    (_layer2 (rtos i 2 0) i)
    (setq i (1+ i))
  )
  (princ)
)
(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)
      )
    )
  )
)

 

[Virus acad.fas]

Dạo này em dính con virus acad.fas này. Bực mình quá cơ. Cứ bật Cad lên là nó xuất hiện. Không tài nào xoá hết được vì cứ bật bản cad lên là nó hiện. Nhưng ở dạng ẩn (mờ).

Nhờ các bác chỉ dùm cách xử lý nó với ạ

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

Cảm ơn tất cả các bác đã hỗ trợ em

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

Vừa xong, Doan Nguyen Van đã nói:

Cộng mỗi z, còn x với y thì lấy thế nào a

Giống như khi Z<2. lấy X của thằng đầu và Y của thằng Z>2

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

Vừa xong, Doan Nguyen Van đã nói:

Lúc đầu e k biết có lấy số z<2 không nên viết thế, cộng lại vẫn < 2 nếu bỏ đi thì a sửa lại như thế này

• cadvietlisp.lsp
  
• [✎]
   

(defun tachlist (lst / lst1 z x y l1)
  (setq lst1 (list) z 0 )
  (while (setq l1 (car lst))
    (setq lst (cdr lst))
    (if (< (caddr l1) 2.0) (if (= z 0) (setq x (car l1) y (cadr l1) z (caddr l1)) (setq y (cadr l1) z (+ z (caddr l1))))
		(if (< z 2) (Setq lst1 (append lst1 (list l1)) z 0) (Setq lst1 (append lst1 (list (list x y z) l1)) z 0)))
    )
  lst1
  )

 

Em có thể chỉnh sửa lại 1 chút được không? Nếu tổng Z < 2 mà tìm thấy Z > 2 thì cộng gộp luôn.

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

15 phút trước, Doan Nguyen Van đã nói:

Bất quá, hàm này vẫn lấy ra cả phần tử có z < 2 nếu trong list các vị trí z=1 không đứng cạnh nhau bác ạ

Chuẩn rồi em. Nếu không đứng cạnh nhau nó vẫn lấy. Anh quên mất là trường hợp đó nữa

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

12 phút trước, Doan Nguyen Van đã nói:

Bất quá, hàm này vẫn lấy ra cả phần tử có z < 2 nếu trong list các vị trí z=1 không đứng cạnh nhau bác ạ

Anh dùng nó OK mà.

(defun C:00 (/ I L1 L2 LOOP LTSPNT OBJTUYEN P0 P1 P2 S0 SDOAN)
  (vl-load-com)
  (setvar "CMDECHO" 0)
  (setq	ObjTuyen
	 (car
	   (LM:SelectIf
	     "\nCh\U+1ECDn Polyline:  "
	     (lambda (x)
	       (eq "LWPOLYLINE"
		   (cdr (assoc 0 (entget (car x))))
	       )
	     )
	     entsel
	     nil
	   )
	 )
  )
  (setq LtsPnt (acet-geom-vertex-list ObjTuyen))
  (setq L1 (list))
  (setq i 0)
  (while (< i (- (length LtsPnt) 1))
    (setq Sdoan	(- (vlax-curve-getDistAtParam ObjTuyen (+ i 1))
		   (vlax-curve-getDistAtParam ObjTuyen i)
		)
    )
    (setq L1 (append L1 (list (list (+ i 1) (+ i 2) Sdoan))))
    (setq i (1+ i))
  )
  (princ (tachlist L1))
  (princ)
)
(defun tachlist	(lst / lst1 z x y l1)
  (setq	lst1 (list)
	z    0
  )
  (while (setq l1 (car lst))
    (setq lst (cdr lst))
    (if	(< (caddr l1) 2.0)
      (if (= z 0)
	(setq x	(car l1)
	      y	(cadr l1)
	      z	(caddr l1)
	)
	(setq y	(cadr l1)
	      z	(+ z (caddr l1))
	)
      )
      (if (= z 0)
	(Setq lst1 (append lst1 (list l1)))
	(Setq lst1 (append lst1 (list (list x y z) l1))
	      z	   0
	)
      )
    )
  )
  lst1
)
(defun LM:GetXWithDefault (_function _prompt _symbol _default / _toString)
  ;; © Lee Mac 2010

  (setq	_toString
	 (lambda (x)
	   (cond
	     ((eq getangle _function) (angtos x))
	     ((eq 'REAL (type x)) (rtos x))
	     ((eq 'INT (type x)) (itoa x))
	     (x)
	   )
	 )
  )

  (set _symbol
       (
	(lambda	(input)
	  (if (or (not input) (eq "" input))
	    (eval _symbol)
	    input
	  )
	)
	 (_function (strcat _prompt
			    "<"
			    (_toString (set _symbol
					    (cond ((eval _symbol))
						  (_default)
					    )
				       )
			    )
			    "> : "
		    )
	 )
       )
  )
)