Windows 95 v2.4 Fix/W95-v2.4fix.iso/ACADWIN/SUPPORT/DDCHPROP.LSP

Lisp/Scheme | 1995-02-08 | 36.8 KB | 1,161 lines

; Next available MSG number is    41
; MODULE_ID DDCHPROP_LSP_
;;;----------------------------------------------------------------------------
;;;
;;;    DDCHPROP.LSP   Version 0.5
;;;
;;;    Copyright (C) 1991, 1992, 1993, 1994 by Autodesk, Inc.
;;;
;;;    Permission to use, copy, modify, and distribute this software
;;;    for any purpose and without fee is hereby granted, provided
;;;    that the above copyright notice appears in all copies and
;;;    that both that copyright notice and the limited warranty and
;;;    restricted rights notice below appear in all supporting
;;;    documentation.
;;;
;;;    AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.
;;;    AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF
;;;    MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE.  AUTODESK, INC.
;;;    DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
;;;    UNINTERRUPTED OR ERROR FREE.
;;;
;;;    Use, duplication, or disclosure by the U.S. Government is subject to
;;;    restrictions set forth in FAR 52.227-19 (Commercial Computer
;;;    Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)
;;;    (Rights in Technical Data and Computer Software), as applicable.
;;;
;;;.
;;;   2 February 1992
;;;
;;;----------------------------------------------------------------------------
;;;   DESCRIPTION
;;;----------------------------------------------------------------------------
;;;   C:DDCHPROP is a dialogue interface for the CHPROP command.
;;;
;;;   The command looks similar to DDEMODES.  The main dialogue has an image
;;;   tile, 3 buttons (layer, color, linetype), and an editbox (thickness).
;;;   The 3 buttons each launch a sub-dialogue containing a list and edit box.
;;;   The dialogues are all defined in the DDCHPROP.DCL file.
;;;
;;;
;;;----------------------------------------------------------------------------
;;;----------------------------------------------------------------------------
;;;   Prefixes in command and keyword strings:
;;;      "."  specifies the built-in AutoCAD command in case it has been
;;;           redefined.
;;;      "_"  denotes an AutoCAD command or keyword in the native language
;;;           version, English.
;;;----------------------------------------------------------------------------
;;;
;;;
;;; Avoid (gc)s on load to improve load time.
;;;
(defun do_alloc (/ old_allod new_alloc)
  (setq old_alloc (alloc 2000) new_alloc (alloc 2000))
  (expand (1+ (/ 4750 new_alloc)))
  (alloc old_alloc)
)
(do_alloc)
(setq do_alloc nil)
;;;
;;; ===========================================================================
;;; ===================== load-time error checking ============================
;;;

  (defun ai_abort (app msg)
     (defun *error* (s)
        (if old_error (setq *error* old_error))
        (princ)
     )
     (if msg
       (alert (strcat " Error en la aplicaci≤n: "
                      app
                      " \n\n  "
                      msg
                      "  \n"
              )
       )
     )
     (exit)
  )

;;; Check to see if AI_UTILS is loaded, If not, try to find it,
;;; and then try to load it.
;;;
;;; If it can't be found or it can't be loaded, then abort the
;;; loading of this file immediately, preserving the (autoload)
;;; stub function.

  (cond
     (  (and ai_dcl (listp ai_dcl)))          ; it's already loaded.

     (  (not (findfile "ai_utils.lsp"))                     ; find it
        (ai_abort "DDCHPROP"
                  (strcat "Imposible localizar el archivo AI_UTILS.LSP."
                          "\n Compruebe el directorio de soporte.")))

     (  (eq "failed" (load "ai_utils" "failed"))            ; load it
        (ai_abort "DDCHPROP" "Imposible cargar el archivo AI_UTILS.LSP"))
  )

  (if (not (ai_acadapp))               ; defined in AI_UTILS.LSP
      (ai_abort "DDCHPROP" nil)        ; a Nil <msg> supresses
  )                                    ; ai_abort's alert box dialog.

;;; ==================== end load-time operations ===========================

;;; Initialize program subroutines and variables.

(defun ddchprop_init()

  ;;
  ;; Define buttons and set values in CHPROP dialogue box
  ;;
  (defun call_chp (/ cmdact)
    (if (not (new_dialog "ch_prop" dcl_id)) (exit))
    (set_tile "error" "")
    ;; Set initial dialogue tile values
    (set_col_tile)
    (set_tile "t_layer" elayer)

;    (if (= lay-idx nil)
;      (set_tile "t_layer" ;|DDCHPROP_LSP_6|;"Varies")
;      (set_tile "t_layer" (nth lay-idx laynmlst))
;      (set_tile "t_layer" (cdr (assoc '8 elist)))
;    )
    (cond
      ((= lt-idx nil)
        (set_tile "t_ltype" "varφa")
      )
      ((= lt-idx 0) ; set tile "By layer & layer linetype"
        (set_tile "t_ltype" (bylayer_lt))
      )
      (T
        (set_tile "t_ltype" (nth lt-idx ltnmlst))
      )
    )
    (if (or (= ethickness nil)
            (= ethickness ;|MSG0|;"VARIES"))
      (set_tile "eb_thickness" "varφa")
      (set_tile "eb_thickness" (ai_rtos ethickness))
    )
    (if (or (= eltscale nil)
            (= eltscale ;|MSG0|;"VARIES"))
      (set_tile "eb_ltscale" "varφa")
      (set_tile "eb_ltscale" (ai_rtos eltscale))
    )
    ;; Disable tiles if need be...
    (setq a 0)
    (while ( < a  (sslength ss))
      (setq which_tiles
            (ai_common_state (cdr (assoc '0 (entget (ssname ss a))))))

      ;; If all fields are enabled, don't bother checking anymore.
      (if (/= which_tiles (logior 1 2 4 8 16))
        (setq a (1+ a))
        (setq a (sslength ss))
      )
    )
    ;; Layer Button and Text Field
    (if (/= 1 (logand 1 which_tiles))
      (progn
        (mode_tile "t_layer" 1)
        (mode_tile "b_name" 1)
      )
    )
    ;; Color Button and Text Field
    (if (/= 2 (logand 2 which_tiles))
      (progn
        (mode_tile "t_color" 1)
        (mode_tile "b_color" 1)
        (mode_tile "show_image" 1)
      )
    )
    ;; Linetype Button and Text Field
    (if (/= 4 (logand 4 which_tiles))
      (progn
        (mode_tile "t_ltype" 1)
        (mode_tile "b_line" 1)
      )
    )
    ;; Linetype Scale Edit Field
    (if (/= 8 (logand 8 which_tiles))
      (progn
        (mode_tile "eb_ltscale" 1)
      )
    )
    ;; Thickness Edit Field.
    (if (/= 16 (logand 16 which_tiles))
      (progn
        (mode_tile "eb_thickness" 1)
      )
    )

    ;; Define action for tiles
    (action_tile "b_color" "(setq ecolor (getcolor))")
    (action_tile "show_image" "(setq ecolor (getcolor))")
    (action_tile "b_name" "(setq elayer (getlayer))")
    (action_tile "b_line" "(setq eltype (getltype))")
    (action_tile "eb_ltscale"  "(getscale $value)")
    (action_tile "eb_thickness"  "(getthickness $value)")
    (action_tile "help" "(help \"\" \"ddchprop\")")
    (action_tile "accept" "(test-main-ok)")
    (if (= (start_dialog) 1)
      (progn
        (setq cmdact (getvar "cmdactive"))
        (command "_.chprop" ss "")
        (if (/= cmdact (getvar "cmdactive"))  ; Is CHPROP actually running?
          (progn
            (if ecolor
              (progn
                (if (= 0 ecolor)   (setq ecolor ;|MSG0|;"BYBLOCK"))
                (if (= 256 ecolor) (setq ecolor ;|MSG0|;"BYLAYER"))
                (command "_c" ecolor)
              )
            )
            (if (and (/= eltype ;|MSG0|;"Varies") lt-idx)
              (command "_lt" eltype)
            )
            (if (and (/= elayer ;|MSG0|;"Varies") lay-idx)
              (command "_la" elayer)
            )
            (if (and (/= ethickness ;|MSG0|;"Varies") ethickness)
              (command "_t" ethickness)
            )
            (if (and (/= eltscale ;|MSG0|;"Varies") eltscale)
              (command "_lts" eltscale)
            )
            (command "")
          )
          (princ "\nPropiedades no modificadas")  ; CHPROP didn't like our SS set
        )
      )
      ;; Fred GERBER - 25-AUG-94
      ;; Don't print the "Properties unchanged" message when the user cancels
      ;; the dialog because he knows that already (otherwise he would have
      ;; hit the "OK" button). Display the message only if CHPROP fails for
      ;; some reason, because it is not the expected behavior of the command.
      ;;
      ;; (princ ;|DDCHPROP_LSP_8|;"\nProperties unchanged")
    )
    (princ)
  )
  ;;
  ;; Function to set the Color text tile and swab to the current color value.
  ;;
  (defun set_col_tile()
    (cond
      ((= ecolor nil)
        (set_tile "t_color" "varφa")
        (col_tile "show_image" 0 nil)
      )
      ((= ecolor 0)
        (set_tile "t_color" "PORBLOQUE")
        (col_tile "show_image" 7 nil)    ; show BYBLOCK as white
      )
      ((= ecolor 1)
        (set_tile "t_color" "1 rojo")
        (col_tile "show_image" 1 nil)
      )
      ((= ecolor 2)
        (set_tile "t_color" "2 amarillo")
        (col_tile "show_image" 2 nil)
      )
      ((= ecolor 3)
        (set_tile "t_color" "3 verde")
        (col_tile "show_image" 3 nil)
      )
      ((= ecolor 4)
        (set_tile "t_color" "4 ciano")
        (col_tile "show_image" 4 nil)
      )
      ((= ecolor 5)
        (set_tile "t_color" "5 azul")
        (col_tile "show_image" 5 nil)
      )
      ((= ecolor 6)
        (set_tile "t_color" "6 magenta")
        (col_tile "show_image" 6 nil)
      )
      ((= ecolor 7)
        (set_tile "t_color" "7 blanco")
        (col_tile "show_image" 7 nil)
      )
      ;; If the color is "BYLAYER", then set the tile to
      ;; show it's set By layer, but also indicate the
      ;; color of the layer - i.e. By layer (red)
      ((= ecolor 256)
        (set_tile "t_color" (bylayer_col))
        (col_tile "show_image" cn nil)
      )
      (T
        (set_tile "t_color" (itoa ecolor))
        (col_tile "show_image" ecolor nil)
      )
    )
  )
  ;;
  ;;  Function to put up the standard color dialogue.
  ;;
  (defun getcolor(/ col_def lay_clr temp_color)
    ;; col_def is the default color used when rq_color is called.  If ecolor
    ;; is nil (varies) then set it to 1, else use the value of ecolor.
    (if ecolor
      (setq col_def ecolor)
      (setq col_def 1)
    )

    ;; If we're working with a single layer, get its color
    ;; for use in the color swatch if the user selects color BYLAYER.
    (if (/= elayer ;|MSG0|;"Varies")
      (setq lay_clr (cdr (assoc 62 (tblsearch "layer" elayer))))
      (setq lay_clr 0)
    )
    (if (numberp (setq temp_color (acad_colordlg col_def T lay_clr)))
      (progn
        (setq ecolor temp_color)
        (set_col_tile)
        ecolor
      )
      ecolor
    )
  )
  ;;
  ;; This function pops a dialogue box consisting of a list box, image tile,
  ;; and edit box to allow the user to select or type a linetype.  It returns
  ;; the linetype selected.
  ;;
  (defun getltype (/ old-idx ltname)
    ;; Initialize a dialogue from dialogue file
    (if (not (new_dialog "setltype" dcl_id)) (exit))
    (start_list "list_lt")
    (mapcar 'add_list ltnmlst)         ; initialize list box
    (end_list)
    (setq old-idx lt-idx)
    ;; Show initial ltype in image tile, list box, and edit box
    (if (/= lt-idx nil)
      (ltlist_act (itoa lt-idx))
      (progn
        (set_tile "edit_lt" "varφa")
        (col_tile "show_image" 0 nil)
      )
    )
    (action_tile "list_lt" "(ltlist_act $value)")
    (action_tile "edit_lt" "(ltedit_act)")
    (action_tile "accept" "(test-ok)")
    (action_tile "cancel" "(reset-lt)")
    (if (= (start_dialog) 1)           ; User pressed OK
      (cond
        ((= lt-idx nil)
          (set_tile "t_ltype" "varφa")
          ;|MSG0|;"Varies"
        )
        ((= lt-idx 0)
          (set_tile "t_ltype" (bylayer_lt))
          ;|MSG0|;"BYLAYER"
        )
        ((= lt-idx 1)
          (set_tile "t_ltype" "PORBLOQUE")
          ;|MSG0|;"BYBLOCK"
        )
        (T
          (set_tile "t_ltype" ltname)
          ltname
        )
      )
      eltype
    )
  )
  ;;
  ;; Edit box entries end up here
  ;;
  (defun ltedit_act ()
    ;; If linetype name,is valid, then clear error string,
    ;; call ltlist_act function, and change focus to list box.
    ;; Else print error message.
    (setq ltvalue (xstrcase (get_tile "edit_lt")))
    (if (or (= ltvalue ;|MSG0|;"BYLAYER")
            (= ltvalue "PORCAPA"))
      (setq ltvalue "PORCAPA")
    )
    (if (or (= ltvalue ;|MSG0|;"BYBLOCK")
            (= ltvalue "PORBLOQUE"))
      (setq ltvalue "PORBLOQUE")
    )
    (if (setq lt-idx (getindex ltvalue ltnmlst))
      (progn
        (set_tile "error" "")
        (ltlist_act (itoa lt-idx))
        (mode_tile "list_lt" 2)
      )
      (progn
        (if (/= ltvalue ;|MSG0|;"VARIES")
          (set_tile "error" "Tipo de lφnea no vßlido.")
        )
        (setq lt-idx old-idx)
      )
    )
  )
  ;;
  ;; List selections end up here
  ;;
  (defun ltlist_act (index / dashdata)
    ;; Update the list box, edit box, and color tile
    (set_tile "error" "")
    (setq lt-idx (atoi index))
    (setq ltname (nth lt-idx ltnmlst))
    (setq dashdata (nth lt-idx mdashlist))
    (col_tile "show_image" 0 dashdata)
    (set_tile "list_lt" (itoa lt-idx))
    (set_tile "edit_lt" ltname)
  )
  ;;
  ;; Reset to original linetype when cancel it selected
  ;;
  (defun reset-lt ()
    (setq lt-idx old-idx)
    (done_dialog 0)
  )
  ;;
  ;; This function pops a dialogue box consisting of a list box and edit box to
  ;; allow the user to select or type a layer name.  It returns the layer name
  ;; selected.  It also the status (On, Off, Frozen, etc.) of all layer in the
  ;; drawing.
  ;;
  (defun getlayer (/ old-idx layname on off frozth linetype colname)
    ;; Create layer list the first time the layer
    ;; dialogue is called.
    (if (not lay-idx)
      (progn
        (makelaylists)                     ; layer list - laynmlst
        (setq lay-idx (getindex elayer laynmlst))
      )
    )

    ;; Load a dialogue from dialogue file
    (if (not (new_dialog "setlayer" dcl_id)) (exit))
    (start_list "list_lay")
    (mapcar 'add_list longlist)        ; initialize list box
    (end_list)
    ;; Display current layer, show initial layer name in edit
    ;; box, and highlight list box.
    (setq old-idx lay-idx)
    (if (/= lay-idx nil) (laylist_act (itoa lay-idx)))
    (set_tile "cur_layer" (getvar "clayer"))
    (action_tile "list_lay" "(laylist_act $value)")
    (action_tile "edit_lay" "(layedit_act)")
    (action_tile "accept" "(test-ok)")
    (action_tile "cancel" "(reset-lay)")
    (if (= (start_dialog) 1)           ; User pressed OK
      (progn
        (if (= lay-idx nil)
            (progn (setq layname ;|MSG0|;"VARIES")
                   (set_tile "t_layer" "varφa"))
            (set_tile "t_layer" layname)
        )
        ; If layer or ltype equals bylayer reset their tiles
        (if (= lt-idx 0)
          (set_tile "t_ltype" (bylayer_lt))
        )
        (if (= ecolor 256)
          (progn
            (set_tile "t_color" (bylayer_col))
            (col_tile "show_image" cn nil)
          )
        )
        layname
      )
      elayer
    )
  )
  ;;
  ;; Edit box selections end up here
  ;;
  (defun layedit_act()
    ;; Convert layer entry to upper case.  If layer name is
    ;; valid, clear error string, call (laylist_act) function,
    ;; and change focus to list box.  Else print error message.
    (setq layvalue (xstrcase (get_tile "edit_lay")))
    (if (setq lay-idx (getindex layvalue laynmlst))
      (progn
        (set_tile "error" "")
        (laylist_act (itoa lay-idx))
      )
      (progn
        (set_tile "error" "Nombre de capa no vßlido.")
        (setq lay-idx old-idx)
      )
    )
  )
  ;;
  ;; List entry selections end up here
  ;;
  (defun laylist_act (index / layinfo color dashdata)
    ;; Update the list box, edit box, and color tile
    (set_tile "error" "")
    (setq lay-idx (atoi index))
    (setq layname (nth lay-idx laynmlst))
    (setq layinfo (tblsearch "layer" layname))
    (setq color (cdr (assoc 62 layinfo)))
    (setq color (abs color))
    (setq colname (colorname color))
    (set_tile "list_lay" (itoa lay-idx))
    (set_tile "edit_lay" layname)
    (mode_tile "list_lay" 2)
  )
  ;;
  ;; Reset to original layer when cancel is selected
  ;;
  (defun reset-lay ()
    (setq lay-idx old-idx)
    (done_dialog 0)
  )

  ;; Checks validity of linetype scale from edit box.  It checks to
  ;; see if the value equals "Varies".

  (defun getscale (value / rval)
    (setq value (strcase value)
          rval (distof value))
    (if (or (= value ;|MSG0|;"VARIES")
            (> rval 0.0))
        (progn
          (set_tile "error" "")
          (if (= value ;|MSG0|;"VARIES")
              (progn
                (set_tile "eb_ltscale" "varφa")
                (setq eltscale nil))
            (progn
              (setq eltscale (distof value))
              (set_tile "eb_ltscale" (ai_rtos eltscale))
              eltscale)))
      (progn
        (set_tile "error" "Escala Tlφnea no vßlido.")
        nil)))
  ;;
  ;; Checks validity of thickness from edit box. Since (atof) returns 0 when a
  ;; string can't be converted to a real, this routine checks if the first
  ;; character is "0".  It also checks to see if the value equals "Varies".
  ;;
  (defun getthickness (value)
    (setq value (strcase value))
    (if (or (= value ;|MSG0|;"VARIES")
            (distof value))
      (progn
        (set_tile "error" "")
        (if (= value ;|MSG0|;"VARIES")
          (progn
            (set_tile "eb_thickness" "varφa")
            (setq ethickness nil))
          (progn
            (setq ethickness (distof value))
            (set_tile "eb_thickness" (ai_rtos ethickness))
            ethickness)))
      (progn
        (set_tile "error" "Grosor no vßlido.")
        nil)))
  ;;
  ;; This function make a list called laynmlst which consists of all the layer
  ;; names in the drawing.  It also creates a list called longlist which
  ;; consists of strings which contain the layer name, color, linetype, etc.
  ;; Longlist is later mapped into the layer listbox.  Both are ordered the
  ;; same.
  ;;
  (defun makelaylists (/ layname onoff frozth color linetype vpf vpn ss cvpname
                         xdlist vpldata sortlist name templist bit-70
                         layer_number
                      )
    (if (= (setq tilemode (getvar "tilemode")) 0)
      (progn
        (setq ss (ssget "_x" (list (cons 0 "VIEWPORT")
                                  (cons 69 (getvar "CVPORT"))
                            )
                 )
        )
        (setq cvpname (ssname ss 0))
        (setq xdlist (assoc -3 (entget cvpname '("acad"))))
        (setq vpldata (cdadr xdlist))
      )
    )
    (setq sortlist nil)
    (setq templist (tblnext "LAYER" T))
    (setq layer_number 1)
    (while templist
      (setq name (cdr (assoc 2 templist)))
      (setq sortlist (cons name sortlist))
      (setq templist (tblnext "LAYER"))
      ;; Not dead message...
      (if (= (/ layer_number 50.0) (fix (/ layer_number 50.0)))
        (set_tile "error" (strcat "Reuniendo..." (itoa layer_number)))
      )
      (setq layer_number (1+ layer_number))
    )
    (set_tile "error" "")
    (if (>= (getvar "maxsort") (length sortlist))
      (progn
        (if (> layer_number 50)
          (set_tile "error" "Ordenando...")
        )
        (setq sortlist (acad_strlsort sortlist))
      )
      (setq sortlist (reverse sortlist))
    )
    (set_tile "error" "")
    (setq laynmlst sortlist)
    (setq longlist nil)
    (setq layname (car sortlist))
    (setq layer_number 1)
    (while layname
      (if (= (/ layer_number 50.0) (fix (/ layer_number 50.0)))
        (set_tile "error" (strcat "Analizando..." (itoa layer_number)))
      )
      (setq layer_number (1+ layer_number))
      (setq laylist (tblsearch "LAYER" layname))
      (setq color (cdr (assoc 62 laylist)))
      (if (minusp color)
        (setq onoff ".")
        (setq onoff "Act")
      )
      (setq color (abs color))
      (setq colname (colorname color))
      (setq bit-70 (cdr (assoc 70 laylist)))
      (if (= (logand bit-70 1) 1)
        (setq frozth "I" fchk laylist)
        (setq frozth ".")
      )
      (if (= (logand bit-70 2) 2)
        (setq vpn "N")
        (setq vpn ".")
      )
      (if (= (logand bit-70 4) 4)
        (setq lock "B")
        (setq lock ".")
      )
      (setq linetype (cdr (assoc 6 laylist)))
      (setq layname (substr layname 1 31))
      (if (= tilemode 0)
        (progn
          (if (member (cons 1003 layname) vpldata)
            (setq vpf "A")
            (setq vpf ".")
          )
        )
        (setq vpf ".")
      )
      (setq ltabstr (strcat layname "\t"
                              onoff "\t"
                             frozth "\t"
                               lock "\t"
                                vpf "\t"
                                vpn "\t"
                            colname "\t"
                           linetype
                    )
      )
      (setq longlist (append longlist (list ltabstr)))
      (setq sortlist (cdr sortlist))
      (setq layname (car sortlist))
    )
    (set_tile "error" "")
  )
  ;;
  ;; This function makes 2 lists - ltnmlst & mdashlist.  Ltnmlst is a list of
  ;; linetype names read from the symbol table.  Mdashlist is list consisting
  ;; of lists which define the linetype pattern - numbers that indicate dots,
  ;; dashes, and spaces taken from group code 49.  The list corresponds to the
  ;; order of names in ltnmlst.
  ;;
  (defun makeltlists (/ ltlist ltname)
    (setq mdashlist nil)
    (setq ltlist (tblnext "LTYPE" T))
    (setq ltname (cdr (assoc 2 ltlist)))
    (setq ltnmlst (list ltname))
    (while (setq ltlist (tblnext "LTYPE"))
      (setq ltname (cdr (assoc 2 ltlist)))
      (setq ltnmlst (append ltnmlst (list ltname)))
    )
    (setq ltnmlst (acad_strlsort ltnmlst))
    (foreach ltname ltnmlst
      (setq ltlist (tblsearch "LTYPE" ltname))
      (if (= ltname "CONTINUOUS")
        (setq mdashlist (append mdashlist (list "CONT")))
        (setq mdashlist
            (append mdashlist (list (add-mdash ltlist)))
        )
      )
    )
    (setq ltnmlst (cons "PORBLOQUE" ltnmlst))
    (setq mdashlist  (cons nil mdashlist))
    (setq ltnmlst (cons "PORCAPA" ltnmlst))
    (setq mdashlist  (cons nil mdashlist))
  )
  ;;
  ;; Get all the group code 49 values for a linetype and put them in a list
  ;; (pen-up, pen-down info)
  ;;
  (defun add-mdash (ltlist1 / dashlist assoclist dashsize)
    (setq dashlist nil)
    (while (setq assoclist (car ltlist1))
      (if (= (car assoclist) 49)
        (progn
          (setq dashsize (cdr assoclist))
          (setq dashlist (cons dashsize dashlist))
        )
      )
      (setq ltlist1 (cdr ltlist1))
    )
    (setq dashlist (reverse dashlist))
  )
  ;;
  ;; Color a tile, draw linetype, and draw a border around it
  ;;
  (defun col_tile (tile color patlist / x y)
    (setq x (dimx_tile tile))
    (setq y (dimy_tile tile))
    (start_image tile)
    (fill_image 0 0 x y color)
    (if (= color 7)
      (progn
        (if patlist (drawpattern x (/ y 2) patlist 0))
        (tile_rect 0 0 x y 0)
      )
      (progn
        (if patlist (drawpattern x (/ y 2) patlist 7))
        (tile_rect 0 0 x y 7)
      )
    )
    (end_image)
  )
  ;;
  ;; Draw a border around a tile
  ;;
  (defun tile_rect (x1 y1 x2 y2 color)
    (setq x2 (- x2 1))
    (setq y2 (- y2 1))
    (vector_image x1 y1 x2 y1 color)
    (vector_image x2 y1 x2 y2 color)
    (vector_image x2 y2 x1 y2 color)
    (vector_image x1 y2 x1 y1 color)
  )
  ;;
  ;; Draw the linetype pattern in a tile.  Boxlength is the length of the image
  ;; tile, y2 is the midpoint of the height of the image tile, pattern is a
  ;; list of numbers that define the linetype, and color is the color of the
  ;; tile.
  ;;
  (defun drawpattern (boxlength y2 pattern color / x1 x2
                      patlist dash)
    (setq x1 0 x2 0)
    (setq patlist pattern)
    (setq fx 30)
    (if (= patlist "CONT")
      (progn
        (setq dash boxlength)
        (vi)
        (setq x1 boxlength)
      )
      (foreach dash patlist
        (if (> (abs dash) 2.5)
          (setq fx 2)
        )
      )
    )
    (while (< x1 boxlength)
      (if (setq dash (car patlist))
        (progn
          (setq dash (fix (* fx dash)))
          (cond
            ((= dash 0)
              (setq dash 1)
              (vi)
            )
            ((> dash 0)
              (vi)
            )
            (T
              (if (< (abs dash) 2) (setq dash 2))
              (setq x2 (+ x2 (abs dash)))
            )
          )
          (setq patlist (cdr patlist))
          (setq x1 x2)
        )
        (setq patlist pattern)
      )
    )
  )
  ;;
  ;; Draw a dash or dot in image tile
  ;;
  (defun vi ()
    (setq x2 (+ x2 dash))
    (vector_image x1 y2 x2 y2 color)
  )

  ;; This function takes a selection and returns a list of the color,
  ;; linetype, layer, linetype scale, and thickness properties that
  ;; are common to every entities in the selection set - (color
  ;; linetype layer thickness).  If all entities do not share the same
  ;; property value it returns "Varies" in place of the property
  ;; value.  i.e.  ("BYLAYER" "DASHED" "Varies" 0)

  (defun getprops (selset / sslen elist color ltype layer ltscale thickness
                          go ctr)
    (setq sslen (sslength selset)
          elist (entget (ssname selset 0))
          color (cdr (assoc 62 elist))
          ltype (cdr (assoc 6 elist))
          layer (cdr (assoc 8 elist))
          thickness (cdr (assoc 39 elist))
          ltscale (cdr (assoc 48 elist)))

    (if (not color)
        (setq color 256))
    (if (not ltype)
        (setq ltype "BYLAYER"))
    (if (not thickness)
        (setq thickness 0))
    (if (not ltscale)
        (setq ltscale 1))
    (setq go T chk-col T chk-lt T chk-lay T chk-lts T chk-th T ctr 1)

    ;; Page through the selection set.  When a property
    ;; does not match, stop checking for that property.
    ;; If all properties vary, stop paging.

    (while (and (> sslen ctr) go)
      (setq elist (entget (setq en (ssname selset ctr))))
      (if chk-col (match-col))
      (if chk-lt (match-lt))
      (if chk-lay (match-lay))
      (if chk-lts (match-lts))
      (if chk-th (match-th))
      (setq ctr (1+ ctr))
      (if (and (not chk-col)
               (not chk-lt)
               (not chk-lay)
               (not chk-lts)
               (not chk-th))
        (setq go nil)
      )
    )
    (list color ltype layer thickness ltscale)
  )

  (defun match-col (/ ncolor)
    (setq ncolor (cdr (assoc 62 elist)))
    (if (not ncolor) (setq ncolor 256))
    (if (/= color ncolor)
      (progn
        (setq chk-col nil)
        (setq color nil)
      )
    )
  )

  (defun match-lt (/ nltype)
    (setq nltype (cdr (assoc 6 elist)))
    (if (not nltype) (setq nltype "BYLAYER"))
    (if (/= ltype nltype)
      (progn
        (setq chk-lt nil)
        (setq ltype ;|MSG0|;"Varies")
      )
    )
  )

  (defun match-lay (/ nlayer)
    (setq nlayer (cdr (assoc 8 elist)))
    (if (/= layer nlayer)
      (progn
        (setq chk-lay nil)
        (setq layer ;|MSG0|;"Varies")
      )
    )
  )

  (defun match-th (/ nthickness)
    (setq nthickness (cdr (assoc 39 elist)))
    (if (not nthickness) (setq nthickness 0))
    (if (/= thickness nthickness)
      (progn
        (setq chk-th nil)
        (setq thickness ;|MSG0|;"Varies")
      )
    )
  )

  (defun match-lts (/ nltscale)
    (setq nltscale (cdr (assoc 48 elist)))
    (if (not nltscale) (setq nltscale 1))
    (if (/= ltscale nltscale)
      (progn
        (setq chk-th nil)
        (setq ltscale ;|MSG0|;"Varies")
      )
    )
  )

  ;;
  ;; If an item is a member of the list, then return its index number, else
  ;; return nil.
  ;;
  (defun getindex (item itemlist / m n)
    (setq n (length itemlist))
    (if (> (setq m (length (member item itemlist))) 0)
        (- n m)
        nil
    )
  )
  ;;
  ;; This function is called if the linetype is set "BYLAYER". It finds the
  ;; ltype of the layer so it can be displayed beside the linetype button.
  ;;
  (defun bylayer_lt (/ layname layinfo ltype)
    (if lay-idx
      (progn
        (setq layname (nth lay-idx laynmlst))
        (setq layinfo (tblsearch "layer" layname))
        (setq ltype (cdr (assoc 6 layinfo)))
        (strcat "PORCAPA" " (" ltype ")")
      )
      "PORCAPA"
    )
  )
  ;;
  ;; This function is called if the color is set "BYLAYER".  It finds the
  ;; color of the layer so it can be displayed  beside the color button.
  ;;
  (defun bylayer_col (/ layname layinfo color)
    (if lay-idx
      (progn
        (setq layname (nth lay-idx laynmlst))
        (setq layinfo (tblsearch "layer" layname))
        (setq color (abs (cdr (assoc 62 layinfo))))
        (setq cn color)
        (strcat "PORCAPA" " (" (colorname color) ")")
      )
      (progn
        (setq layname elayer)
        (if (/= elayer "Varies")
          (progn
            (setq layinfo (tblsearch "layer" elayer))
            (setq color (abs (cdr (assoc 62 layinfo))))
            (setq cn color)
            (strcat "PORCAPA" " (" (colorname color) ")")
          )
          (progn
            (setq cn 0)
            "BYLAYER"
          )
        )
      )
    )
  )
  ;;
  ;; If there is no error message, then close the dialogue
  ;;
  ;; If there is an error message, then set focus to the tile
  ;; that's associated with the error message.
  ;;
  (defun test-ok ( / errtile)
    (setq errtile (get_tile "error"))
    (cond
      (  (= errtile "")
         (done_dialog 1))
      (  (= errtile "Grosor no vßlido.")
         (mode_tile "eb_thickness" 2))
    )
  )
  ;;
  ;; OK in main dialogue.
  ;;
  (defun test-main-ok ()
    (cond
      ( (not (distof (get_tile "eb_thickness")))
         (set_tile "error" "Invalid thickness.")
         (mode_tile "eb_thickness" 2)
      )
      ( (not (distof (get_tile "eb_ltscale")))
         (set_tile "error" "Invalid linetype scale.")
         (mode_tile "eb_ltscale" 2)
      )
      ( T (done_dialog 1))
    )
  )

  ;;
  ;; A color function used by getlayer.
  ;;
  (defun colorname (colnum)
    (setq cn (abs colnum))
    (cond ((= cn 1) "rojo")
          ((= cn 2) "amarillo")
          ((= cn 3) "verde")
          ((= cn 4) "ciano")
          ((= cn 5) "azul")
          ((= cn 6) "magenta")
          ((= cn 7) "blanco")
          (T (itoa cn))
    )
  )

;;; Construct layer and ltype lists and initialize all
;;; program variables:

;  (makelaylists)                     ; layer list - laynmlst
  (makeltlists)                      ; linetype lists - ltnmlst, mdashlist
  ;; Find the property values of the selection set.
  ;; (getprops ss) returns a list of properties from
  ;; a selection set - (color ltype layer thickness).
  (setq proplist (getprops ss)
        ecolor (car proplist)
        eltype (nth 1 proplist)
        elayer (nth 2 proplist)
        ethickness (nth 3 proplist)
        eltscale (nth 4 proplist))

  ;; Find index of linetype, and layer lists
  (cond
    ((= eltype "Varies") (setq lt-idx nil))
    ((= eltype "BYLAYER")
     (setq lt-idx (getindex "PORCAPA" ltnmlst)))
    ((= eltype "BYBLOCK")
     (setq lt-idx (getindex "PORBLOQUE" ltnmlst)))
    (T (setq lt-idx (getindex eltype ltnmlst)))
  )
  (if (= elayer "Varies")
      (setq lay-idx nil)
      (setq lay-idx (getindex elayer laynmlst))
  )
  (if (= ethickness "Varies")
      (setq ethickness nil)
  )
  (if (= eltscale "Varies")
      (setq eltscale nil)
  )

)   ; end (ddchprop_init)

;;; (ddchprop_select)
;;;
;;; Aquires selection set for DDCHPROP, in one of three ways:
;;;
;;;   1 - Autoselected.
;;;   2 - Prompted for.
;;;   3 - Passed as an argument in a call to (ddchprop <ss> )
;;;
;;; The (ddchprop_select) function also sets the value of the
;;; global symbol AI_SELTYPE to one of the above three values to
;;; indicate the method thru which the entity was aquired.


(defun ddchprop_select ()
   (cond
      (  (and ss (eq (type ss) 'pickset))        ; selection set passed to
         (cond                                   ; (ddchprop) as argument
            (  (not (zerop (sslength ss)))       ;   If not empty, then
               (setq ai_seltype 3)               ;   then return pickset.
               (ai_return ss))))

      (  (ai_aselect))                          ; Use current selection
                                                ; set or prompt for objects

      (t (princ "\nNo se ha seleccionado nada.")
         (ai_return nil))
   )
)

;;; Define command function.

(defun C:DDCHPROP ()
   (ddchprop nil)
   (princ)
)


;;; Main program function - callable as a subroutine.
;;;
;;; (ddchprop <pickset> )
;;;
;;; <pickset> is the selection set of objects to be changed.
;;;
;;; If <pickset> is nil, then the current selection set is
;;; aquired, if one exists.  Otherwise, the user is prompted
;;; to select the objects to be changed.
;;;
;;; Before (ddchprop) can be called as a subroutine, it must
;;; be loaded first.  It is up to the calling application to
;;; first determine this, and load it if necessary.

(defun ddchprop (ss  /

                  add-mdash      ecolor          ltedit_act      s
                  assoclist      elayer          ltidx           selset
                  bit-70         elist           ltlist          set_col_tile
                  boxlength      eltype          ltlist1
                  bylayer-lt     en              ltlist_act      sortlist
                  bylayer_col    ethickness      ltname
                  bylayer_lt     fchk            ltnmlst         sslen
                  call_chp       frozth          ltvalue         templist
                  chk-col        getcolor        ltype           temp_color
                  chk-lay        getindex        m               test-ok
                  chk-lt         getlayer        makelaylists    testidx
                  chk-th         getltype        makeltlists     testlay
                  cmd            getprops        match-col       th-value
                  cmdecho        getthickness    match-in        thickness
                  cn             globals         match-lay       tile
                  cnum                           match-lt        tilemode
                  col-idx        index           match-th        tile_rect
                  colname        item            match_col       vi
                  colnum         item1           mdashlist       vpf
                  color          item2           n               vpldata
                  colorname      itemlist        name            vpn
                  col_def        lay-idx         ncolor          x
                  col_tile       layedit_act     nlayer          x1
                                 layer           nltype          x2
                  cvpname        layinfo         nthickness      xdlist
                  dash           laylist         off             y
                  dashdata       laylist_act     old-idx         y1
                  dashlist       layname         olderr          y2
                  dashsize       laynmlst        on              undo_init
                  dcl_id         layvalue        onoff           fx
                  test-main-ok   linetype        patlist         which_tiles
                  ddchprop-err   list1           pattern         a
                  longlist       proplist
                  lt-idx         reset-lay
                  drawpattern    ltabstr         reset-lt
                  eltscale       match-lts
                )

  (setq old_cmd (getvar "cmdecho")    ; save current setting of cmdecho
        old_error  *error*            ; save current error function
        *error* ai_error              ; new error function
  )

  (setvar "cmdecho" 0)

  (cond
     (  (not (ai_notrans)))                      ; Not transparent?
     (  (not (ai_acadapp)))                      ; ACADAPP.EXP xloaded?
     (  (not (setq dcl_id (ai_dcl "ddchprop")))) ; is .DCL file loaded?
     (  (not (setq ss (ddchprop_select))))       ; objects to modify?

     (t (ai_undo_push)
        (ddchprop_init)                          ; Everything's cool,
        (call_chp)                               ; so proceed!
        (ai_undo_pop)
     )
  )

  (setq *error* old_error)
  (setvar "cmdecho" old_cmd)
  (princ)
)

;;;----------------------------------------------------------------------------

(princ "   DDCHPROP cargada.")
(princ)