;Title - Erin Stephens Lisp Page
;Lisp Page from Internet - Internet Worldwide Communications
; ***  Balloon   [Version 1.5] 8/22/95  ***
;
;Copyright 1995 Manu-Soft Computer Services
;
; ***************************************
; ****  Author:  Owen Wengerd        ****
; ****                               ****
; ****  Manu-Soft Computer Services  ****
; ****  P.O. Box 84                  ****
; ****  Fredericksburg, OH  44627    ****
; ****  (330) 695-5903               ****
; ****  Compu-Serve ID:  71324,3252  ****
; ***************************************
;
;
; This program creates leaders and encloses the leader text in a
; 'Balloon'. If the text has fewer than 3 characters, the balloon is
; a DONUT;  if longer, the balloon is an ELLIPSE. Both text and balloon
; continue at the same angle as the last line in the leader. Editable
; parameters let you put the balloon on a specific layer, adjust the
; gap between text and balloon and the balloon's lineweight, and specify
; whether the leader is a block or individual entities.
;
; Tested on AutoCAD R12 & R13, DOS/Windows (Should work in R11)

(defun C:BALLOON

  (/ tmp ts th nh ip sp ali le errexit bx acadver
     LBLOCK BLAYER TEXTGAP CHARWIDTH BWIDTH)


;**************************************************************************
                           
                           ;Balloons are created as blocks
    (setq LBLOCK T)        ;  unless LBLOCK is set to nil here.
  
                           ;Layer For Balloon Placement:
    (setq BLAYER "sdim")   ;   "XXXX" = Place on layer XXXX
                           ;   nil    = Use current layer

    (setq TEXTGAP 0.8)     ;Desired Gap Between Text & Balloon
                           ;   (1 unit = Dimension Text Height)

    (setq CHARWIDTH 1.0)   ;Average Width of a 1-Unit High Character
                           ;   (** Used in Release 11 Only **)

    (setq BWIDTH 0.04)     ;Balloon Line Weight
                           ;   nil = no width
                           ;   (1 unit = Dimension Text Height)
                           ;   (** No effect if balloon is elliptical
                           ;    & PELLIPSE=0 in Release 13 **)

;**************************************************************************


  (setq acadver (read (substr (getvar "ACADVER") 1 2)))
  (if (/= (type acadver) 'INT) (setq acadver 0))

  (defun errexit (s)
    (princ "\nError:  ")
    (princ s)
    (restore)
  )

  (defun bx ()
    (if le (entdel le))
    (setvar "CMDECHO" (car oldvar))
    (setvar "BLIPMODE" (cadr oldvar))
    (setvar "OSMODE" (nth 2 oldvar))
    (setvar "CLAYER" (nth 3 oldvar))
    (setvar "DONUTID" (nth 4 oldvar))
    (setvar "DONUTOD" (nth 5 oldvar))
    (setq *error* olderr)
    (princ)
  )

  ;*** Main Program ***
  (setq T (not nil))
  (setq olderr  *error*
        restore bx
        *error* errexit
  )
  (setq oldvar 
    (list 
      (getvar "CMDECHO") 
      (getvar "BLIPMODE") 
      (getvar "OSMODE")
      (getvar "CLAYER")
      (getvar "DONUTID")
      (getvar "DONUTOD")
    )
  )
  (setvar "CMDECHO" 0)
  (setvar "BLIPMODE" 0)
  (setvar "OSMODE" 0)
  (terpri)
  (if (= acadver 11)            ;Is this R11?
    (defun textbox (elist)      ;  If so, define a custom textbox function
      (list
        '(0 0 0)
        (list
          (* (strlen (cdr (assoc 1 elist))) (cdr (assoc 40 elist)) CHARWIDTH)
          (cdr (assoc 40 elist))
          0
        )
      )
    )
  )
  (if 
    (= 0 
      (setq th 
        (cdr (assoc '40 (tblsearch "style" (getvar "textstyle"))))
      )
    ) 
    (setq nh (setq th (* (getvar "DIMTXT") (getvar "DIMSCALE"))))
    (setq nh nil)
  )
  (if BLAYER  
    (command "._LAYER"
      (if (tblsearch "LAYER" BLAYER) "_S" "_M")
      BLAYER
      ""
    )
  )
  (if (setq ip (setq sp (getpoint "Pick Leader Start Point: ")))
    (progn
      (entmake (list '(0 . "POINT") (cons 10 (trans sp 1 0))))
      (setq le (entlast))
      (command "._DIM1" "_LEADER")
      (setvar "CMDECHO" 1)
      (command sp)
      (while
        (progn 
          (initget 128)
          (setq sp (getpoint sp))
        )
        (command sp)
      )
      (setvar "CMDECHO" 0)
      (command)
      (setq sp (trans (cdr (assoc '11 (entget (entlast)))) 0 1))
      (setq ali (angle (trans (cdr (assoc '10 (entget (entlast)))) 0 1) sp))  
      (setq tmp (getstring T "Enter Balloon Text:  "))
      (setq ts (textbox (list (cons '1 tmp) (cons '40 th))))
      (setq ts 
        (list 
          (+ (- (car (cadr ts)) (car (car ts))) (* 2 TEXTGAP th))
          (* 3 TEXTGAP th)
        )
      )
      (command "._TEXT"
               "_M"
               (polar 
                 sp 
                 ali 
                 (* 0.5 (if (<= (strlen tmp) 2) (cadr ts) (car ts))) 
               )
      )
      (if nh (command th))
      (command 
        (if (<= (strlen tmp) 2)
          '0
          (rtd
            (if 
              (and (< ali (* 3 (/ pi 2))) (> ali (/ pi 2))) 
              (+ ali pi) 
              ali
            )
          )
        )
        tmp
      )
      (if (<= (strlen tmp) 2)
        (command "._DONUT" 
                 (cadr ts) 
                 (cadr ts) 
                 (polar 
                   sp 
                   ali 
                   (* 0.5 (if (<= (strlen tmp) 2) (cadr ts) (car ts))) 
                 )
                 ""
        )
        (command "._ELLIPSE" 
                 sp 
                 (polar sp ali (if (<= (strlen tmp) 2) (cadr ts) (car ts)))
                 (/ (cadr ts) 2)
        )
      )
      (if 
        (and BWIDTH
             (> BWIDTH 0)
             (not (and (= acadver 13) (zerop (getvar "PELLIPSE")) (> (strlen tmp) 2)))
        ) 
        (command "._PEDIT" (entlast) "W" (* th BWIDTH) "X")
      )
      (if LBLOCK
        (progn
          (entmake (list 
            (cons '0 "BLOCK") 
            (cons '2 "*U") 
            (cons '70 1) 
            (cons '10 ip)
          ))
          (setq th (setq tmp le))
          (while (setq tmp (entnext tmp))
            (entmake (entget tmp))
          ) 
          (setq tmp (entmake (list (cons '0 "ENDBLK"))))
          (while (setq th (entnext th))
            (entdel th)
          ) 
          (entdel le)
          (setq le nil)
          (entmake (list 
            (cons '0 "INSERT") 
            (cons '2 tmp) 
            (cons '10 ip)
          ))
        )
      )   
    )  
  )  
  (restore)
)