如何剪切穿过文本的线段？

congcong 发表于 2004-3-1 20:37:00

一个尺寸标注加上公差值后，且这个标注还是斜的，怎么用它来剪切穿过它的线段

具体要求如图所示

这个程序较麻烦，想看看各位有没有更简单的方法来实现这个功能

lee1892 发表于 2004-3-2 00:55:00

试试这个，写得简单了点:)

(defun C:DTrim (/ dim line objs text n ent) (setvar "cmdecho" 0) (command "_.undo" "_be") (setq dim (entsel "\nSelect the dimension to trim:") line (entsel "\nSelect the line to be trimed:") dimobj (vla-copy (vlax-ename->vla-object (car dim))) ) (setq ent (entlast)) (command "_.explode" (vlax-vla-object->ename dimobj) "") (while (not (eq (setq ent (entnext ent)) (entlast))) (setq objs (cons (vlax-ename->vla-object ent) objs) text (if (eq (vla-get-entityname (vlax-ename->vla-object ent)) "AcDbMText") (vlax-ename->vla-object ent) text) ) ) (command "_.trim" dim "" line "") (mapcar '(lambda (x) (vla-erase x)) objs) (command "_.undo" "_e") (princ) )

meflying 发表于 2004-3-2 09:07:00

选择时要选择标注的文本。。。

(defun c:test( / ent ent_dim ents pt_lst ang_txt height pt pt1 pt2 ptCenter dist ang pt_w1 pt_w2 pt_w3 pt_w4 os) (setq os (getvar "osmode"))

(setq ent (nentsel)) (setq ent_dim (car (last ent))) (setq ent (car ent)) (setq ents (entget ent)) (setq pt_lst (textbox (list (cons 0 "TEXT") (assoc 1 ents) (assoc 40 ents) ) ) ) (setq ang_txt (cdr (assoc 50 ents))) (setq height (/ (cdr (assoc 40 ents)) 5.0)) (setq pt (cdr (assoc 10 ents))) (setq pt1 (car pt_lst)) (setq pt2 (cadr pt_lst)) (setq ptCenter (list (/ (+ (car pt1) (car pt2)) 2.0) (/ (+ (cadr pt1) (cadr pt2)) 2.0))) (setq pt2 (list (+ (car pt2) height) (+ (cadr pt2) (* 2.0 height)))) (setq dist (distance ptCenter pt2)) (setq ang (angle pt2 ptCenter)) (setq pt_w1 (polar pt (- (+ ang_txt pi) ang) dist)) (setq pt_w2 (polar pt (+ ang_txt ang) dist)) (setq pt_w3 (polar pt (- ang_txt ang) dist)) (setq pt_w4 (polar pt (+ ang_txt pi ang) dist)) (setvar "osmode" 0) (setvar "cmdecho" 0) (command "_.wipeout" "f" "off") (command "_.wipeout" pt_w1 pt_w2 pt_w3 pt_w4 "") (entdel ent_dim) (entdel ent_dim) (setvar "osmode" os) (princ) )

congcong 发表于 2004-3-2 10:08:00

倾斜的文本出现的状况不如人意

谢谢各位，程序都不错，不过三楼的程序如果用在倾斜的文本上的时候出现的状况不如人意，能否改善？

我就是拿倾斜的且带有公差的文本没有办法，请大家帮忙。

meflying 发表于 2004-3-2 10:31:00

你要如何才如人意？

meflying 发表于 2004-3-2 10:48:00

(setq pt2 (list (+ (car pt2) height) (+ (cadr pt2) (* 2.0 height))))

此句中后面(* 2.0 ...中的2.0可以适当改大，以达到有公差时的要求（大概要到4—5左右比较合适）

龙龙仔 发表于 2004-3-2 12:30:00

;;-----------------------C:MaskDimText------------------------------------ ;;Command to place a WIPEOUT behind selected DIMENSION text (one entity) ;;&#169; 2001 Herman Mayfarth ;;Tested with AutoCAD Release 14.01 ;;Not tested with R15

;;修改 By 龍龍仔(LUCAS) ;;Only tested with R16 ;;Not tested with R14

;;Known limitations: ;; 1. This routine works by asking the user to select a nested MTEXT object, ;; and uses that object's entity data to define the WIPEOUT boundary. ;; If you have dimension text stacked over/under the dimension line, ;; i.e. using the \X code, this routine will _not_ mask all the text, ;; since the over/under text are separate MTEXT entities. ;; (A better & more sophisticated way would be to walk through the ;; DIMENSION block & determine the bounding box of all MTEXT objects in the ;; block, but this is a Q & D 1st attempt) ;; 2. In R14.01, on my system, if the DIMENSION has been moved or copied, ;; the WIPEOUT is incorrectly placed at the *original* location of ;; the MTEXT object.(???) Don't know why, at this point. ;; ;; Feel free to modify to suit your own needs &/or whims. ;;------------------------------------------------------------------------ ;;global function ;;test function to see if wipeout.arx is available (defun WIPEOUTP () (if (> (atoi (getvar "AcadVer")) 15) (arxload "acwipeout" NIL) (arxload "wipeout" NIL) ) ) ;wipeoutp ;; (defun C:MASKDIMTEXT (/ CECHO OLDLYR ENT FLAG OUTER BOXMTEXT LWRECT) ;;local functions ;;;--------------------boxmtext------------------------------------- ;;; Purpose: draws a lwpolyline rectangle to enclose an MTEXT entity ;;; Parameter: entity name of MTEXT entity ;;; External function: lwrect to draw the rectangle ;;;----------------------------------------------------------------- (defun BOXMTEXT (ENAME / MTXTNT P10 H ANG1 DELTA D1 BOXANG BOXDIA ATTACH VEC P1 P3 HOR VERT ) (setq MTXTNT (entget ENAME) P10 (cdr (assoc 10 MTXTNT)) H (cdr (assoc 40 MTXTNT)) HOR (cdr (assoc 42 MTXTNT)) VERT (cdr (assoc 43 MTXTNT)) ANG1 (cdr (assoc 50 MTXTNT)) ATTACH (cdr (assoc 71 MTXTNT)) VEC (getvar "UCSXDIR") ANG1 (+ (atan (cadr VEC) (car VEC)) ANG1) DELTA (/ H 2) ;adjust as req'd D1 (+ HOR (* 2 DELTA)) BOXANG (atan (+ VERT (* 2 DELTA)) D1) BOXDIA (* (/ 1 (cos BOXANG)) D1) ) ;setq (cond ((= ATTACH 1) ;top left (setq P1 (polar P10 (+ (/ (* 3 pi) 2) ANG1) (+ VERT DELTA))) ) ((= ATTACH 2) ;top center (setq P1 (polar (polar P10 (+ pi ANG1) (/ HOR 2)) (+ (/ (* 3 pi) 2) ANG1) (+ VERT DELTA) ) ) ) ((= ATTACH 3) ;top right (setq P1 (polar (polar P10 (+ pi ANG1) HOR) (+ (/ (* 3 pi) 2) ANG1) (+ VERT DELTA) ) ) ) ((= ATTACH 4) ;middle left (setq P1 (polar P10 (+ (/ (* 3 pi) 2) ANG1) (+ (/ VERT 2) DELTA)) ) ) ((= ATTACH 5) ;middle center (setq P1 (polar (polar P10 (+ pi ANG1) (/ HOR 2)) (+ (/ (* 3 pi) 2) ANG1) (+ (/ VERT 2) DELTA) ) ) ) ((= ATTACH 6) ;middle right (setq P1 (polar (polar P10 (+ pi ANG1) HOR) (+ (/ (* 3 pi) 2) ANG1) (+ (/ VERT 2) DELTA) ) ) ) ((= ATTACH 7) ;bottom left (setq P1 (polar P10 (+ (/ (* 3 pi) 2) ANG1) DELTA)) ) ((= ATTACH 8) ;bottom center (setq P1 (polar (polar P10 (+ pi ANG1) (/ HOR 2)) (+ (/ (* 3 pi) 2) ANG1) DELTA ) ) ) ((= ATTACH 9) ;bottom right (setq P1 (polar (polar P10 (+ pi ANG1) HOR) (+ (/ (* 3 pi) 2) ANG1) DELTA ) ) ) ) ;cond (setq P1 (polar P1 (+ pi ANG1) DELTA) P3 (polar P1 (+ BOXANG ANG1) BOXDIA) ) ;setq (LWRECT P1 P3 ANG1 (getvar "CLAYER") 256 (getvar "CELTYPE")) ) ;boxmtext ;;;-------------------------lwrect------------------------------------ ;;; Purpose: draws a lightweight polyline rectangle ;;; Params: p1,p3 - WCS points at opposite corners ;;; rotate - rotation angle of selected axis in radians ;;; layer, color, ltype what they say ;;; Returns: EAL of entity (defun LWRECT (P1 P3 ROTATE LAYER COLOR LTYPE / D13 ABOX P2 P4 ELIST) (setq D13 (distance P1 P3) ABOX (- (angle P1 P3) ROTATE) P2 (polar P1 ROTATE (* (cos ABOX) D13)) P4 (polar P1 (+ ROTATE (/ pi 2)) (* (sin ABOX) D13)) ) (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 6 LTYPE) (cons 8 LAYER) '(43 . 0) (cons 62 COLOR) '(90 . 4) (cons 10 P1) (cons 10 P2) (cons 10 P3) (cons 10 P4) '(70 . 1) ;closed pline - must follow G.C. 10s ) ) ) ;lwrect ;;Main program ;;if wipeout.arx is available (if (WIPEOUTP) ;;proceed (progn ;;save sysvars (setq CECHO (getvar "CMDECHO") OLDLYR (getvar "CLAYER") ) ;;start UNDO group (command "_.UNDO" "BEGIN") ;;setup a layer for WIPEOUTs (command "_.LAYER" "M" "WIPEOUTS" "") ;;loop until an MTEXT entity in a DIMENSION is selected (setq FLAG t) (while FLAG (setq ALIST (nentsel "\nSelect Dimension Text to Mask: ") ENT (car ALIST) OUTER (car (last ALIST)) ) (if (= "MTEXT" (cdr (assoc 0 (entget ENT)))) (setq FLAG NIL) ) ) ;while ;;draw a LWPOLYLINE rectangle enclosing the MTEXT (BOXMTEXT ENT) ;;call command to draw the WIPEOUT using the preceding LWPOLYLINE (command "_.wipeout" "f" "off" "_.wipeout" "p" (entlast) "y") ;;now call draworder to bring the DIMENSION to the front ;;it would be nice if there is a better way, that doesn't force a regen ;;the only sure way I can think of is to delete the DIMENSION and remake it (command "_.draworder" OUTER "" "front") ;causes a regen ;;restore sysvars & end UNDO group (setvar "CLAYER" OLDLYR) (command "_.UNDO" "END") (setvar "CMDECHO" CECHO) ) ;progn (alert "Wipeouts Not Available.") ) ;if (princ) ) ;C:MaskDimText

meflying 发表于 2004-3-2 14:44:00

改进了一下，主要是我发现标注中的文本都是居中对齐的，不知道是不是都这样的。。。(defun c:test( / ent ent_dim ents pt_lst ang_txt height pt width dist ang pt_w1 pt_w2 pt_w3 pt_w4 os)
(setq os (getvar "osmode"))
(setq ent (nentsel))
(setq ent_dim (car (last ent)))
(setq ent (car ent))
(setq ents (entget ent))
(setq pt_lst (textbox (list (cons 0 "TEXT")
            (assoc 1 ents)
            (assoc 40 ents)
   )
            )
)
(setq ang_txt (cdr (assoc 50 ents)))
(setq pt (cdr (assoc 10 ents)))
(setq height (cdr (assoc 43 ents)))
(setq width (cdr (assoc 42 ents)))
(setq height (* height 1.2))
(setq width (* width 1.2))
(setq ang (atan (/ height width)))
(setq dist (/ (sqrt (+ (expt height 2) (expt width 2))) 2.0))
(setq pt_w1 (polar pt (- (+ ang_txt pi) ang) dist))
(setq pt_w2 (polar pt (+ ang_txt ang) dist))
(setq pt_w3 (polar pt (- ang_txt ang) dist))
(setq pt_w4 (polar pt (+ ang_txt pi ang) dist))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(command "_.wipeout" "f" "off")
(command "_.wipeout" pt_w1 pt_w2 pt_w3 pt_w4 "")
(entdel ent_dim)
(entdel ent_dim)
(setvar "osmode" os)
(princ)
)

congcong 发表于 2004-3-2 15:44:00

谢谢，改进后的程序没有问题了。

xjjy 发表于 2004-9-28 11:16:00

其实并不是真正剪切，这个很好，

如果要恢复，要如何做？

页: [1] 2

明经CAD社区's Archiver

如何剪切穿过文本的线段？

倾斜的文本出现的状况不如人意