TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: cjw on December 18, 2009, 12:23:34 AM
-
;;; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;; + box_text +
;;; + Created by C. Alan Butler +
;;; + Copyright 2005 +
;;; + by Precision Drafting & Design All Rights Reserved. +
;;; + Contact at ab2draft@TampaBay.rr.com +
;;; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;;
;;; VERSION
;;; 1.2 Jan 24, 2006 UCS corrections
;;;
;;; FUNCTION
;;; Return Box coordinates for an dtext object in any UCS, any angle.
;;;
;;; USAGE
;;; (box_text ent)
;;;
;;; ARGUMENTS
;;; ent = text ename
;;;
;;; RETURNS
;;; list of 4 points for box, (ll lr ur ul)
;;;
<edit: old code removed>
-
Can you describe your problem.
is it that the smallest box is a different size for the horizontal text than the vertical text ?
-
see the dwg with shx file.
Maybe the "box_text" have not right work.
-
Can you describe your problem.
is it that the smallest box is a different size for the horizontal text than the vertical text ?
the horizontal text is OK.
the vertical text does not get right box points.
-
;-------------------------------------------------------------------------------
; Program Name: Text-Box.lsp [Text-Box R2]
; Created By: Terry Miller (Email: terrycadd@yahoo.com)
; c:Text-Box - Draws a polyline Text Box outlining Text, Mtext and Dimensions.
;-------------------------------------------------------------------------------
(defun c:TB () (c:Text-Box)) ;Shortcut
(defun c:Text-Box (/ Cnt# EntName^ Osmode# Pt PtsList@ SS&)
(setq Osmode# (getvar "OSMODE"))
(princ "\nSelect Text, Mtext or Dimension for Text Box")
(if (setq SS& (ssget '((-4 . "<OR")
(0 . "TEXT")
(0 . "MTEXT")
(0 . "DIMENSION")
(-4 . "OR>")
)
)
)
(progn
(command "UNDO" "BEGIN")
(setvar "OSMODE" 0)
(setq Cnt# 0)
(repeat (sslength SS&)
(setq EntName^ (ssname SS& Cnt#))
(setq PtsList@ (append (Text-Box EntName^) (list "C")))
(command "PLINE" (foreach Pt PtsList@ (command Pt)))
(setq Cnt# (1+ Cnt#))
) ;repeat
(command "UNDO" "END")
(setvar "OSMODE" Osmode#)
) ;progn
(princ "\nNo Text, Mtext or Dimension selected.")
) ;if
(princ)
) ;defun c:Text-Box
;-------------------------------------------------------------------------------
; Text-Box - Function for Text, Mtext and Dimension entities
; Arguments: 1
; Entity^ = Entity name of the Text, Mtext or Dimension to use
; Returns: A list of the four corners of the Text Box
;-------------------------------------------------------------------------------
(defun Text-Box (Entity^ / Ang~ AngEntity~
Corners: EntList@ EntNext^ EntType$ First
List@ MovePt NewPts@ Pt Return@
Textboxes@ X X1 X3
Y Y1 Y3 Zero
)
;-----------------------------------------------------------------------------
; Corners: - Calculates the four corners of the Text Box
;-----------------------------------------------------------------------------
(defun Corners: (Entity^ / Ang~ Corners@ Dist~
EntList@ Ins Pt Pt1 Pt2
Pt3 Pt4
)
(setq EntList@ (entget Entity^)
Corners@ (textbox EntList@)
Ang~ (cdr (assoc 50 EntList@))
Ins (cdr (assoc 10 EntList@))
Pt (mapcar '+ (car Corners@) Ins)
Pt1 (polar Ins (+ Ang~ (angle Ins Pt)) (distance Ins Pt))
Pt (mapcar '+ (cadr Corners@) Ins)
Pt3 (polar Ins (+ Ang~ (angle Ins Pt)) (distance Ins Pt))
Dist~ (* (distance (car Corners@) (cadr Corners@))
(cos (- (angle Pt1 Pt3) Ang~))
)
Pt2 (polar Pt1 Ang~ Dist~)
Pt4 (polar Pt3 Ang~ (- Dist~))
) ;setq
(list Pt1 Pt2 Pt3 Pt4)
) ;defun Corners:
;-----------------------------------------------------------------------------
(setq EntList@ (entget Entity^)
EntType$ (cdr (assoc 0 EntList@))
) ;setq
(cond
((= EntType$ "TEXT")
(setq Return@ (Corners: Entity^))
) ;case
((or (= EntType$ "MTEXT") (= EntType$ "DIMENSION"))
(command "UNDO" "MARK")
(setq EntNext^ (entlast))
(command "EXPLODE" Entity^)
(if (= EntType$ "DIMENSION")
(command "EXPLODE" (entlast))
) ;if
(while (setq EntNext^ (entnext EntNext^))
(if (= "TEXT" (cdr (assoc 0 (entget EntNext^))))
(setq Textboxes@
(append Textboxes@ (list (Text-Box EntNext^)))
)
) ;if
) ;while
(command "UNDO" "BACK")
(setq AngEntity~ (angle (nth 0 (nth 0 Textboxes@))
(nth 1 (nth 0 Textboxes@))
)
Zero (list 0 0)
First t
) ;setq
(foreach List@ Textboxes@
(foreach Pt List@
(setq X (car Pt)
Y (cadr Pt)
)
(if First
(setq First nil
X1 X
Y1 Y
)
) ;if
(if (< X X1)
(setq X1 X)
)
(if (< Y Y1)
(setq Y1 Y)
)
) ;foreach
) ;foreach
(if (or (< X1 0) (< Y1 0))
(progn
(cond
((and (< X1 0) (< Y1 0)) (setq MovePt (list X1 Y1)))
((< X1 0) (setq MovePt (list X1 0)))
((< Y1 0) (setq MovePt (list 0 Y1)))
) ;cond
(command "UCS" "M" MovePt)
) ;progn
) ;if
(setq First t)
(foreach List@ Textboxes@
(foreach Pt List@
(setq Ang~ (- (angle Zero Pt) AngEntity~))
(setq Pt (polar Zero Ang~ (distance Zero Pt)))
(setq X (car Pt)
Y (cadr Pt)
)
(if First
(setq First nil
X1 X
X3 X
Y1 Y
Y3 Y
)
) ;if
(if (< X X1)
(setq X1 X)
)
(if (< Y Y1)
(setq Y1 Y)
)
(if (> X X3)
(setq X3 X)
)
(if (> Y Y3)
(setq Y3 Y)
)
) ;foreach
) ;foreach
(command "UCS" "W")
(setq NewPts@ (list (list X1 Y1)
(list X3 Y1)
(list X3 Y3)
(list X1 Y3)
)
)
(foreach Pt NewPts@
(setq Ang~ (+ (angle Zero Pt) AngEntity~))
(setq Pt (polar Zero Ang~ (distance Zero Pt)))
(setq Return@ (append Return@ (list Pt)))
) ;foreach
) ;case
) ;cond
Return@
) ;defun Text-Box
;-------------------------------------------------------------------------------
(princ)
All right. It's OK.
-
:) .. and it's a different program :)
great that you found a solution. Alan (CAB) may be interested in your first post.
-
Sorry cjw I had not posted my updated routine.
Find the complete Text Box routine here: http://www.theswamp.org/index.php?topic=7003.msg86092#msg86092
The updated dText subroutine is in the 2.3 version in the link above. It was fixed in 2008. :?
If no one complains I forget to update as I make changes to the routines.
;;; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;; + box_text +
;;; + Created by C. Alan Butler +
;;; + Copyright 2005 +
;;; + by Precision Drafting & Design All Rights Reserved. +
;;; + Contact at ab2draft@TampaBay.rr.com +
;;; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;;
;;; VERSION
;;; 1.2 Jan 24, 2006 UCS corrections
;;; 1.3 Nov 26, 2008 Fixed Bug when text was rotated
-
Very nice routine, Alan.:)
The "eye candy" of dialog box and different box types are superb, IMO.
Natch, I have my own home-grown command line version, but never took it anywhere close to yours.
Think I'll switch.:)
fwiw, here's how I did my boxtext:
;;;--------------------boxtext--------------------------------------
;;; Author: Herman Mayfarth
;;; Purpose: draws a lwpolyline rectangle to enclose a TEXT entity
;;; Parameters: ename - entity name of TEXT entity
;;; layer, color, ltype - what they say
;;; External functions: dxf lwrect
;;;----------------------------------------------------------------
(defun boxtext (ename layer color ltype / txtent tb p10 h ang1 delta p1 d1 boxang boxdia p3)
(setq tb (textbox (entget ename))
p10 (dxf 10 ename)
h (dxf 40 ename)
ang1 (dxf 50 ename)
delta (/ h 2);adjust to suit
p1 (polar p10 (+ (/(* 5 pi) 4) ang1) (* (sqrt 2) delta))
d1 (+(caadr tb) (* 2 delta))
boxang (atan (+ h (* 2 delta)) d1)
boxdia (* (/ 1 (cos boxang)) d1)
p3 (polar p1 (+ boxang ang1) boxdia)
);setq
(lwrect p1 p3 ang1 layer color ltype)
);boxtext
(defun dxf (code ent) (cdr (assoc code (entget ent))))
;;;-------------------------lwrect------------------------------------
;;; Purpose: draws a lightweight polyline rectangle
;;; Params: p1,p3 - WCS points at lower left & upper right corners
;;; rotate - rotation angle of long 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)
(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
& similarly for boxmtext
Thx for your very polished work.
-
Sorry cjw I had not posted my updated routine.
Find the complete Text Box routine here: http://www.theswamp.org/index.php?topic=7003.msg86092#msg86092
The updated dText subroutine is in the 2.3 version in the link above. It was fixed in 2008. :?
If no one complains I forget to update as I make changes to the routines.
;;; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;; + box_text +
;;; + Created by C. Alan Butler +
;;; + Copyright 2005 +
;;; + by Precision Drafting & Design All Rights Reserved. +
;;; + Contact at ab2draft@TampaBay.rr.com +
;;; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;;
;;; VERSION
;;; 1.2 Jan 24, 2006 UCS corrections
;;; 1.3 Nov 26, 2008 Fixed Bug when text was rotated
OK, where do we find bt-single.sld???
-
I think CAB forgot to upload it :wink:
Here, for now:
http://www.theswamp.org/index.php?topic=4723.msg81560#msg81560 (http://www.theswamp.org/index.php?topic=4723.msg81560#msg81560)
-
Sorry Steve, I change the lsp attachment to a zip with needed files.
http://www.theswamp.org/index.php?topic=7003.msg86092#msg86092
Thanks Herman 8-)
-
Sorry Steve, I change the lsp attachment to a zip with needed files.
http://www.theswamp.org/index.php?topic=7003.msg86092#msg86092
Thanks Herman 8-)
Grabbed it, thanks... we'll have fun now ! maybe a green rectangle with a red ribbon i.e. a dynamic block?
love it !!!!
-
Thanks Lee, that was quick thinking. 8-)
-
Thanks,CAB
a good reference for this program
-
Thanks Lee, that was quick thinking. 8-)
No problem, I only saw the program the other day - I must say - fantastic work Alan, as usual.
-
Did some testing & Terry's does not work in a rotated WCS but does work when using Orbit.
Herman's works in rotated WCS but not when you Orbit.
-
Thanks CAB.
Very nice work.