home *** CD-ROM | disk | FTP | other *** search
/ BUG 15 / BUGCD1998_06.ISO / aplic / felixcad / fcaddata.z / FLX_TCOR.LSP < prev    next >
Lisp/Scheme  |  1996-09-30  |  13KB  |  329 lines
  1. ;;; FLX_TCOR.LSP
  2. ;;; =====================================================================
  3. ;;; (C)opyright: Felix Computer Aided Technologies GmbH 1995-96 
  4. ;;; Created:     Jan 30,1995 vp
  5. ;;; Modified:    Aug 30, 1996
  6. ;;; =====================================================================
  7. ;;; Command: TCORRECT
  8. ;;; This utility allows to correct text in the drawing.
  9. ;;; The user is prompted to select text objects to be modified.
  10. ;;; =====================================================================
  11.  
  12. (defun FLX_TCORRECT ( / prt_list luprec auprec lunits aunits angbase
  13.                         textsize textfont
  14.                         FINDFONT MODENT CHANGE_SINGLE CHANGE_GLOBAL 
  15.                         ss c n e w new ct os osl ns nsl ch s si tmp el)
  16.  
  17.   ;;; Prompt List
  18.  
  19.   (setq prt_list (list
  20.     "Select text...\n"        ;0
  21.     "Font"                    ;1
  22.     "Text Height"             ;2
  23.     "Insertion Angle"         ;3
  24.     "Qblique Angle"           ;4
  25.     "Width Factor"            ;5
  26.     "No or invalid entry in edit box: "  ;6
  27.     "Alert"                   ;7
  28.     " text entities selected" ;8
  29.     "No text selected!"       ;9
  30.   ))
  31.   (if FLX_XLANGUAGE (FLX_XLANGUAGE "_tcor" nil))     
  32.  
  33.   ;;; -------------------------------------------------------------------
  34.   (defun FINDFONT( / s1 lst)
  35.     (setq s1 (tblnext "STYLE" T))
  36.     (setq lst (list (cdr (assoc 2  s1))))
  37.     (while (setq s1 (tblnext "STYLE"))
  38.       (setq lst (append lst (list (cdr (assoc 2 s1)))))
  39.     )
  40.     (setq lst (reverse lst))
  41.   )
  42.   ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
  43.   ;;; MODENT function to 'entmod' entity
  44.   ;;; e = entity list / var = dotted pair index / new = new content/value
  45.   (defun MODENT (e var new)
  46.     (setq e (subst (cons var new) (assoc var e) e))
  47.     (entmod e)
  48.   )
  49.   ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
  50.   (defun CHANGE_GLOBAL (tmp)
  51.      ;;; Replace Text
  52.      (if tmp (setq OS  (caar tmp)  NS  (cadar tmp)))
  53.      (if OS  (setq OSL (strlen OS) NSL (strlen NS)))
  54.      (if (and OSL (> OSL 0))
  55.        (progn
  56.          (setq c 0)
  57.          (repeat (sslength ss)
  58.          (setq ch nil
  59.                si 1
  60.                e  (entget (ssname ss c))
  61.                s  (cdr (assoc 1 e))
  62.           )
  63.           (if (member (cdr (assoc 0 e)) '("TEXT" "ATTDEF"))
  64.             (progn
  65.               (while (= osl (setq sl (strlen (setq st (substr s si osl)))))
  66.                 (if (= st os)
  67.                   (progn
  68.                     (setq s  (strcat (substr s 1 (1- si)) ns (substr s (+ si osl))))
  69.                     (setq si (+ si nsl) ch T )
  70.                    )
  71.                    (setq si (1+ si)) ; else
  72.                  )
  73.                 )
  74.                 (if ch (MODENT e 1 s))
  75.               )
  76.             )
  77.             (setq c (1+ c))
  78.          ) ; repeat
  79.        )
  80.       )
  81.     ; change other properties
  82.     (if (= (type (setq tmp (cadr tmp))) 'LIST) (progn
  83.       (setq c 0)
  84.       (repeat (sslength ss)
  85.         (setq e (entget (ssname ss c)))
  86.         (foreach el tmp (setq e (subst (cons (car el)(cadr el)) (assoc (car el) e ) e)) )
  87.         (entmod e)
  88.         (setq c (+ c 1))
  89.        )
  90.     ))    
  91.   ) ; defun
  92.   ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
  93.   ; MAIN
  94.   ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
  95.   (FLX_FUNC_INIT) ;;; Global Error Handler
  96.   (setq
  97.     lunits   (getvar "LUNITS")
  98.     luprec   (getvar "LUPREC")
  99.     aunits   (getvar "AUNITS")
  100.     auprec   (getvar "AUPREC")
  101.     angbase  (getvar "ANGBASE")
  102.     textsize (getvar "TEXTSIZE")
  103.     textfont (getvar "TEXTSTYLE")
  104.   )
  105.   ; object selection
  106.   (princ (nth 0 prt_list)) ;;;@Select text ...\n"
  107.   (setq selset (ssget))
  108.   (setq ss (ssadd) ss_index 0)
  109.   ; reduced selection set
  110.   (repeat (sslength selset)
  111.      (setq ename (ssname selset ss_index))
  112.      (setq e (entget ename))
  113.      (if (member (cdr (assoc 0 e)) '("TEXT" "ATTDEF")) (ssadd ename ss))
  114.      (setq ss_index (1+ ss_index))
  115.   )
  116.   (setq selset nil)
  117.   (if (> (sslength ss) 0)
  118.       (progn
  119.         (princ (strcat (itoa (sslength ss)) (nth 8 prt_list) )) ;;; ###@" text entities selected"
  120.         (if (setq tmp (FLX_EDIT_GLOBAL))(CHANGE_GLOBAL tmp))
  121.         ;;; ### if single 
  122.       )
  123.       (princ (nth 9 prt_list))  ;;; @No text selected!
  124.   )
  125.   (FLX_FUNC_EXIT) (setq *error* nil)
  126.   (princ)
  127. )
  128.  
  129. ;;; ===========================================================================
  130. ;;; FLX_EDIT_GLOBAL 
  131. ;;; ===========================================================================
  132.  
  133. (defun FLX_EDIT_GLOBAL ( / ret READCONTROLS SETMODE DlgInit)
  134.  
  135.   (defun READCONTROLS ( / ret1 ret2 err2 tmp el)
  136.    ;;; Text Font
  137.     (if (= (Dlg_TileGet "retain1") "0")(progn
  138.       (setq tmp (Dlg_TileGet "Font2")) 
  139.       (if (tblsearch "STYLE" tmp)
  140.           (setq ret2 (append ret2 (list (list 7 tmp))))
  141.           (setq err2 (append err2 (list (nth 1 prt_list)))) ;;;@Font
  142.       )
  143.     ))
  144.    ;;; Text Size
  145.     (if (= (Dlg_TileGet "retain2") "0")(progn
  146.       (setq tmp (Dlg_TileGet "Height2"))
  147.       (setq tmp (distof tmp)) ;;; current unit system specification to float
  148.       (if (=  tmp 0.00)
  149.         (setq err2 (append err2 (list (nth 2 prt_list)))) ;;;@Text Height
  150.         (setq ret2 (append ret2 (list (list 40 tmp))))
  151.       )
  152.     ))
  153.     ;;; Insertion Angle
  154.     (if (= (Dlg_TileGet "retain3") "0")(progn
  155.       (setq tmp (Dlg_TileGet "Angle2"))
  156.       (setq tmp (angtof tmp aunits)) ;;; current unit system; returns radians or nil
  157.       (if  tmp
  158.         (setq ret2 (append ret2 (list (list 50 tmp))))
  159.         (setq err2 (append err2 (list (nth 3 prt_list)))) ;;;@Insertion Angle
  160.       )
  161.     ))
  162.     ;;; X Scale Factor
  163.     (if (= (Dlg_TileGet "retain5") "0")(progn
  164.       (setq tmp (Dlg_TileGet "Width2"))
  165.       (setq tmp (atof tmp)) 
  166.       (if (= tmp 0.00)
  167.         (setq err2 (append err2 (list (nth 5 prt_list)))) ;;;@Width Factor
  168.         (setq ret2 (append ret2 (list (list 41 tmp))))
  169.       )
  170.     ))
  171.     ;;; Slant Angle
  172.     (if (= (Dlg_TileGet "retain4") "0")(progn
  173.       (setq tmp (Dlg_TileGet "Oblique2"))
  174.       (setq tmp (angtof tmp 0)) ;;; decimal degrees, returns radians or nil
  175.       (if  tmp
  176.         (setq ret2 (append ret2 (list (list 51 tmp))))
  177.         (setq err2 (append err2 (list (nth 4 prt_list)))) ;;;@Qblique Angle
  178.       )
  179.     ))
  180.     (setq ret1 (list (Dlg_TileGet "Search")(Dlg_TileGet "Replace")))
  181.     (if (= (type err2) 'LIST)
  182.       (alert
  183.          (strcat 
  184.             (nth 6 prt_list) ;;;@No or invalid entry in edit box: 
  185.             (foreach el err2 (setq tmp (strcat tmp "\n" el)))
  186.             " !"
  187.          )
  188.          (nth 7 prt_list) ;;;@Alert 
  189.          "EXCLAMATION"
  190.       )
  191.       (progn 
  192.         (setq ret (list ret1 ret2)) 
  193.         (Dlg_DialogDone)
  194.       )
  195.     )
  196.   )
  197.   (defun SETMODE (x1 x2 / n)
  198.       (foreach n x1 (Dlg_TileMode n x2))
  199.       (Dlg_TileMode (cadr x1) 2)
  200.   )
  201.   (defun DlgInit ()
  202.      (if FLX$WIN95 (foreach n 
  203.         '("IDCANCEL" "IDOK" "IDHELP" "Single"
  204.            "Static1" "Static2" "Static3" "Static4" "Static5" 
  205.            "Font0" "Height0" "Angle0" "Oblique0" "Width0"
  206.            "Font1" "Height1" "Angle1" "Oblique1" "Width1"
  207.            "Font2" "Height2" "Angle2" "Oblique2" "Width2"
  208.            "retain1" "retain2" "retain3" "retain4" "retain5" 
  209.          )
  210.           (Dlg_TileSetFont n 2)
  211.      ))
  212.  
  213.       (Dlg_TileSet    "Height2"  (rtos textsize lunits luprec))
  214.       (Dlg_TileSet    "Angle2"   (angtos 0.00 aunits auprec))
  215.  
  216.       (Dlg_TileSet    "Oblique2" (angtos 0.00 0 0))
  217.       (Dlg_TileSet    "Width2"   (rtos 1.00 2 2))
  218.       (Dlg_TileSet    "retain1" "1")
  219.       (Dlg_TileSet    "retain2" "1")
  220.       (Dlg_TileSet    "retain3" "1")
  221.       (Dlg_TileSet    "retain4" "1")
  222.       (Dlg_TileSet    "retain5" "1")
  223.       (Dlg_ListStart  "Font2")(mapcar 'Dlg_ListAdd (FINDFONT))(Dlg_ListEnd)
  224.       (Dlg_TileSet    "Font2" textfont) 
  225.       ;;; Control modes
  226.       (SETMODE 
  227.             (list 
  228.               "Font0" "Height0" "Angle0" "Oblique0" "Width0"
  229.               "Font1" "Height1" "Angle1" "Oblique1" "Width1"
  230.               "Font2" "Height2" "Angle2" "Oblique2" "Width2"
  231.              )
  232.              1
  233.       )
  234.       (Dlg_TileMode  "search" 2)
  235.       ;;; Event handling
  236.       (Dlg_TileAction "retain1" "(SETMODE (list \"Font0\" \"Font1\" \"Font2\")(atoi $value))")
  237.       (Dlg_TileAction "retain2" "(SETMODE (list \"Height0\" \"Height1\" \"Height2\")(atoi $value))")
  238.       (Dlg_TileAction "retain3" "(SETMODE (list \"Angle0\" \"Angle1\" \"Angle2\")(atoi $value))")
  239.       (Dlg_TileAction "retain4" "(SETMODE (list \"Oblique0\" \"Oblique1\" \"Oblique2\")(atoi $value))")
  240.       (Dlg_TileAction "retain5" "(SETMODE (list \"Width0\" \"Width1\" \"Width2\")(atoi $value))")
  241.       (Dlg_TileAction "IDOK"    "(READCONTROLS)")
  242.       (Dlg_TileAction "IDCANCEL" "(setq ret nil)(Dlg_DialogDone)")
  243.       (Dlg_TileAction "Single"   "(setq ret nil single T)(Dlg_DialogDone)") ;###
  244.   ) 
  245.   (if (FLX_DLGDSP "flx_dlg" "TCORglobal" "(princ)" "(DlgInit)") (princ) (exit))
  246.   (setq ret ret)
  247. )
  248.  
  249. ;;; ===========================================================================
  250. ;;; FLX_EDIT_SINGLE 
  251. ;;; ===========================================================================
  252.  
  253.   (defun SING (ss_index) ;;; ###
  254.       (setq e (entget (ssname ss ss_index)))
  255.       (if (member (cdr (assoc 0 e)) '("TEXT" "ATTRIB" "ATTDEF"))  ;;; ### ATTRIB ?
  256.         (if (= (type (setq txtlst (FLX_EDIT_SINGLE e))) 'LIST)
  257.             (CHANGE_SINGLE txtlst)
  258.         )
  259.       )
  260.   )
  261.   ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
  262.   (defun CHANGE_SINGLE (txtlist / W_OUT)             
  263.      (defun W_OUT (w / ret) (setq ret (* pi (/ w 180.00))))
  264.      (setq e (subst (cons  1 (nth 0 txtlst)) (assoc 1 e) e)) ; text
  265.      (setq e (subst (cons  7 (nth 1 txtlst)) (assoc 7 e) e)) ; font
  266.      (setq tmp (atof (nth 2 txtlst)))
  267.      (setq e (subst (cons 40 tmp) (assoc 40 e) e))
  268.      (setq e (subst (cons 41 (atof (nth 5 txtlst))) (assoc 41 e) e ))
  269.      (setq e (subst (cons 50 (W_OUT (atof (nth 3 txtlst)))) (assoc 50 e) e))
  270.      (setq e (subst (cons 51 (W_OUT (atof (nth 4 txtlst)))) (assoc 51 e) e))
  271.      (entmod e)
  272.   ) 
  273.   ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
  274.  (defun FLX_EDIT_SINGLE (s / SETCONTROL RESTORE READCONTROLS DlgInit remain ret)
  275.  
  276.   (defun SETCONTROL (i s / i)
  277.     (Dlg_TileSet (strcat "Font"    i) (cdr (assoc 7 s)))
  278.     (Dlg_TileSet (strcat "Height"  i) (rtos   (cdr (assoc 40 s)) lunits luprec))
  279.     (Dlg_TileSet (strcat "Angle"   i) (angtos (cdr (assoc 50 s)) aunits auprec))
  280.     (Dlg_TileSet (strcat "Oblique" i) (angtos (cdr (assoc 51 s)) 0      0     )) 
  281.     (Dlg_TileSet (strcat "Width"   i) (rtos   (cdr (assoc 41 s)) 2      luprec))
  282.   )
  283.   (defun RESTORE()
  284.     (SETCONTROL "2" s)
  285.     (Dlg_TileSet "Remain" "0")
  286.   )
  287.   (defun READCONTROLS ( / r1 r2 r3 r4 r5 r6)
  288.      (setq r1 (Dlg_TileGet "ReplaceText"))
  289.      (setq r2 (Dlg_TileGet "Font2"))
  290.      (setq r3 (Dlg_TileGet "Height2"))
  291.      (setq r4 (Dlg_TileGet "Angle2"))
  292.      (setq r5 (Dlg_TileGet "Oblique2"))
  293.      (setq r6 (Dlg_TileGet "Width2"))
  294.      (setq remain (if (= (Dlg_TileGet "Remain") "1") 1 nil))
  295.      (setq ret (list r1 r2 r3 r4 r5 r6))
  296.   )
  297.   (defun DlgInit ()
  298.     (Dlg_TileSet "LineInfo" 
  299.       (strcat "" (itoa (+ ss_index 1)) " / " (itoa (sslength ss)) ) 
  300.     )  ;;; ### prt: Line ... of ...
  301.     (Dlg_TileSet "CurrentText" (cdr (assoc 1 s)))
  302.     (Dlg_TileSet "ReplaceText" (cdr (assoc 1 s)))
  303.     (Dlg_ListStart  "Font2")(mapcar 'DLG_ListAdd (FINDFONT))(Dlg_ListEnd)
  304.     (SETCONTROL "1" s)
  305.     (if (= remain 1) 
  306.       (progn 
  307.         (Dlg_TileSet "Remain" "1")
  308.         (if (= (type txtlst) 'LIST)(progn 
  309.           (Dlg_TileSet "Font2"    (nth 1 txtlst))
  310.           (Dlg_TileSet "Height2"  (nth 2 txtlst))
  311.           (Dlg_TileSet "Angle2"   (nth 3 txtlst))
  312.           (Dlg_TileSet "Oblique2" (nth 4 txtlst))
  313.           (Dlg_TileSet "Width2"   (nth 5 txtlst))
  314.         ))
  315.       )
  316.       (SETCONTROL "2" s)   ;;; else
  317.     ) 
  318.     (Dlg_TileAction "Restore"  "(RESTORE)")
  319.     (Dlg_TileAction "IDOK"     "(READCONTROLS)(Dlg_DialogDone)")
  320.     (Dlg_TileAction "IDCANCEL" "(setq ret nil)(Dlg_DialogDone)")
  321.  )  ; defun
  322.  (if (FLX_DLGDSP "flx_dlg" "TCORsingle" "(princ)" "(DlgInit)") (princ)(exit))
  323.  (setq ret ret) ;;; returns txtlst
  324. )
  325.  
  326. ;;; =========================================================
  327. (princ)
  328.  
  329.