- page 285

Info

File

Tác giả: khaosat2009
Bài viết gốc: 109537
Tên lệnh: xscale xsc

Đây là đọan code scale đối tượng một chiều
Lệnh là XSC hoặc XSCALE
;Scale the mot chieu
(DEFUN EXCUTE()
 (setq oldvalue (getvar...
>>
Đây là đọan code scale đối tượng một chiều
Lệnh là XSC hoặc XSCALE
;Scale the mot chieu
(DEFUN EXCUTE()
 (setq oldvalue (getvar "CMDECHO"))
 (setvar "CMDECHO" 0)
 (princ "Chon doi tuong can scale: ")
 (setq ss (ssget))
 (setq P0 (getpoint "\nChon diem goc: "))
 (initget 1 "X Y X S")
 (setq C (getkword "\nScale theo ? :"))
 (setq hs (getreal "Cho biet he so scale: "))
 (DELBLOCK "vkc_temp")
 (CREATEBLOCK ss P0)  
 (Command "-Insert" "vkc_temp" C hs P0 "")   
 (setq dt (entlast))
 (Command "Explode" dt)
 (setvar "CMDECHO" oldvalue)
 (princ)
)
(DEFUN CREATEBLOCK(ss P)
 (command "-Block" "vkc_temp" P ss "")
)

(DEFUN DELBLOCK (bname)
 (if (IsExistBlock bname)
(Command "-Purge" "B" bname "Y" "Y")	
 )
)
(DEFUN IsExistBlock(bname / kq)
 (setq kq Nil)
 (setq n (length LiBlk))
 (setq i 0)
 (while (< i n)
(if (= bname (nth i LiBlk))
  (progn
(setq i n)
(setq kq T)
  )	
)
(setq i (1+ i))
 )
 kq
)
(DEFUN CREALIBLK (/ NL)
 (setq LiBlk (List))
 (setq NL (tblnext "BLOCK" T))  
 (while NL	
(setq LiBlk (append LiBlk (list (cdr (assoc 2 NL)))))
(setq NL (tblnext "BLOCK"))
 )
 (setq LiBlk (Acad_strlsort LiBlk))
)
(DEFUN C:XSCALE()
 (CREALIBLK)
 (EXCUTE)
)
(DEFUN C:XSC()
 (CREALIBLK)
 (EXCUTE)
)
Anh Hoành ơi, làm ơn giúp mình một Lisp dùng trong công tác nắn bản vẽ Ảnh.

Ví dụ như mình có một tờ bản đồ ảnh trên đó thể hiện các hình thể địa hình tự nhiên, sau khi đo đạc vào các điểm chuẩn trên ảnh tương ứng ngoài thực tế có tọa độ có tọa độ các điểm, chuyển điểm lên Cad.

Mình muốn nhờ anh giúp lisp : yêu cầu load ảnh vào, chọn điểm trên ành chỉ vảo điểm cần nắn đến, ... chọn nhiều điểm càng tốt.

Khi thực hiện thì lisp kéo ra hoặc thu lại các điểm của ảnh vào đúng vị trí các điểm trên cad.

Mong được anh giúp

<<

Download lisp

Filename: 109537_xscale_xsc.lsp

Tác giả: tientracdia
Bài viết gốc: 222971
Tên lệnh: xt2ex

chuyển số liệu text từ cad sang excell

Chú ý là các đa giác phải cùng màu và cùng lớp với circle nhé.


(defun c:xt2ex (/ oldos sslst tlst filename f...
>>

Chú ý là các đa giác phải cùng màu và cùng lớp với circle nhé.


(defun c:xt2ex (/ oldos sslst tlst filename f sslst1 C1 C2 C3 C4 C5 C6 C7 C8 )
(vl-load-com)
(command "undo" "be")
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq sslst (acet-ss-to-list (ssget (list (cons 0 "LWPOLYLINE") (cons 62 63) (cons 8 "Main_tach_o"))))
         tlst ""   )
(setq filename (getfiled "Select a File" "" "csv" 1))
(setq f (open filename "w"))
(write-line "Main_STT,Main_H_Dap,Main_S_Dap,Main_V_Dap,Main_H_Dao,Main_S_Dao,Main_V_Dao,Main_S_O," f)
(foreach e sslst
	(setq sslst1 (acet-ss-to-list (ssget "wp" (acet-geom-vertex-list e)
                                                                         (list (cons 0 "text")) 	))  )
	(setq C1 nil C2 nil C3 nil C4 nil C5 nil C6 nil C7 nil C8 nil)
	(foreach en sslst1
                 (if (= (cdr (assoc 8 (entget en))) "Main_STT")
                     (setq C1 (cdr (assoc 1 (entget en))) )
                 )
	)
	(foreach en sslst1
                 (if (= (cdr (assoc 8 (entget en))) "Main_H_Dap")
                     (setq C2 (cdr (assoc 1 (entget en))) )
                 )
	)
	(foreach en sslst1
                 (if (= (cdr (assoc 8 (entget en))) "Main_S_Dap")
    				(setq C3 (cdr (assoc 1 (entget en))) )
                 )
	)
	(foreach en sslst1
                 (if (= (cdr (assoc 8 (entget en))) "Main_V_Dap")
                     (setq C4 (cdr (assoc 1 (entget en))) )
                 )
	)
	(foreach en sslst1
                 (if (= (cdr (assoc 8 (entget en))) "Main_H_Dao")
                     (setq C5 (cdr (assoc 1 (entget en))) )
                 )
	)
	(foreach en sslst1
                 (if (= (cdr (assoc 8 (entget en))) "Main_S_Dao")
    				(setq C6 (cdr (assoc 1 (entget en))) )
                 )
	)
	(foreach en sslst1
                 (if (= (cdr (assoc 8 (entget en))) "Main_V_Dao")
                     (setq C7 (cdr (assoc 1 (entget en))) )
                 )
	)

	(foreach en sslst1
                 (if (= (cdr (assoc 8 (entget en)))  "Main_S_O")
    				(setq C8 (cdr (assoc 1 (entget en))) )
                 )
	)
	(setq tlst (strcat (if C1 C1 " ") (chr 44) (if C2 C2 " ") (chr 44) (if C3 C3 " ") (chr 44) (if C4 C4 " ") (chr 44)
                                   (if C5 C5 " ") (chr 44) (if C6 C6 " ") (chr 44) (if C7 C7 " ") (chr 44) (if C8 C8 " ") (chr 44) ))
	(write-line tlst f)
	(setq tlst "")
)
(close f)
(setvar "osmode" oldos)
(command "undo" "e")
(princ)
)

Vẩn không xuất ra cvs được bạn ơi

Nhưng tại sao mình lại chuyển cùng màu và cùng lớp vậy bạn ?

khi đã thay đổi

(setq sslst (acet-ss-to-list (ssget (list (cons 0 "LWPOLYLINE") (cons 62 63) (cons 8 "Main_tach_o"))))

tlst "" )

http://www.cadviet.com/upfiles/3/114381_ycau4.dwg

Download lisp

Filename: 222971_xt2ex.lsp

Tác giả: akita13
Bài viết gốc: 133979
Tên lệnh: itest

kiểm tra một điểm có nằm trong đa giác hay không?

Bác cứ nghiên cứu đoạn Autolisp này thử nhé

;;======================================================================;;
;;	DETERMINING IF A POINT LIES ON THE INTERIOR OF A POLYGON	;;
;;======================================================================;;

(defun insidep (pt ent / big flag obj1 obj2 obj3 p1 p2 small)
 (vl-load-com)
 (if (and pt ent)
   (progn
     (setq obj1 (vlax-ename->vla-object (car ent)))
     (setq obj2 (car (vlax-invoke obj1 'Offset 0.001))
    obj3 (car (vlax-invoke obj1 'Offset -0.001)))
     (if (> (vla-get-area obj2)(vla-get-area obj3))
(progn
  (set 'big obj2)
  (set 'small obj3))
(progn
  (set 'big obj3)
  (set 'small obj2)))
     (setq p1 (vlax-curve-getClosestPointTo big pt)
    p2 (vlax-curve-getClosestPointTo small pt))
     (if (> (distance pt p1)(distance pt p2))
(setq flag T)
(setq flag nil))
     (mapcar (function (lambda (x)
		  (progn
		    (vla-delete x)
		    (vlax-release-object x))))
      (list big small))
     )
   )
 flag
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun @Inside (PIQ	 Object	  /	   ClosestPoint
	ClosestParam	  Sample   Start    End	     P1
	P2	 P	  a1	   a2	    Defl
       )

 (setq Sample 0.2)

 (vl-load-com)
 (or (= (type @delta) 'SUBR)
     (defun @delta (a1 a2)
(cond
  ((> a1 (+ a2 pi))
   (+ a2 pi pi (- a1))
  )
  ((> a2 (+ a1 pi))
   (- a2 a1 pi pi)
  )
  (1 (- a2 a1))
)
     )
 )
 (and
   (cond
     ((not Object)
      (prompt "  No object provided.")
     )
     ((= (type Object) 'VLA-Object))
     ((= (type Object) 'Ename)
      (setq Object (vlax-ename->vla-object Object))
     )
     (1 (prompt "  Improper object type."))
   )
   (or
     (and
(< 1 (vl-list-length PIQ) 4)
(vl-every 'numberp PIQ)
     )
     (prompt " Improper point value.")
   )
   (or
     (not
(vl-catch-all-error-p
  (setq	Start
	 (vl-catch-all-apply
	   'vlax-curve-getStartPoint
	   (list Object)
	 )
  )
)
     )
     (prompt "  Object is not a curve.")
   )
   (or
     (equal Start (vlax-curve-getendpoint Object) 1e-10)
     (prompt "  Curve is not closed.")
   )
   (setq P (trans PIQ 1 0))		; PIQ in WCS
   (setq ClosestPoint
   (vlax-curve-getclosestpointto Object P) ; In WCS
   )
   (not (equal P ClosestPoint 1e-10))	; in WCS
   (setq ClosestParam (vlax-curve-getparamatpoint Object ClosestPoint))
   (setq ClosestPoint (trans ClosestPoint 0 1)) ; convert to UCS
   (setq End (vlax-curve-getEndparam Object))
   (setq P1   0.0
  P2   Sample
  Defl 0.0
   )
   (setq a1 (angle PIQ (trans Start 0 1))) ; in UCS
   (while (<= P2 End)
     (setq P2 (min P2 End))
       (if (< P1 ClosestParam P2)
(setq a2   (angle PIQ ClosestPoint)
      Defl (+ Defl (@delta a1 a2))
      a1   a2
)
     )

     (while (not (setq P (vlax-curve-getPointAtParam Object P2)))
(setq P2 (+ P2 Sample))
     )
     (setq a2	 (angle PIQ (trans P 0 1)) ; in UCS
    Defl (+ Defl (@delta a1 a2))
    a1	 a2
    P1	 P2
    P2	 (+ P2 Sample)
     )
   )

   (> (abs Defl) 4)
 )
)
;;;;;;*************
(defun C:ITest (/ Object P)
 (if (setq Object (car (entsel "\nSelect curve: ")))
   (while (setq P (getpoint "\nPoint: "))
     (prin1 (@Inside P Object))
   )
 )
 (princ)
)

Có bác nào onl không cho em hỏi chút.Cái hàm insidep ở đầu chương trình em thấy trong chương trình chính không thấy lệnh gọi.nó chạy trong chương trình này như thế nào ah.

Download lisp

Filename: 133979_itest.lsp

Tác giả: phongthan123vn
Bài viết gốc: 297939
Tên lệnh: tmp

Lips move line; pline; vuông góc với line hay pline có sẵn

Sửa lại. Không thấy bạn test với text thế nào?

(defun c:tmp()
(defun dxf (id v) (cdr (assoc id...
>>

Sửa lại. Không thấy bạn test với text thế nào?

(defun c:tmp()
(defun dxf (id v) (cdr (assoc id (entget v))))
(defun getNear(v ent)
(setq tm (vl-sort (list (vlax-curve-getStartPoint v) (vlax-curve-getEndPoint v))
'(lambda(x y) (< (distance x (vlax-curve-getClosestPointTo ent x))
(distance y (vlax-curve-getClosestPointTo ent y)))))
tm1 (vlax-curve-getClosestPointTo ent (car tm)))
)
 
(defun thgoc (ent pt / param)
(if (setq param (vlax-curve-getParamAtPoint ent pt))
(- (angle '(0 0 0) (vlax-curve-getFirstDeriv ent param)) (/ pi 2))
nil)
)
(defun laydinh(v / n L node)
(setq v (vlax-ename->vla-object v)
n -1 L nil)
(vl-catch-all-error-p (vl-catch-all-apply '(lambda() 
(while (setq node (vla-get-Coordinate v (setq n (1+ n)))) 
(setq L (append L (list (vlax-safearray->list (vlax-variant-value node)))))))))
L
)
 
;;;
(vl-load-com)
(command "undo" "be")
(setq ent (car (entsel "\nChon duong dan:"))
os (getvar 'osmode))
(setvar 'osmode 0)
(prompt "\nChon doi tuong can move:")  
(mapcar '(lambda(x)
(cond ((= "LINE" (dxf 0 x)) (getNear x ent)
(command "move" x "" (car tm) tm1)
(command "rotate" x "" tm1 "r" tm1 (polar tm1 (angle (car tm) (last tm)) 1) (polar tm1 (thgoc ent tm1) 1)))
 
((vl-string-search "LINE" (dxf 0 x)) (getNear x ent) 
(command "move" x "" (car tm) tm1)
(setq tm2 (if (< (distance tm1 (car (setq tm3 (laydinh x)))) 0.1) (nth 1 tm3) (nth (- (length tm3) 2) tm3)))
(command "rotate" x "" tm1 "r" tm1 (polar tm1 (angle tm1 tm2) 1)
(polar tm1 (thgoc ent tm1) 1)))
 
((vl-string-search "TEXT" (dxf 0 x))
(command "move" x "" (dxf 10 x) (setq tm1 (vlax-curve-getClosestPointTo ent (dxf 10 x))))
(command "rotate" x "" tm1 "r" tm1 (polar tm1 (dxf 50 x) 1) (polar tm1 (thgoc ent tm1) 1)))
 
)) (acet-ss-to-list (ssget '((0 . "*LINE,*TEXT"))))
)
(command "undo" "e") (setvar 'osmode os) (princ)
)

Bác ơi. Quá tuyệt vời ạ. Bác đúng là vị cứu tinh của em. Ko biết nói j để cảm ơn sự nhiệt tình của bác. E chỉ biết chúc bác sức khỏe và hạnh phúc trong cuộc sống và công việc ạ.