Đến nội dung


Hình ảnh
- - - - -

Căn lề text + Mtext, Căn lề đối tượng


  • Please log in to reply
52 replies to this topic

#41 risusu

risusu

    biết vẽ circle

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

Đã gửi 13 October 2011 - 01:53 PM

Giờ là lisp căn lề đối tượng (s).Bao gồm có L,PL,ARC,Dim,Hatch,Block,Att,Point,Text,Mtext,Ellisp,SPline.Code thì dài khỏi nói rồi ^^ Các bác thử test xem sao.(E đã bỏ phần bắt lỗi và các thiết đặt reset setting đi cho đỡ rối mắt r )

(defun c:Trai ( / Set1 Base_X I ObjName Min_X DeltaPt Pt_List_M AttribList AttribFlag)			(setq Set1 (ssget))				(setq ObjName (car (entsel "\n Select Reference Object: ")))		(setq Base_X (caar(GetObjSize_401 ObjName)))	(setq time (getvar "MILLISECS"))	(setq i 0)		(repeat (sslength Set1)				(setq Pt_List_M nil Flag2 nil InsertFlag nil)				(setq ObjName (ssname Set1 i))				(setq Min_X (caar (GetObjSize_401 ObjName)))				(if Flag2 (setq DeltaPt '(0 0))						(setq DeltaPt (list (- Base_X Min_X) 0)))						(setq DeltaPt (mapcar '- (trans DeltaPt 1 0 ) (getvar "UCSORG")))				(Entmod_Obj_401 ObjName DeltaPt)						(setq i (1+ i))		)		(setq time (/ (- (getvar "MILLISECS") time) 1000.0))(princ (strcat "\nThoi gian thuc hien (giay) :" (rtos time)))		(princ))(defun c:Giua ( / Set1 Base_X I ObjName Min_X DeltaPt Pt_List_M AttribList AttribFlag)		(setq Set1 (ssget))			(setq ObjName (car (entsel "\n Select Reference Object: ")))			(setq Pt_List_M(GetObjSize_401 ObjName))	(setq Base_X ( / (+ (caar Pt_List_M)(caadr Pt_List_M)) 2))	(setq i 0)	(setq time (getvar "MILLISECS"))		(repeat (sslength Set1)				(setq Pt_List_M nil Flag2 nil)				(setq ObjName (ssname Set1 i))				(setq Pt_List_M (GetObjSize_401 ObjName))				(setq Min_X ( / (+ (caar Pt_List_M)(caadr Pt_List_M)) 2))				(if Flag2 (setq DeltaPt '(0 0))						(setq DeltaPt (list (- Base_X Min_X) 0)))						(setq DeltaPt (mapcar '- (trans DeltaPt 1 0 ) (getvar "UCSORG")))				(Entmod_Obj_401 ObjName DeltaPt)						(setq i (1+ i))						)						(setq time (/ (- (getvar "MILLISECS") time) 1000.0))(princ (strcat "\nThoi gian thuc hien (giay) :" (rtos time)))		(princ))(defun c:phai ( / Set1 Base_X I ObjName Min_X DeltaPt Pt_List_M AttribList AttribFlag)	(setq Set1 (ssget))					(setq ObjName (car (entsel "\n Select Reference Object: ")))				(setq Pt_List_M(GetObjSize_401 ObjName))	(setq Base_X (caadr Pt_List_M))	(setq i 0)		(repeat (sslength Set1)				(setq Pt_List_M nil Flag2 nil)				(setq ObjName (ssname Set1 i))				(setq Pt_List_M(GetObjSize_401 ObjName))				(setq Min_X (caadr Pt_List_M))				(if Flag2 (setq DeltaPt '(0 0))						(setq DeltaPt (list (- Base_X Min_X) 0)))						(setq DeltaPt (mapcar '- (trans DeltaPt 1 0 ) (getvar "UCSORG")))				(Entmod_Obj_401 ObjName DeltaPt)						(setq i (1+ i))		)		(princ))(defun c:tren ( / Set1 Base_Y I ObjName Min_Y DeltaPt Pt_List_M AttribList AttribFlag)	(setq Set1 (ssget))				(setq ObjName (car (entsel "\n Select Reference Object: ")))			(setq Pt_List_M(GetObjSize_401 ObjName))	(setq Base_Y (cadar Pt_List_M))	(setq i 0)		(repeat (sslength Set1)				(setq Pt_List_M nil Flag2 nil)				(setq ObjName (ssname Set1 i))				(setq Pt_List_M(GetObjSize_401 ObjName))				(setq Min_Y (cadar Pt_List_M))				(if Flag2 (setq DeltaPt '(0 0))						(setq DeltaPt (list 0 (- Base_Y Min_Y))))						(setq DeltaPt (mapcar '- (trans DeltaPt 1 0 ) (getvar "UCSORG")))				(Entmod_Obj_401 ObjName DeltaPt)						(setq i (1+ i))		)		(princ))(defun c:giua1 ( / Set1 Base_Y I ObjName Min_Y DeltaPt Pt_List_M AttribList  AttribFlag)	(setq Set1 (ssget))				(setq ObjName (car (entsel "\n Select Reference Object: ")))				(setq Pt_List_M(GetObjSize_401 ObjName))	(setq Base_Y ( / (+ (cadar Pt_List_M)(cadadr Pt_List_M)) 2))		(setq i 0)		(repeat (sslength Set1)				(setq Pt_List_M nil Flag2 nil)				(setq ObjName (ssname Set1 i))				(setq Pt_List_M(GetObjSize_401 ObjName))				(setq Min_Y ( / (+ (cadar Pt_List_M)(cadadr Pt_List_M)) 2))				(if Flag2 (setq DeltaPt '(0 0))						(setq DeltaPt (list 0 (- Base_Y Min_Y))))						(setq DeltaPt (mapcar '- (trans DeltaPt 1 0 ) (getvar "UCSORG")))				(Entmod_Obj_401 ObjName DeltaPt)						(setq i (1+ i))		)		(princ))(defun c:duoi ( / Set1 Base_Y I ObjName Min_Y DeltaPt Pt_List_M AttribList AttribFlag)	(setq Set1 (ssget))			(setq ObjName (car (entsel "\n Select Reference Object: ")))			(setq Pt_List_M(GetObjSize_401 ObjName))	(setq Base_Y (cadadr Pt_List_M))	(setq i 0)		(repeat (sslength Set1)				(setq Pt_List_M nil Flag2 nil)				(setq ObjName (ssname Set1 i))				(setq Pt_List_M(GetObjSize_401 ObjName))				(setq Min_Y (cadadr Pt_List_M))				(if Flag2 (setq DeltaPt '(0 0))						(setq DeltaPt (list  0 (- Base_Y Min_Y))))						(setq DeltaPt (mapcar '- (trans DeltaPt 1 0 ) (getvar "UCSORG")))				(Entmod_Obj_401 ObjName DeltaPt)						(setq i (1+ i))		)		(princ));;;----------------------------Distribution_401-----------------------(defun Distribution_401 (ObjName /	)			(setq Data (entget ObjName) ObjType (cdr(assoc 0 Data)))	(cond 	((= ObjType "INSERT")(INSERT_Box ObjName))			((= ObjType "HATCH")(HATCH_Box ObjName))			((= ObjType "LINE")(Line_Box ObjName))			((= ObjType "LWPOLYLINE")(LWPOLYLINE_Box ObjName))			((= ObjType "DIMENSION")(DIMENSION_Box ObjName))			((= ObjType "TEXT")(TEXT_Box ObjName))			((= ObjType "MTEXT")(MTEXT_Box ObjName))			((= ObjType "ARC")(ARC_Box ObjName))			((= ObjType "CIRCLE")(CIRCLE_Box ObjName))			((= ObjType "POLYLINE")(POLYLINE_Box ObjName))			((= ObjType "SPLINE")(SPLINE_Box ObjName))			((= ObjType "ELLIPSE")(ELLIPSE_Box ObjName))			((= ObjType "ATTRIB")(setq AttribFlag T)(TEXT_Box ObjName)(setq AttribFlag nil))			((and (= ObjType "ATTDEF") (null InsertFlag))(TEXT_Box ObjName))			((= ObjType "POINT")(POINT_Box ObjName))	)	Pt_List_M);;;===================================================(defun INSERT_Box (ObjName / Ins_P Scale_X Scale_Y Ang AttribList I_NameList)	(setq InsertFlag T)	(setq Ins_P (reverse (cdr (reverse (cdr(assoc 10 (entget ObjName)))))))		(setq Scale_X (cdr(assoc 41 (entget ObjName))))		(setq Scale_Y (cdr(assoc 42 (entget ObjName))))		(setq ScXY (list Scale_X Scale_Y ))	(setq Ang (cdr(assoc 50 (entget ObjName))))		(cond 	((= (cdr(assoc 66 (entget ObjName))) 1)			(setq AttribList (AttribListInsideBlock ObjName))			(mapcar 'Distribution_401 AttribList)			)	)	(setq I_NameList (MakeListInsideBlock ObjName))	(mapcar 'Distribution_401 I_NameList)	(setq Pt_List_M (BoxPoint Pt_List_M))	(setq Ins_P '(0 0) Scale_X 1.0 Scale_Y 1.0 Ang 0))(defun AttribListInsideBlock (ObjName / NextObjType ObjNext )	(setq ObjNext (entnext ObjName))	(while (= (cdr (assoc 0 (entget ObjNext))) "ATTRIB")		(setq AttribList (append AttribList (list ObjNext)))		(if (entnext ObjNext)(setq ObjNext (entnext ObjNext)))	)	AttribList);;;===================================================(defun HATCH_Box (ObjName / )		(Make_Point_List Data)	(if (/= L_Line nil)	(Cal_Line L_Line))	(if (/= L_Arc nil)	(mapcar 'Cal_Arc L_Arc))	(if (/= L_Ellip nil)	(mapcar 'Cal_Ellip L_Ellip))	(if (/= L_Spline nil)(Cal_Spline L_Spline))	(if (/= PL_NoPt nil)(Cal_PL PL_NoPt PL_Pt PL_R))		(setq Pt_List_M (BoxPoint Pt_List_M))	Pt_List_M);;;----------------------------------------------------------------------(defun Make_Point_List ( Data / )	(setq nn (length Data) mm 0)	(while (/= mm nn)		(setq Item (nth mm Data))						(cond 	((and (= (car Item) 92)(= (logand (cdr item) 2) 2))(MakeList_PLine))				((and (= (car Item) 72)(= (cdr Item) 1))(MakeList_Line))				((and (= (car Item) 72)(= (cdr Item) 2))(MakeList_Arc))				((and (= (car Item) 72)(= (cdr Item) 3))(MakeList_Ellip))				((and (= (car Item) 72)(= (cdr Item) 4))(MakeList_Spline))		)		(setq mm (1+ mm))	));;;----------------------------------------------------------------------(defun Cal_PL (PL_NoPt PL_Pt PL_R / j p Pt_List)			(setq PL_Pt (MovRotScl PL_Pt Ins_P Ang Scale_X Scale_Y))			(setq PL_Pt (mapcar '(lambda(x)(trans x 0 1)) PL_Pt))		(setq PL_R (mapcar '(lambda(x)(*	(/ (* Scale_X Scale_Y)(abs (* Scale_X Scale_Y))) x)) PL_R))		(setq j 0)	(foreach Item PL_NoPt		(setq p 1)		(repeat Item			(if (/= p Item)				(setq Pt_List (append Pt_List (list (list (nth j PL_Pt)(nth (1+ j) PL_Pt)(nth j PL_R)))))							(progn 	(setq Pt_List (append Pt_List (list (list (nth j PL_Pt)(nth (- j Item -1) PL_Pt)(nth j PL_R)))))						(setq p 0))			)			(setq j (1+ j) p (1+ p))		)	)	&#8218;&#211;&#8218;&#173;&#8218;&#231;&#8218;&#221;&#8218;&#170;&#8226;&#8240;&#8218;&#220;&#8218;&#189;&#8218;&#205;0&#8218;&#204;&#234;&#8225;&#8218;&#205;&#338;v&#381;Z&#8218;&#181;&#8218;&#200;&#8218;&#162;	(setq Pt_List (vl-remove-if '(lambda(x)(<= (nth 2 x) 0)) Pt_List))	(setq C_Rd_List (mapcar 'CompR Pt_List))		(setq QtPt_List (mapcar '(lambda(x) (QuaterPt (car x)(cadr x))) C_Rd_List))	(setq QtPt_List (apply 'append QtPt_List))		(setq Pt_List (append PL_Pt QtPt_List))	(setq Pt_List (BoxPoint Pt_List))		(setq Pt_List_M (append Pt_List_M Pt_List)));;;----------------------------------------------------------------------(defun Cal_Ellip (Pt_List /)	(setq 	P1 (nth 0 Pt_List)			P2 (nth 1 Pt_List)			P2x (car P2)			P2y (cadr P2)			Rate (nth 2 Pt_List)			EPs (nth 3 Pt_List)			EPe (nth 4 Pt_List)			EDrec (nth 5 Pt_List))						(setq EPs (AngleCircleToEllip EPs Rate) EPe (AngleCircleToEllip EPe Rate))			(setq EPsOrg EPs EPeOrg EPe )						(if (= EDrec 0)(setq EPs (- (* 2 pi) EPeOrg) EPe (- (* 2 pi) EPsOrg)))		(setq Pt_List2 (list P1))			(setq Pt_List3(list P2))			(setq Pt_List2 (MovRotScl Pt_List2 Ins_P Ang Scale_X Scale_Y))			(setq Pt_List3 (MovRotScl Pt_List3 '(0 0) Ang Scale_X Scale_Y))		(setq Pt_List2 (mapcar '(lambda(x)(trans x 0 1)) Pt_List2))	(setq Pt_List3 (mapcar '(lambda(x)(trans x 0 1)) Pt_List3))		(if 	(entmake (list	'(0 . "ELLIPSE")'(100 . "AcDbEntity")'(100 . "AcDbEllipse")					(append '(10) (car Pt_List2))(append '(11) (car Pt_List3))(cons 40 Rate)(cons 41 EPs)(cons 42 EPe)))		(setq TempObjName (entlast))(princ "\n Failed in ArcEntEllip"))		(setq 	P2x (caar Pt_List3)			P2y (cadar Pt_List3))			(setq	PEco	(* P2x P2y (- 1 (* Rate Rate)))			PE1x 	(sqrt (+(* P2x P2x)(* Rate Rate P2y P2y)))			PE1y	(/ PEco PE1x)			PE2y	(sqrt (+(* P2y P2y)(* Rate Rate P2x P2x)))			PE2x	(/ PEco PE2y))	(setq 	PE1	(list PE1x PE1y)			PE2	(list PE2x PE2y)			PE3	(mapcar '* PE1 '(-1 -1))			PE4	(mapcar '* PE2 '(-1 -1)))	(setq Pt_List (list PE1 PE2 PE3 PE4))	(setq Pt_List (mapcar '(lambda(x) (mapcar '+  x (car Pt_List2))) Pt_List))		(setq Pt_List (mapcar '(lambda(x)(if (equal (distance (vlax-curve-getClosestPointTo TempObjName x) x ) 0 0.01) x)) Pt_List))	(entdel TempObjName)	&#183;	(setq Pt_List (vl-remove nil Pt_List))		(if Pt_List		(progn	(setq Pt_List (BoxPoint Pt_List))		)	)	(setq Pt_List_M (append Pt_List_M Pt_List)));;;----------------------------------------------------------------------(defun Cal_Arc (Pt_List )		(setq 	P1 (nth 0 Pt_List)			Rd (* (abs Scale_X)(nth 1 Pt_List))			EPs (nth 2 Pt_List)			EPe (nth 3 Pt_List)			Drec (nth 4 Pt_List))	(setq EPsOrg EPs EPeOrg EPe )				(if (= Drec 0)(setq EPs (- (* 2 pi) EPe) EPe (- (* 2 pi) EPsOrg)))				(setq EPs_org EPs EPe_org EPe)				(cond 	((and (< Scale_X 0)(> Scale_Y 0))(setq EPs (- pi EPe_org) 		EPe (- pi EPs_org)))		;X- Y+						((and (< 0 Scale_X)(< Scale_Y 0))(setq EPs (- (* 2 pi) EPe_org)	EPe (- (* 2 pi) EPs_org)))	;X+ Y-						((and (< Scale_X 0)(< Scale_Y 0))(setq EPs (+ pi EPs_org) 		EPe (+ pi EPe_org)))			;X- Y-				)								(setq EPs (+ EPs Ang))				(setq EPe (+ EPe Ang))		(setq Pt_List (list P1))		(setq Pt_List (MovRotScl Pt_List Ins_P Ang Scale_X Scale_Y))	(setq Pt_List (mapcar '(lambda(x)(trans x 0 1)) Pt_List))		(if 	(entmake (list	'(0 . "ARC")'(100 . "AcDbEntity")'(100 . "AcDbCircle")					(append '(10) (car Pt_List))(cons 40 Rd)'(100 . "AcDbArc")(cons 50 EPs)(cons 51 EPe)))		(setq TempObjName (entlast))		(princ "\n Failed in ArcEntmake"))		(setq Pt_List (QuaterPt (car Pt_List) Rd))		(setq Pt_List (mapcar '(lambda(x)(if (equal (distance (vlax-curve-getClosestPointTo TempObjName x) x ) 0 0.00001) x)) Pt_List))	(entdel TempObjName)		(setq Pt_List (vl-remove nil Pt_List))	(if Pt_List		(progn	(setq Pt_List (BoxPoint Pt_List))		)	)			(setq Pt_List_M (append Pt_List_M Pt_List)));;;----------------------------------------------------------------------(defun Cal_Line (Pt_List)	(setq Pt_List (MovRotScl Pt_List Ins_P Ang Scale_X Scale_Y))	(setq Pt_List (mapcar '(lambda(x)(trans x 0 1)) Pt_List))	(setq Pt_List (BoxPoint Pt_List))			(setq Pt_List_M (append Pt_List_M Pt_List)));;;===================================================(defun DIMENSION_Box (ObjName);	(princ "\n DIMENSION_Start===============")	(setq I_NameList (MakeListInsideBlock ObjName))	(mapcar '(lambda(x) (Distribution_401 x)) I_NameList)	(setq Pt_List_M (BoxPoint Pt_List_M)));;;===================================================(defun ELLIPSE_Box (ObjName);	(princ "\n ELLIPSE_Box--------------------------")	(setq 	P1 (cdr (assoc 10 Data)) 				P2 (cdr (assoc 11 Data))				P2x (car P2)			P2y (cadr P2)			Rate (cdr (assoc 40 Data))				EPs	(cdr(assoc 41 Data))				EPe	(cdr(assoc 42 Data))			EDrec (nth 3 (assoc 210 Data))			)				(if (or	(and (< Scale_X 0)(< 0 Scale_Y))					(and (< 0 Scale_X)(< Scale_Y 0))				)			(progn	(setq EPs_org EPs)					(setq EPe_org EPe)					(setq EPs (- (* 2 pi) EPe_org))					(setq EPe (- (* 2 pi) EPs_org))))		(setq Pt_List2 (list P1))			(setq Pt_List3(list P2))			(setq Pt_List2 (MovRotScl Pt_List2 Ins_P Ang Scale_X Scale_Y))			(setq Pt_List3 (MovRotScl Pt_List3 '(0 0) Ang Scale_X Scale_Y))		(setq Pt_List2 (mapcar '(lambda(x)(trans x 0 1)) Pt_List2))	(setq Pt_List3 (mapcar '(lambda(x)(trans x 0 1)) Pt_List3))	;&#381;&#192;'&#339;&#8218;&#204;&#236;&#144;&#172;	(setq Data (subst (append  '(10) (car Pt_List2)) (assoc 10 Data) Data))		(setq Data (subst (append  '(11) (car Pt_List3)) (assoc 11 Data) Data))		(setq Data (subst (cons 41 EPs)(assoc 41 Data) Data))		(setq Data (subst (cons 42 EPe)(assoc 42 Data) Data))		(setq Data (subst (cons 8 "A51")(assoc 8 Data) Data))	(if (entmake Data)(setq TempObjName (entlast))(princ "\n Failed in ArcEntmake"))	(setq Pt1 (vlax-curve-getStartPoint TempObjName))			(setq Pt2 (vlax-curve-getEndPoint TempObjName))				(setq 	P2x (caar Pt_List3)			P2y (cadar Pt_List3))			(setq	PEco	(* P2x P2y (- 1 (* Rate Rate)))			PE1x 	(sqrt (+(* P2x P2x)(* Rate Rate P2y P2y)))			PE1y	(/ PEco PE1x)			PE2y	(sqrt (+(* P2y P2y)(* Rate Rate P2x P2x)))			PE2x	(/ PEco PE2y))	(setq 	PE1	(list PE1x PE1y)			PE2	(list PE2x PE2y)			PE3	(mapcar '* PE1 '(-1 -1))			PE4	(mapcar '* PE2 '(-1 -1)))	(setq Pt_List (list PE1 PE2 PE3 PE4))	(setq Pt_List (mapcar '(lambda(x) (mapcar '+  x (car Pt_List2))) Pt_List))	;&#8240;&#241;"]&#352;g'&#229;&#338;&#227;&#8218;&#204;'&#8224;&#144;S&#192;&#8226;W&#8218;&#240;'&#171;&#8218;&#183;		(setq Pt_List (mapcar '(lambda(x)(if (equal (distance (vlax-curve-getClosestPointTo TempObjName x) x ) 0 0.00001) x)) Pt_List))	(entdel TempObjName)		(setq Pt_List (append (vl-remove nil Pt_List) (list Pt1 Pt2)))		(setq Pt_List (BoxPoint Pt_List))	(setq Pt_List_M (append Pt_List_M Pt_List)));;;===================================================(defun ARC_Box(ObjName)	(setq 	P1 (cdr (assoc 10 Data)) 			Rd (* (abs Scale_X) (cdr (assoc 40 Data)))			EPs	(cdr(assoc 50 Data))			EPe	(cdr(assoc 51 Data)))									(setq EPs_org EPs EPe_org EPe)				(cond 	((and (< Scale_X 0)(> Scale_Y 0))(setq EPs (- pi EPe_org) 		EPe (- pi EPs_org)))		;X- Y+						((and (< 0 Scale_X)(< Scale_Y 0))(setq EPs (- (* 2 pi) EPe_org)	EPe (- (* 2 pi) EPs_org)))	;X+ Y-						((and (< Scale_X 0)(< Scale_Y 0))(setq EPs (+ pi EPs_org) 		EPe (+ pi EPe_org)))			;X- Y-				)								(setq EPs (+ EPs Ang))				(setq EPe (+ EPe Ang))	(setq EPs (- EPs (angle (trans '(0 0) 1 0)(trans  '(1 0) 1 0))))	(setq EPe (- EPe (angle (trans '(0 0) 1 0)(trans  '(1 0) 1 0))))	(setq Pt_List (list P1))	(setq Pt_List (MovRotScl Pt_List Ins_P Ang Scale_X Scale_Y))	(setq Pt_List (mapcar '(lambda(x)(trans x 0 1)) Pt_List))		(setq Data (subst (append  '(10) (car Pt_List)) (assoc 10 Data) Data))		(setq Data (subst (cons 50 EPs)(assoc 50 Data) Data))			(setq Data (subst (cons 51 EPe)(assoc 51 Data) Data))				(setq Data (subst (cons 40 Rd)(assoc 40 Data) Data))		(setq Data (subst (cons 8 "A51")(assoc 8 Data) Data))	(if (entmake Data)(setq TempObjName (entlast))(princ "\n Failed in ArcEntmake"))	(setq Pt1 (vlax-curve-getStartPoint TempObjName))			(setq Pt2 (vlax-curve-getEndPoint TempObjName))			(setq Pt_List (QuaterPt (car Pt_List) Rd))	(setq Pt_List (mapcar '(lambda(x)(if (equal (distance (vlax-curve-getClosestPointTo TempObjName x) x ) 0 0.00001) x)) Pt_List))	(entdel TempObjName)	(setq Pt_List (append (vl-remove nil Pt_List) (list Pt1 Pt2)))	(setq Pt_List (BoxPoint Pt_List))		(setq Pt_List_M (append Pt_List_M Pt_List))	);;;===================================================(defun SPLINE_Box (ObjName)	(setq Pt_list (mapcar 'cdr (vl-remove-if-not '(lambda(x)(= (car x) 11)) Data)))	(setq Pt_List (MovRotScl Pt_List Ins_P Ang Scale_X Scale_Y ))	(setq Pt_List (mapcar '(lambda(x)(trans x 0 1)) Pt_List))	(setq Pt_List (BoxPoint Pt_List))		(setq Pt_List_M (append Pt_List_M Pt_List)));;;===================================================(defun LWPOLYLINE_Box (ObjName)	(setq Pt_List (mapcar 'cdr (vl-remove-if-not '(lambda(x)(= (car x) 10)) Data)))		(setq R_List (mapcar 'cdr (vl-remove-if-not '(lambda(x)(= (car x) 42)) Data)))		(setq Flag401 (cdr(assoc 70 Data)))		(setq Drec (nth 3 (assoc 210 (entget ObjName))))	(setq Pt_List (MovRotScl Pt_List Ins_P Ang (* Drec Scale_X) Scale_Y))	(setq Pt_List (mapcar '(lambda(x)(trans x 0 1)) Pt_List))		(setq R_List (mapcar '(lambda(x)(*	(/ (* Scale_X Scale_Y)(abs (* Scale_X Scale_Y))) x)) R_List))		(setq Data (vl-remove-if '(lambda(x)(or (= (car x) 10)(= (car x) 40)(= (car x) 41)(= (car x) 42)(= (car x) 210))) Data))	(setq Data2 (apply 'append (mapcar '(lambda (x y) (list (append '(10) x)(cons 42 y))) Pt_List R_List)))	(setq Data (append Data Data2))	(setq Data (subst '(8 . "A51")(assoc 8 Data) Data))		(if (entmake Data)(setq TempObjName (entlast))(princ "\n Failed in LWPoly"))			(setq k 0 PtR_List nil)	(repeat (length Pt_List)		(if (/= (nth k R_List) 0)			(setq PtR_List 				(append PtR_List (list (list (nth k Pt_List)(if (null (nth (1+ k) Pt_List)) (nth 0 Pt_List)(nth (1+ k) Pt_List)) (nth k R_List))))))		(setq k (1+ k))	)	(if (= 0 Flag401)(setq PtR_List (reverse(cdr (reverse PtR_List)))))	(setq C_Rd_List (mapcar 'CompR PtR_List))		(setq QtPt_List (mapcar '(lambda(x) (QuaterPt (car x)(cadr x))) C_Rd_List))	(setq QtPt_List (mapcar '(lambda(y) (mapcar '(lambda(x)				(if (equal (distance (vlax-curve-getClosestPointTo TempObjName x) x) 0 0.00001) x )) y )) QtPt_List))	(entdel TempObjName)	(setq QtPt_List (vl-remove-if 'null (apply 'append QtPt_List)))		(setq Pt_List (append Pt_List QtPt_List))		_	(setq Pt_List (BoxPoint Pt_List))	(setq Pt_List_M (append Pt_List_M Pt_List)));;;===================================================(defun POLYLINE_Box (ObjName)	(setq ObjName (entnext ObjName) Pt_List nil)	(while	(/= (cdr(assoc 0 (entget ObjName))) "SEQEND")		(setq Pt_List (append Pt_List (list (cdr(assoc 10 (entget ObjName))))))		(setq ObjName (entnext ObjName))	)	(setq Pt_List (MovRotScl Pt_List Ins_P Ang Scale_X Scale_Y))	(setq Pt_List (mapcar '(lambda(x)(trans x 0 1)) Pt_List))	(setq Pt_List (BoxPoint Pt_List))		(setq Pt_List_M (append Pt_List_M Pt_List))	);;;===================================================(defun MText_Box (ObjName)	(setq TBase (cdr (assoc 10 Data)))	(setq IP   (cdr (assoc 71 Data)))	(setq W_42     (cdr (assoc 42 Data)))	(setq H_43     (cdr (assoc 43 Data)))	(setq TAng     (+ (angle (trans '(0 0) 1 0)(trans  '(1 0) 1 0)) (cdr (assoc 50 Data))))			(setq Pt_List (list '(0 0) (list W_42 0) (list W_42 H_43) (list 0 H_43)))	(cond 	((= IP 1)	(setq Pt_List (mapcar '(lambda(x)(mapcar '- x (mapcar '* '(0 1.0)(nth 2 Pt_List)))) Pt_List)))			((= IP 2)	(setq Pt_List (mapcar '(lambda(x)(mapcar '- x (mapcar '* '(0.5 1.0)(nth 2 Pt_List)))) Pt_List)))			((= IP 3)	(setq Pt_List (mapcar '(lambda(x)(mapcar '- x (mapcar '* '(1.0 1.0)(nth 2 Pt_List)))) Pt_List)))			((= IP 4)	(setq Pt_List (mapcar '(lambda(x)(mapcar '- x (mapcar '* '(0 0.5)(nth 2 Pt_List)))) Pt_List)))			((= IP 5)	(setq Pt_List (mapcar '(lambda(x)(mapcar '- x (mapcar '* '(0.5 0.5)(nth 2 Pt_List)))) Pt_List)))			((= IP 6)	(setq Pt_List (mapcar '(lambda(x)(mapcar '- x (mapcar '* '(1.0 0.5)(nth 2 Pt_List)))) Pt_List)))			((= IP 7)	(setq Pt_List (mapcar '(lambda(x)(mapcar '- x (mapcar '* '(0 0)(nth 2 Pt_List)))) Pt_List)))			((= IP 8)	(setq Pt_List (mapcar '(lambda(x)(mapcar '- x (mapcar '* '(0.5 0)(nth 2 Pt_List)))) Pt_List)))			((= IP 9)	(setq Pt_List (mapcar '(lambda(x)(mapcar '- x (mapcar '* '(1.0 0)(nth 2 Pt_List)))) Pt_List)))	)	(setq Pt_List (mapcar '(lambda(x)(SD8446  x '(0 0) TAng)) Pt_List))	(setq Pt_List (mapcar '(lambda(x) (mapcar '+  TBase x)) Pt_List))	(setq Pt_List (MovRotScl Pt_List Ins_P Ang Scale_X Scale_Y))	(setq Pt_List (mapcar '(lambda(x)(trans x 0 1)) Pt_List))	(setq Pt_List (BoxPoint Pt_List))		(setq Pt_List_M (append Pt_List_M Pt_List)));;;===================================================(defun Text_Box (ObjName)	(setq TBase (cdr (assoc 10 Data)))			(setq Pt2 (cadr (textbox Data)))				(setq TAng (cdr (assoc 50 Data)))			(setq Pt_List (list '(0 0) (list (car Pt2) 0) Pt2 (list 0 (cadr Pt2))))	(setq Pt_List (mapcar '(lambda(x)(SD8446  x '(0 0) TAng)) Pt_List))	(setq Pt_List (mapcar '(lambda(x) (mapcar '+  TBase x)) Pt_List))		(if (null AttribFlag)(setq Pt_List (MovRotScl Pt_List Ins_P Ang Scale_X Scale_Y)))	(setq Pt_List (mapcar '(lambda(x)(trans x 0 1)) Pt_List))	(setq Pt_List (BoxPoint Pt_List))	(setq Pt_List_M (append Pt_List_M Pt_List)));;;===================================================(defun Line_Box (ObjName);	(princ "\n Line_Box--------------------------")		(setq Pt_List (list (cdr (assoc 10 Data))(cdr (assoc 11 Data))))	(setq Pt_List (MovRotScl Pt_List Ins_P Ang Scale_X Scale_Y))	(setq Pt_List (mapcar '(lambda(x)(trans x 0 1)) Pt_List))		(setq Pt_List (BoxPoint Pt_List))		(setq Pt_List_M (append Pt_List_M Pt_List))	Pt_List_M);;;===================================================(defun CIRCLE_Box(ObjName);	(princ "\n CIRCLE_Box--------------------------")	(setq 	P1 (cdr (assoc 10 Data)) 			Rd (* (abs Scale_X) (cdr (assoc 40 Data))))		(setq Pt_List (list P1))		(setq Pt_List (MovRotScl Pt_List Ins_P Ang Scale_X Scale_Y))	(setq Pt_List (mapcar '(lambda(x)(trans x 0 1)) Pt_List))	(setq Pt_List (list (mapcar '- (car Pt_List)(list Rd Rd))(mapcar '+ (car Pt_List) (list Rd Rd) )))	(setq Pt_List_M (append Pt_List_M Pt_List)));;;===================================================(defun POINT_Box(ObjName)	(setq 	P1 (cdr (assoc 10 Data)))		(setq Pt_List (list P1))		(setq Pt_List (MovRotScl Pt_List Ins_P Ang Scale_X Scale_Y))	(setq Pt_List (mapcar '(lambda(x)(trans x 0 1)) Pt_List))	(setq Pt_List_M (append Pt_List_M Pt_List)))(defun QuaterPt (Pt Rd / )			(setq Px (car Pt) Py (cadr Pt))	(setq QtPt_List (list	(list Px (- Py Rd))	(list (+ Px Rd) Py)	(list Px (+ Py Rd))	(list (- Px Rd) Py)))		;4&#8226;&#170;&#8240;~"_	QtPt_List		j)(defun CompR (PtR_List /)	(setq P1X (caar PtR_List)) 			(setq P1Y (cadar PtR_List))			(setq P2X (caadr PtR_List))			(setq P2Y (cadadr PtR_List))			(setq Ratio (nth 2 PtR_List))	(setq Dist (distance (car PtR_List) (cadr PtR_List)))	(setq Rd (abs ( / (* Dist (+ 1 (expt Ratio 2))) (* 4 Ratio))))	(setq POX ( + ( * (+ P1X P2X) 0.5) ( / ( * (- (expt Ratio 2) 1) (- P2Y P1Y)) ( * 4 Ratio))))	(setq POY ( - ( * (+ P1Y P2Y) 0.5) ( / ( * (- (expt Ratio 2) 1) (- P2X P1X)) ( * 4 Ratio))))	(setq C_Rd (list (list POX POY) Rd))	C_Rd		)(defun AngleCircleToEllip ( AngOnCircle Rate)		(setq AngOnEllip (atan (/ (sin AngOnCircle) (* Rate (cos AngOnCircle)))))	(cond 	((and (<= (* -2.0 pi) AngOnCircle)(< AngOnCircle (* -1.5 pi)))(setq  AngOnEllip (- AngOnEllip (* 2.0 pi))))			((and (<= (* -1.5 pi) AngOnCircle) (< AngOnCircle (* -0.5 pi)))	(setq  AngOnEllip (- AngOnEllip pi)))			((and (<= (* 0.5 pi) AngOnCircle) (< AngOnCircle (* 1.5 pi)))	(setq  AngOnEllip (+ pi AngOnEllip)))			((and (<= (* 1.5 pi) AngOnCircle) (< AngOnCircle (* 2.0 pi)))	(setq  AngOnEllip (+ (* 2.0 pi) AngOnEllip))))	AngOnEllip)(defun BoxPoint (Pt_List / V1 V2 )	(setq V1 (list (apply 'min (mapcar 'car Pt_List))(apply 'min (mapcar 'cadr Pt_List))))	(setq V2 (list (apply 'max (mapcar 'car Pt_List))(apply 'max (mapcar 'cadr Pt_List))))	(setq Pt_List (list V1 V2)))(defun MakeList_PLine ()	(setq mm (1+ mm))	(while (and (/= (car (nth mm Data)) 92)(/= (car (nth mm Data)) 97)(/= (car (nth mm Data)) 75))		(cond 	((= (car (nth mm Data)) 93)(setq PL_NoPt_Temp (append PL_NoPt_Temp (list (cdr (nth mm Data))))))	;'&#184;"_&#144;"				((= (car (nth mm Data)) 10)(setq PL_Pt_Temp (append PL_Pt_Temp (list (cdr (nth mm Data))))))	;'["_				((= (car (nth mm Data)) 42)(setq PL_R_Temp (append PL_R_Temp (list (cdr (nth mm Data))))))	;&#8218;&#211;&#8218;&#173;&#8218;&#231;&#8218;&#221;		)		(setq mm (1+ mm))	)	(setq mm (- mm 1))		(if 	(null PL_R_Temp)		(setq L_Line0 PL_Pt_Temp PL_NoPt_Temp nil PL_Pt_Temp nil ))		(setq PL_NoPt (append PL_NoPt PL_NoPt_Temp))	(setq PL_Pt (append PL_Pt PL_Pt_Temp))	(setq PL_R (append PL_R PL_R_Temp))	(setq L_Line (append L_Line L_Line0))	)(defun MakeList_Line ( / L_Line0)	(setq mm (1+ mm))	(while (and (/= (car (nth mm Data)) 72)(/= (car (nth mm Data)) 92)				(/= (car (nth mm Data)) 97)(/= (car (nth mm Data)) 75))		(setq L_Line0 (append L_Line0 (list (cdr (nth mm Data)))))		(setq mm (1+ mm))	)	(setq mm (- mm 1))	(setq L_Line (append L_Line L_Line0))	)(defun MakeList_Arc ( / L_Arc0)	(setq mm (1+ mm))	(while (and (/= (car (nth mm Data)) 72)(/= (car (nth mm Data)) 92)				(/= (car (nth mm Data)) 97)(/= (car (nth mm Data)) 75))		(setq L_Arc0 (append L_Arc0 (list (cdr (nth mm Data)))))		(setq mm (1+ mm))	)	(setq mm (- mm 1))	(setq L_Arc (append L_Arc (list L_Arc0))))(defun MakeList_Ellip ( / L_Ellip0)	(setq mm (1+ mm))	(while (and (/= (car (nth mm Data)) 72)(/= (car (nth mm Data)) 92)				(/= (car (nth mm Data)) 97)(/= (car (nth mm Data)) 75))		(setq L_Ellip0 (append L_Ellip0 (list (cdr (nth mm Data)))))		(setq mm (1+ mm))	)	(setq mm (- mm 1))	(setq L_Ellip (append L_Ellip (list L_Ellip0))))(defun MakeList_Spline ( /L_Spline0)	(setq mm (1+ mm))	(while (and (/= (car (nth mm Data)) 72)(/= (car (nth mm Data)) 92)				(/= (car (nth mm Data)) 97)(/= (car (nth mm Data)) 75))		(if (= (car (nth mm Data)) 10)			(setq L_Spline0 (append L_Spline0 (list (cdr (nth mm Data))))))		(setq mm (1+ mm))	)	(setq mm (- mm 1))	(setq L_Spline (append L_Spline (list L_Spline0))))(defun Entmod_Obj_401 (ObjName	DeltaPt /  NewData Flag3 NextName Loc DataA NextObjType Flag4 Flag5)	(setq Data (entget ObjName))	(setq ObjType (cdr(assoc 0 Data)))	(cond 	((or (= ObjType "LINE")	(= ObjType "SPLINE"))				(entmod (mapcar '(lambda(x)(if 	(or (= (car x) 10) (= (car x) 11))														(list (car x)(+ (nth 1 x) (car DeltaPt))(+ (nth 2 x)(cadr DeltaPt))(nth 3 x))														x)) (entget ObjName)))			)			((= ObjType "INSERT")				(setq Loc (assoc 10 Data))				(entmod (subst 	(list 10 (+ (nth 1 Loc) (car DeltaPt))(+ (nth 2 Loc)(cadr DeltaPt))(nth 3 Loc))	Loc Data))								(cond 	((= (cdr (assoc 66 Data)) 1)						(setq ObjNext (entnext ObjName))						(while 	(= (cdr (assoc 0 (setq DataA (entget ObjNext)))) "ATTRIB")						       	(setq Loc (assoc 11 DataA))						       	(entmod(subst 	(list 11 (+ (nth 1 Loc) (car DeltaPt))(+ (nth 2 Loc)(cadr DeltaPt))(nth 3 Loc))	Loc DataA))								(entupd ObjNext)								(setq ObjNext(entnext ObjNext))						)						)				)			)			((= ObjType "POLYLINE")				;vertex				(setq NextName (entnext ObjName))				(setq NextObjType (cdr (assoc 0  (entget NextName))))				(while (/= NextObjType "SEQEND")					(if (= (cdr(assoc 0 (setq DataA (entget NextName)))) "VERTEX")			            	(progn	(setq Loc (assoc 10 DataA))			            			(entmod (subst 	(list 10 (+ (nth 1 Loc) (car DeltaPt))(+ (nth 2 Loc)(cadr DeltaPt))(nth 3 Loc))	Loc DataA))			            			(entupd NextName)			            	)			            )					(setq NextName(entnext NextName))					(setq NextObjType (cdr (assoc 0  (entget NextName))))				)			)			((= ObjType "HATCH")				(entmod (mapcar '(lambda(x)					(cond	((and (= (car x) 92)(= (logand (cdr x) 2) 2))								(setq Flag4 nil Flag5 nil)							)							((and (= (car x) 92)(/= (logand (cdr x) 2) 2))								(setq Flag4 T Flag5 nil)							)					)					(cond	((and (= (car x) 72)(= (cdr x) 3) Flag4)								(setq Flag5 T)													)							((and (= (car x) 72)(/= (cdr x) 3) Flag4)							(setq Flag5 nil)													)						)					(cond 	((and Flag5 (=(car x) 10))								(list 10 (+ (nth 1 x) (car DeltaPt))(+ (nth 2 x)(cadr DeltaPt))(nth 3 x))													)							((and (null Flag5)(or (=(car x) 10)(=(car x) 11)))								(list (car x) (+ (nth 1 x) (car DeltaPt))(+ (nth 2 x)(cadr DeltaPt))(nth 3 x))													)							(T x)					)					)Data)				)			)			((= ObjType "LWPOLYLINE")				(if (<= 0 (nth 3 (assoc 210 (entget ObjName))))(setq Flag3 1)(setq Flag3 -1))				(entmod (mapcar '(lambda(x) (if (= (car x) 10)(list 10 (+ (nth 1 x)(* Flag3 (car DeltaPt)))(+ (nth 2 x)(cadr DeltaPt))) x))											(entget ObjName)))     	     )	       	((= ObjType "DIMENSION")				(entmod (mapcar '(lambda(x)(if 	(or (= (car x) 10) (= (car x) 11)(= (car x) 13)(= (car x) 14)(= (car x) 15))														(list (car x)(+ (nth 1 x) (car DeltaPt))(+ (nth 2 x)(cadr DeltaPt))(nth 3 x))														x)) (entget ObjName)))	            )			((= ObjType "TEXT")		            (if 	(and (= (cdr(assoc 72 (entget ObjName))) 0)(= (cdr(assoc 73 (entget ObjName))) 0))		            	(progn	(setq Loc (assoc 10 Data))		            			(entmod (subst 	(list 10 (+ (nth 1 Loc) (car DeltaPt))(+ (nth 2 Loc)(cadr DeltaPt))(nth 3 Loc))	Loc Data))		            	)		            	(progn	(setq Loc (assoc 11 Data))		            			(entmod (subst 	(list 11 (+ (nth 1 Loc) (car DeltaPt))(+ (nth 2 Loc)(cadr DeltaPt))(nth 3 Loc))	Loc Data))		            	)			     )	            )	       	((or (= ObjType "CIRCLE")(= ObjType "ARC")(= ObjType "ELLIPSE")(= ObjType "MTEXT")(= ObjType "ATTDEF"))		       	(setq Loc (assoc 10 Data))		       	(entmod (subst 	(list 10 (+ (nth 1 Loc) (car DeltaPt))(+ (nth 2 Loc)(cadr DeltaPt))(nth 3 Loc))		       					Loc Data))		       )     		(T	(princ "\n Not Defined"))     ))(princ)(defun SD8446 ( PointA PointB Ang / XA YA XB YB PointC)	(setq	XA2(- (car PointA) (car PointB))			YA2(- (cadr PointA) (cadr PointB))	)	(setq PointC (list (- (* XA2 (cos Ang))(* YA2 (sin Ang))) (+ (* XA2 (sin Ang))(* YA2 (cos Ang)))))	(setq PointC (mapcar '+ PointC PointB))	PointC)(defun MovRotScl (Pt_List Ins_P Ang Scale_X Scale_Y / )	(setq Pt_List (mapcar '(lambda(x)(mapcar '* (list Scale_X Scale_Y ) x )) Pt_List))		;scale	(setq Pt_List (mapcar '(lambda (x) (list     (- (* (cos Ang) (car x)) (* (sin Ang) (cadr x))) (+ (* (sin Ang) (car x)) (* (cos Ang) (cadr x))))) Pt_List))	(setq Pt_List (mapcar '(lambda(x)(mapcar '+ Ins_P x)) Pt_List)) 	;move	Pt_List)(defun MakeListInsideBlock ( ObjName1 / B_Name1 I_ObjName1 I_ObjType1 I_ObjList1)	(setq B_Name1 (cdr (assoc 2 (entget ObjName1))))	(setq I_ObjName1 (cdr(assoc -2(tblsearch "block" B_Name1))))	(setq I_NameList1 (list I_ObjName1))	(while	(entnext I_ObjName1)		(setq I_ObjName1 (entnext I_ObjName1))		(setq I_NameList1 (append I_NameList1 (list I_ObjName1)))	)	I_NameList1)(defun GetObjSize_401 ( ObjName / Ins_P Ang Scale_X Scale_Y Data  I_NameList Pt_List_M									L_Line L_Arc L_Ellip L_Spline  PL_NoPt PL_Pt PL_R									nn mm Item j p Pt_List C_Rd_List QtPt_List 									P1 P2 P2x P2y Rate EPs EPe	EDrec Pt_List2 Pt_List3									PL_NoPt_Temp PL_Pt_Temp PL_R_Temp L_Line0 L_Arc0 L_Ellip0 L_Spline0)	(setq Ins_P '(0 0) Ang 0.0 Scale_X 1.0 Scale_Y 1.0)	(setq Pt_List_M (Distribution_401 ObjName))	Pt_List_M)

E cũng làm 1 phát test với 40k đối tượng già trẻ lớn bé to nhỏ đậm nhạt..Kết quả có phần đạt yêu cầu ^^


Cái này mà bác ketxu thêm chức năng giãn dòng nữa thì rất ok. thanks
  • 0
^_^0905-0988.782004^_^

#42 Trang72

Trang72

    biết vẽ ellipse

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

Đã gửi 13 January 2013 - 02:01 PM

Nhờ Bác Ketxu chỉnh sửa hộ lisp trên để căn text, mtext, pline, bock như hình vẽ (lấy tim căn là đường line hoặc pline màu xanh) Cám ơn Bác

http://www.cadviet.c..._drawing1_1.dwg
  • 0

#43 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

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

Đã gửi 13 January 2013 - 04:54 PM

Nhờ Bác Ketxu chỉnh sửa hộ lisp trên để căn text, mtext, pline, bock như hình vẽ (lấy tim căn là đường line hoặc pline màu xanh) Cám ơn Bác

http://www.cadviet.c..._drawing1_1.dwg


Phải chăng bạn muốn xếp các block lên đường pline đúng vị trí tương ứng của các cụm đánh số thứ tư và đặt các cụm này cách pline một khoảng nhất định do bạn chọn.
Nếu dúng vậy thì có thể không cần chờ bác ketxu đâu.
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#44 Trang72

Trang72

    biết vẽ ellipse

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

Đã gửi 13 January 2013 - 06:09 PM

Vâng Cám ơn Bác Bình. Hiện tại các Block của em linh tinh quá em muồn di chuyển xắp xếp vào đường line và các text, line cột TT tương ứng theo 1 khoảng cách đặt ra Bác ạ.
  • 0

#45 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

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

Đã gửi 15 January 2013 - 12:15 PM

Vâng Cám ơn Bác Bình. Hiện tại các Block của em linh tinh quá em muồn di chuyển xắp xếp vào đường line và các text, line cột TT tương ứng theo 1 khoảng cách đặt ra Bác ạ.

Hề hề hề,
Lisp đã viết xong, nhưng diễn đàn trục trặc chi đó mà cả ngày hôm qua không post lên được. Tuy nhiên có một vài vấn đề cần lưu ý với bạn khi sử dụng như sau:
1/- Bản vẽ bạn gửi có rất nhiều đối tượng trùng nhau. Điều này gây khó khăn cho lisp khiến nó không chạy tốt được. Bạn nên sử dụng lệnh overkill trong express d963 loại hết các đối tượng trùng nhau trước khi chạy lisp.
2/- các line mặt đất của bạn vẽ nhiều chỗ không chuẩn , Đít thằng nọ không ngồi lên đầu thằng kia. Vì thế việc chuyển đổi từ line về pline bị trục trặc. bạn cần kiểm soát lại toàn bộ các line mặt đất để đảm bảo đít thằng nọ ngồi đúng đầu thằng kia mới được.
3/- Các block bạn đã nhét sẵn vào bản vẽ hoàn toàn không cần dùng đến nó vì khi chạy lisp sẽ chèn các block mới vào điểm cần chèn. Như vậy xem ra hợp lý hơn là việc move các block có sẵn về điểm chèn mới. (vì chả biết nên move thằng nào)
4/- Bạn nên làm việc dọn dẹp bản vẽ thường xuyên để tránh tình trạng như bản vẽ bạn đã gửi. Nó gây khó khăn rất nhiều cho người làm lisp không am hiểu chuyên ngành của bạn như mình.

Đây là lisp. Bạn hãy làm đúng như mình nói rồi hẵng test, nếu không bạn sẽ thất vọng đó.



(defun c:sxtc ( / oldos p1 p2 ss ssl ss1 ssl1 h p0 sst pc )
(vl-load-com)
(setq oldos (getvar "osmode") )
(setvar "osmode" 0)
(alert "\n Chuyen cac line mat dat thanh polyline")
(command "undo" "be")
(setq p1 (getpoint "\n Chon diem goc tren ben trai vung chon"))
(setq p2 (getpoint p1 "\n Chon diem goc duoi ben phai vung chon"))

(setq ssl (acet-ss-to-list (setq ss (ssget "c" p1 p2 (list (cons 0 "*line") (cons 8 "_MatDat") (cons 62 5))))))
(while (and ss (> (sslength ss) 1))
(setq pl (nth 0 ssl))
(if (= (cdr (assoc 0 (entget pl))) "LINE")
(command "pedit" pl "y" "j" ss "" "")
(command "pedit" pl "j" ss "" "")
)
(setq ssl (acet-ss-to-list (setq ss (ssget "c" p1 p2 (list (cons 0 "*line") (cons 8 "_MatDat") (cons 62 5))))))
)

(setq h (getreal "\n Nhap khoang cach tu line toi pline: "))
(setq plo (vlax-ename->vla-object (entlast)))
(setq ssl1 (acet-ss-to-list (ssget "c" p1 p2 (list (cons 0 "line") (cons 8 "025") (cons 62 7)))))
(foreach lin ssl1
(setq p0 (mid (cdr (assoc 10 (entget lin))) (cdr (assoc 11 (entget lin)))) )
(setq sst (acet-ss-to-list (setq ss1 (ssget "w" (list (- (car p0) 45) (- (cadr p0) 45)) (list (+ (car p0) 45) (+ (cadr p0) 45))
(list (cons 0 "text") (cons 8 "025"))))) )
(foreach txt sst
(setq pt (cdr (assoc 11 (setq enl (entget txt)))))
(if (> (cadr pt) (cadr p0))
(entmod (subst (cons 11 (list (car p0) (+ (cadr p0) 12.5))) (assoc 11 enl) enl))
(entmod (subst (cons 11 (list (car p0) (- (cadr p0) 12.5))) (assoc 11 enl) enl))
)
)
(setq pc (vlax-curve-getClosestPointToProjection plo p0 (list 0 1 0) ) )
(command "insert" "Coc" pc 1 1 0)
(command "move" lin ss1 "" p0 (list (car pc) (+ (cadr pc) h)) )
)
(command "explode" (vlax-vla-object->ename plo))
(command "undo" "e")
(setvar "osmode" oldos)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;
(defun mid (p1 p2)
(setq p (list (/ (+ (car p1) (car p2)) 2) (/ (+ (cadr p1) (cadr p2)) 2)))
)
Chúc bạn vui.
  • 1
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#46 Trang72

Trang72

    biết vẽ ellipse

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

Đã gửi 16 January 2013 - 05:17 PM

Cám ơn Bác Bình đã viết giúp lisp trên .Nhưng nó sảy ra 3 vấn đề :
+ Các Bock và các text của em sảy ra trường hợp có lúc nằm bên trên, có lúc nằm bên dưới và có lúc nằm trùng với đường line.Năm bên trên thì lisp của bác chạy rất tốt còn nằm bên dưới và trùng với đường line thì không chạy được.
+ Đường mặt đất có thể là đường line hoặc đường Pline.
+ Khi chạy lisp của Bác thì block cot chỉ copy xuống đường line mặt đất chứ không phải di chuyển.
  • 0

#47 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

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

Đã gửi 16 January 2013 - 06:06 PM

Cám ơn Bác Bình đã viết giúp lisp trên .Nhưng nó sảy ra 3 vấn đề :
+ Các Bock và các text của em sảy ra trường hợp có lúc nằm bên trên, có lúc nằm bên dưới và có lúc nằm trùng với đường line.Năm bên trên thì lisp của bác chạy rất tốt còn nằm bên dưới và trùng với đường line thì không chạy được.
+ Đường mặt đất có thể là đường line hoặc đường Pline.
+ Khi chạy lisp của Bác thì block cot chỉ copy xuống đường line mặt đất chứ không phải di chuyển.

Hề hề hề,
Tại bạn không đọc kỹ hướng dẫn trước khi sử dụng lisp đó thôi.
1/- Các cụm text và line nằm đâu cũng vậy, miễn là nó nằm tương ứng với vị trí của nó trên đường mặt đất. Sau khi chạy lisp xong thì tất cả đều nằm các đường mặt đất một khoảng như nhau, trên hay dưới hay trùng tùy theo bạn nhập giá trị này.
2/- Các đường mặt đất của bạn có thể là pline nhưng với điều kiện các pline này phải nối tiếp nhau và không có đoạn nào trùng nhau.
3/- Các block cũ của bạn nê xóa sạch trước khi chạy lisp vì lý do mình đã nói ở bài trước.
Hề hề hề, hãy đọc kỹ hướng dẫn sử dụng trước khi dùng.
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#48 Trang72

Trang72

    biết vẽ ellipse

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

Đã gửi 17 January 2013 - 11:48 AM

http://www.cadviet.c...77310_vi_du.rar Nhờ các bác Bình và các Bác trên diễn đàn xem hộ em Lisp này
Em có nhờ anh bạn em viết hộ lisp nhưng lisp có nhược điểm khi chạy lisp này chọn tất cả các block thì Block chỉ di chuyển về được line màu xanh được một vài block mà không di chuyển được tất cả các block về tim tuyến khi kết thúc lệnh.
Hơn nữa do bạn em trình độ có hạn không viết được đoạn lisp di chuyển cả cụm text bên trên cách đường xanh 1 khoảng cách như lisp của bác Bình.
Nhờ các Bác chỉnh sửa giùm em nhé. Cám ơn các Bác



(defun giaodiem (a1 b1 c1)
(setq x (cadr a1)
y (+ (/ (* (- x (cadr b1)) (- (caddr c1) (caddr b1))) (- (cadr c1) (cadr b1))) (caddr b1))
)
(list 10 x y (cadddr a1))
)
;***************************************************************
(defun C:Mm()
(prompt "\nChon doi tuong di chuyen:")
(setq ss (ssget)
Q (sslength ss)
)
(setq pp (ssget "X" '((0 . "LINE") (62 . 5)))
P (sslength pp)
)
(setq i 0 j 0)
(while (< i (* Q 50))
(setq A (entget (ssname ss i)))
(setq B (entget (ssname pp j)))
(setq L10 (assoc 10 A)
L11 (assoc 10 B)
M11 (assoc 11 B)
)

(if (and (>= (cadr L10) (cadr L11)) (<= (cadr L10) (cadr M11)))
(progn
(setq D10 (giaodiem L10 L11 M11)
A (subst D10 L10 A)
)
)
(setq j (+ j 1) i (- i 1))

)
(setq i (+ i 1))
(entmod A)
)
(princ)
)
  • 0

#49 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

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

Đã gửi 17 January 2013 - 06:59 PM

http://www.cadviet.c...77310_vi_du.rar Nhờ các bác Bình và các Bác trên diễn đàn xem hộ em Lisp này
Em có nhờ anh bạn em viết hộ lisp nhưng lisp có nhược điểm khi chạy lisp này chọn tất cả các block thì Block chỉ di chuyển về được line màu xanh được một vài block mà không di chuyển được tất cả các block về tim tuyến khi kết thúc lệnh.
Hơn nữa do bạn em trình độ có hạn không viết được đoạn lisp di chuyển cả cụm text bên trên cách đường xanh 1 khoảng cách như lisp của bác Bình.
Nhờ các Bác chỉnh sửa giùm em nhé. Cám ơn các Bác



(defun giaodiem (a1 b1 c1)
(setq x (cadr a1)
y (+ (/ (* (- x (cadr b1)) (- (caddr c1) (caddr b1))) (- (cadr c1) (cadr b1))) (caddr b1))
)
(list 10 x y (cadddr a1))
)
;***************************************************************
(defun C:Mm()
(prompt "\nChon doi tuong di chuyen:")
(setq ss (ssget)
Q (sslength ss)
)
(setq pp (ssget "X" '((0 . "LINE") (62 . 5)))
P (sslength pp)
)
(setq i 0 j 0)
(while (< i (* Q 50))
(setq A (entget (ssname ss i)))
(setq B (entget (ssname pp j)))
(setq L10 (assoc 10 A)
L11 (assoc 10 B)
M11 (assoc 11 B)
)

(if (and (>= (cadr L10) (cadr L11)) (<= (cadr L10) (cadr M11)))
(progn
(setq D10 (giaodiem L10 L11 M11)
A (subst D10 L10 A)
)
)
(setq j (+ j 1) i (- i 1))

)
(setq i (+ i 1))
(entmod A)
)
(princ)
)

Hề hề hề,
Về ý tưởng thì người viết lisp này không hề có ý định di chuyển các cụm text và line, chỉ di chuyển các block mà thôi. Tuy nhiên nếu người sử dụng quét chọn cả text và line thì nó cũng sẽ bị di chuyển mà không đúng với ý định của người dùng.
Việc lisp không di chuyển được tất cả các block được chọn có nhẽ do người viết lisp tạo vòng lặp While chưa tốt.
Để có thể di chuyển được hết các block bạn thử sửa lại như sau;
1/- Chép thêm một dòng code (while (< j P) vào phía dưới dòng code (while (< i (* Q 50))
2/- Chép thêm một ngoặc đóng vào trước dòng code (setq i (+ i 1 ))
3/- Xóa bỏ đoạn code i (- i 1) trong dòng (setq j (+ j 1) i (- i 1))

Sau đó bạn hãy test lại xem nó đã chuyển hết các đối tượng block được chọn hay chưa nhé.
Chúc bạn vui.
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#50 Trang72

Trang72

    biết vẽ ellipse

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

Đã gửi 17 January 2013 - 09:19 PM

Không được đâu bác Bình ơi Em chạy rồi mà không di chuyển được block nào. Bác kiểm tra lại giúp em với nhé.
Tiện thể Bác thêm code di chuyển cụm text có 1 khoảng cách khi quét chọn cả text và line giống như code hôm trước Bác đã giúp em.
  • 0

#51 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

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

Đã gửi 18 January 2013 - 11:50 AM

Không được đâu bác Bình ơi Em chạy rồi mà không di chuyển được block nào. Bác kiểm tra lại giúp em với nhé.
Tiện thể Bác thêm code di chuyển cụm text có 1 khoảng cách khi quét chọn cả text và line giống như code hôm trước Bác đã giúp em.

Hề hề hề,
Sorry vì mình không kiểm tra kỹ khi hướng dẫn bạn bổ sung code. Bạn hãy chép lại lisp dưới đây và so sánh để thấy dược lỗi và rút kinh nghiệm nhé.
Tuy nhiên do cách tư duy của người viết lisp nên lisp này sẽ chạy khá chậm và rất dễ gây nhầm lẫn khi trên bản vẽ của bạn có nhiều đường mặt đất trùng lặp.
Việc lisp bạn sửa bị lỗi là do khi tạo hai vòng lặp lồng nhau mình đã quên trả biến về giá trị ban đầu.


(defun giaodiem (a1 b1 c1)
(setq x (cadr a1)
y (+ (/ (* (- x (cadr b1)) (- (caddr c1) (caddr b1))) (- (cadr c1) (cadr b1))) (caddr b1))
)
(list 10 x y (cadddr a1))
)
;***************************************************************
(defun C:Mm()
(prompt "\nChon doi tuong di chuyen:")
(setq ss (ssget)
Q (sslength ss)
)
(setq pp (ssget "X" '((0 . "LINE") (62 . 5)))
P (sslength pp)
)
(setq i 0 j 0)
(while (< i Q )
(setq A (entget (ssname ss i)))
(while (< j P)

(setq B (entget (ssname pp j)))
(setq L10 (assoc 10 A)
L11 (assoc 10 B )
M11 (assoc 11 B )
)

(if (and (>= (cadr L10) (cadr L11)) (<= (cadr L10) (cadr M11)))
(progn
(setq D10 (giaodiem L10 L11 M11)
A (subst D10 L10 A) )
(entmod A)
)

)
(setq j (+ j 1) )
)
(setq i (+ i 1) j 0)

)
(princ)
)

Về việc bổ sung thêm vào lisp này thì mình thấy nó không nên do hạn chế của lisp. Hơn nữa cách làm này không thực tạo ra hứng thú với mình. Do vậy nếu bạn vẫn muốn sửa để dùng thì mình gợi ý bạn như sau:
1/- tạo một tập chọn gồ tất cả các line trong cụm.
2/- lặp qua các line này để lấy được các cụm text line riên biệt.
3/- Với mỗi cụm sử dụng lisp hiện có để move nó về điểm tương ứng. Điểm này được lấy tương ứng với các điểm giao có được từ lisp và offset nó theo khoảng cách bạn nhập vào.

bạn hãy thử làm, nếu vướng mắc mình sẽ giúp thêm.
Chúc bạn vui.
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#52 Trang72

Trang72

    biết vẽ ellipse

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

Đã gửi 04 February 2013 - 03:59 PM

Ngon rồi Bác Bình Ơi. Em không biết nhiều về lisp Bác Bình ơi Bác giúp thì giúp em cho chót kính nhờ bác. Em cám ơn Bác nhiều.
  • 0

#53 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

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

Đã gửi 05 February 2013 - 12:16 PM

Ngon rồi Bác Bình Ơi. Em không biết nhiều về lisp Bác Bình ơi Bác giúp thì giúp em cho chót kính nhờ bác. Em cám ơn Bác nhiều.

Hề hề hề,
Thú thực là không khoái lắm với cái lisp này, song vì bạn thích dùng nó nên thôi đành ngậm ...... ớt sửa chút chút để bạn xài thử. Kết cấu lisp kiểu này hơi ...... lẩm cẩm, tuy nó vẫn chạy được xong khá mất thời gian.
Của bạn đây, xài thử và cho ý kiến.


(defun giaodiem (a1 b1 c1)
(setq x (cadr a1)
y (+ (/ (* (- x (cadr b1)) (- (caddr c1) (caddr b1))) (- (cadr c1) (cadr b1))) (caddr b1))
)
(list 10 x y (cadddr a1))
)
;***************************************************************
(defun C:Mm()
(command "undo" "be")
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)

(prompt "\nChon doi tuong di chuyen:")
(setq ss (ssget)
Q (sslength ss)
)
(setq pp (ssget "X" '((0 . "LINE") (62 . 5)))
P (sslength pp)
)
(setq i 0 j 0)
(setq KC (getreal "\n Nhap khoang cach tu duong mat dat toi line ghi chu: "))
(while (< i Q )
(setq A (entget (setq en (ssname ss i))))
(while (< j P)

(setq B (entget (ssname pp j)))
(setq
L11 (assoc 10 B )
M11 (assoc 11 B )
)
(if (= (cdr (assoc 0 A)) "INSERT")
(progn
(setq L10 (assoc 10 A))

(if (and (>= (cadr L10) (cadr L11)) (<= (cadr L10) (cadr M11)))
(progn
(setq D10 (giaodiem L10 L11 M11)
A (subst D10 L10 A) )
(entmod A)
)
)
)
)

(if (= (cdr (assoc 0 A)) "LINE")
(progn
` (setq L10 (mid (cdr (assoc 10 A)) (cdr (assoc 11 A))))
(setq sst (acet-ss-to-list (setq ss1 (ssget "w" (list (- (car L10) 45) (- (cadr L10) 45))
(list (+ (car L10) 45) (+ (cadr L10) 45))
(list (cons 0 "text") (cons 8 "025"))))) )
(foreach txt sst
(setq pt (cdr (assoc 11 (setq enl (entget txt)))))
(if (> (cadr pt) (cadr L10))
(entmod (subst (cons 11 (list (car L10) (+ (cadr L10) 12.5))) (assoc 11 enl) enl))
(entmod (subst (cons 11 (list (car L10) (- (cadr L10) 12.5))) (assoc 11 enl) enl))
)
)
;;;(setq L10 (cons 10 L10))

(if (and (>= (car L10) (cadr L11)) (<= (car L10) (cadr M11)))
(progn
(setq D10 (cdr (giaodiem (list 10 (car L10) (cadr L10) 0.0) L11 M11)))
(command "move" en ss1 "" L10 (list (car D10) (+ (cadr D10) KC)))
(setq A (entget en))
)
)

)
)

(setq j (+ j 1) )
)
(setq i (+ i 1) j 0)

)
(setvar "osmode" oldos)
(command "undo" "e")
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;
(defun mid (p1 p2)
(setq pt (list (/ (+ (car p1) (car p2)) 2) (/ (+ (cadr p1) (cadr p2)) 2)))
)
Bạn nên lưu ý vài điều như sau:
1/- Trước khi chạy lisp nên dùng overkill để tiêu diệt bớt kẻ thù của lisp.
2/- Các thuộc tính của các line mặt đất, text, line ghi chú .... phải đảm bảo giống như trên bản vẽ bạn đã gửi. Chỉ cần các thuộc tinh này thay đổi thì lisp sẽ có thể cho bạn đi tàu bay giấy ngay.
3/- Khi quét chọn các đối tượng cần di chuyển, bạn nên quét chọn từng vùng nhỏ tránh lấy thêm vài nghìn đối tượng không mong muốn. Số lượng đối tượng này càng to thì lisp chạy càng lâu và không ngoại trừ nó tẩu hỏa nhập loanh quanh thì bạn mệt người.
4/- Lisp yêu cầu bạn chọn cả block, cả các cụm text-line cần di chuyển trong một lần chọn duy nhất nên bạn cứ nhẩn nha mà chọn cho tới khi đủ khoái. Miễn rằng đừng chọn nhầm mà tự làm khổ mình. Trong trường hợp nhỡ nhầm, hãy cứ yên tâm chạy lisp rồi undo một phát nó sẽ trả về nguyên trạng trước khi chạy lisp. Nếu không muốn mất thời gian ngồi đợi có thể nhấn ESC rồi nhập lệnh undo, end. Sau đó undo một phát là nó quên hết những gì đã làm và trả cho bạn bản vẽ u như kỵ.
5/- Kết quả của lisp là chuyển các block trên bản vẽ mà bạn cần chuyển về nằm trên đường line mặt đất với tọa độ x không thay đổi. các cụm text-line sẽ chuyển tới vị trí cách đường line mặt đất một khoảng mà bạn được yêu cầu nhập vô trước đó và nằm cùng toạc độ x vốn có của điểm giữa line trong mỗi cụm. Đồng thời nó căn chỉnh cho các text nằm ngay ngắn với line theo một trật tự xác định. Nếu muốn các cụm này nằm trên , dưới hay chình ình giữa đường line mặt đất thì bạn nhập giá trị khoảng cách này là các số lớn hơn, nhỏ hơn hay bằng 0.

Chúc bạn một năm sắp mới vui vẻ....
Hề hề hề
  • 1
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.