[编程交流] 修复旧LISP+DCL

;Tip1756a:  MESSAGE.LSP      Message Service            (c)2001, John R. Fair III;  $50 Bonus Winner
;;; ----------------------------------------------------------
;;;    Message.lsp is a program to store and retrieve        ;
;;; information about a drawing.  Use it to save notes to    ;
;;; yourself or others, information about "odd" non-standard ;
;;; things you were asked to do to a drawing.  Saves right in;
;;; the drawing, retrieve the message the next day, next week;
;;; or next year.
;;; ----------------------------------------------------------
;;; ************ main function *******************************
(defun
  C:MESSAGE (/ MSG-CMD MSG-DCL_ID)
 (setq
   OLDERR *ERROR*
   *ERROR* MERR
 ) ; end setq
 (if (< (setq MSG-DCL_ID (load_dialog "message.dcl")) 0)
; if dialog file is not loaded
   (exit) ; then exit
 ) ; end if
 (if (not (new_dialog "message" MSG-DCL_ID))
; if dialog box is not loaded
   (exit) ; then exit
 ) ; end if
 (SHOW_LIST "exmess")
 (action_tile "exmess" "(show_info $value)")
 (action_tile "delete" "(delmessage (get_tile "exmess"))")
 (action_tile "store" "(storemessage (get_tile "newmess"))")
 (action_tile
   "accept"
   "(yesno "Message has not been stored!" "" "Do you wish to save the message?" "")"
 ) ;_ end of action_tile
 (start_dialog)
 (princ)
) ; close defun
;;; ******************Store message function *******************
(defun
  STOREMESSAGE
  (MSG-MSG / MSG-MESSAGE MSG-XNAME MSG-SCRT MSG-XNAME MSG-AMPM)
 (setq
   MSG-MESSAGE 1
   MSG-SCRT
    (rtos (getvar "CDATE") 2 6)
 ) ; end setq
 (if (or (= MSG-MSG " ") (= MSG-MSG ""))
   (set_tile "error" "No Message to Store!")
   (progn
     (while (/= (dictsearch
; Use while loop to find last message in drawing
                  (namedobjdict)
                  (strcat "message" (rtos MSG-MESSAGE 2 0))
                ) ;_ end of dictsearch
                NIL
            ) ;_ end of /=
       (setq MSG-MESSAGE (1+ MSG-MESSAGE))
     ) ; end while
     (setq
       MSG-XNAME ; use entmakex to create the xrecord with no owner.
        (entmakex
          (append
            (list '(0 . "XRECORD") '(100 . "AcDbXrecord"))
            (list (cons 1 MSG-MSG))
            (list (cons 2 (getvar "LOGINNAME"))) ; Message stored by?
            (list
              (cons
                3
                (strcat
                  (substr MSG-SCRT 5 2) ; Date Message stored on?
                  "/"
                  (substr MSG-SCRT 7 2)
                  "/"
                  (substr MSG-SCRT 1 4)
                ) ; end strcat
              ) ; end cons
            ) ; end list
            (list
              (cons
                4
                (strcat ; Time Message stored at?
                  (if
                    (<=
                      (setq MSG-AMPM (fix (atof (substr MSG-SCRT 10 2))))
                      12
                    ) ;_ end of <=
                     (eval (substr MSG-SCRT 10 2))
                     (eval
                       (rtos
                         (- (fix (atof (substr MSG-SCRT 10 2))) 12)
                         2
                         0
                       ) ;_ end of RTOS
                     ) ;_ end of eval
                  ) ; end if
                  ":"
                  (substr MSG-SCRT 12 2)
                  " "
                  (if (>= MSG-AMPM 12) ; AM or PM ?
                    (eval "pm")
                    (eval "am")
                  ) ; end if
                ) ; end strcat
              ) ; end cons
            ) ; end list
          ) ; end append
        ) ; end entmakex
     ) ; end setq
     (dictadd
       (namedobjdict)
; add the new xrecord to the named object dictionary.
       (strcat "message" (rtos MSG-MESSAGE 2 0))
       MSG-XNAME
     ) ; end dictadd
     (set_tile "newmess" "")
     (set_tile "strdby" (getvar "loginname")) ; Show stored by name
     (set_tile
       "datestrd"
       (strcat
         (substr MSG-SCRT 5 2)
         "/"
         (substr MSG-SCRT 7 2)
         "/"
         (substr MSG-SCRT 1 4)
       ) ;_ end of strcat
     ) ; show date stored
     (set_tile
       "strdtm" ; show stored time
       (strcat
         (if
           (<= (setq MSG-AMPM (fix (atof (substr MSG-SCRT 10 2)))) 12)
; hours
            (eval (substr MSG-SCRT 10 2))
            (eval (rtos (- (fix (atof (substr MSG-SCRT 10 2))) 12) 2 0))
         ) ; end if
         ":"
         (substr MSG-SCRT 12 2) ; minutes
         " "
         (if (>= MSG-AMPM 12) ; am or pm
           (eval "pm")
           (eval "am")
         ) ; end if
       ) ; end strcat
     ) ; end set_tile
   ) ; close progn
 ) ; end if
 (SHOW_LIST "exmess") ; refresh message list
) ; close defun
;;; ****************** Function to delete messages ***********************
(defun
  DELMESSAGE (MSG-LINENO / MSG-TEST)
 (if (= MSG-LINENO "")
   (set_tile "error" "Please select a message to delete! ")
   (progn
     (setq MSG-TEST (read MSG-LINENO))
     (set_tile "error" "Deleting message, please wait....")
     (dictremove ; remove selected message from dictionary
       (namedobjdict)
       (strcat "message" (rtos (1+ (read MSG-LINENO)) 2 0))
     ) ;_ end of dictremove
     (while (dictrename ; rename any remaining message to fill gap
              (namedobjdict)
              (strcat "message" (rtos (+ MSG-TEST 2) 2 0))
              (strcat "message" (rtos (+ MSG-TEST 1) 2 0))
            ) ;_ end of dictrename
       (setq MSG-TEST (1+ MSG-TEST))
     ) ;_ end of while
   ) ;_ end of PROGN
 ) ;_ end of IF
 (set_tile "error" "") ; clear error and info tiles
 (set_tile "strdby" "")
 (set_tile "datestrd" "")
 (set_tile "strdtm" "")
 (SHOW_LIST "exmess") ; refresh  message list
) ;_ end of DEFUN
;;; *************** Error handler ****************************
(defun
  MERR (S)
 (if (not
       (member
         S
         '("console break" "Function canceled" "Invalid selection")
       ) ;_ end of member
     ) ; if command is aborted
   (princ (strcat "\nMessage Error: " S)) ; then prompt user
 ) ; end if
 (setq
   *ERROR* OLDERR
   MERR NIL
 ) ; undo back to mark
) ;_ end of defun
;;; *************** Show/Refresh message list *********************
(defun
  SHOW_LIST (MSG-TILE / MSG-ITEM MSG-MESSAGE)
 (start_list MSG-TILE) ; start message list
 (setq MSG-MESSAGE 1)
 (while (setq
          MSG-ITEM
           (dictsearch ; find any messages
             (namedobjdict)
             (strcat "message" (rtos MSG-MESSAGE 2 0))
           ) ;_ end of dictsearch
        ) ;_ end of setq
   (add_list (cdr (assoc 1 MSG-ITEM))) ; add message to list
   (setq MSG-MESSAGE (1+ MSG-MESSAGE))
 ) ;_ end of while
 (end_list) ; end list
) ;_ end of defun
;;; ****************** Show message info *************************
(defun
  SHOW_INFO (MSG-INFO / MSG-STRDBY MSG-DATESTRD MSG-RECORD)
 (setq
   MSG-RECORD
    (dictsearch ; find selected message in dictionary
      (namedobjdict)
      (strcat "message" (rtos (1+ (read MSG-INFO)) 2 0))
    ) ;_ end of dictsearch
 ) ;_ end of setq
 (if (cdr (assoc 2 MSG-RECORD)) ; display "Stored by:" info
   (set_tile "strdby" (cdr (assoc 2 MSG-RECORD)))
   (set_tile "strdby" "---")
 ) ;_ end of if
 (if (cdr (assoc 3 MSG-RECORD)) ; display "Date Stored:" info
   (set_tile "datestrd" (cdr (assoc 3 MSG-RECORD)))
   (set_tile "datestrd" "---")
 ) ;_ end of if
 (if (cdr (assoc 4 MSG-RECORD)) ; display "Time Stored" info
   (set_tile "strdtm" (cdr (assoc 4 MSG-RECORD)))
   (set_tile "strdtm" "---")
 ) ;_ end of if
) ;_ end of defun
;;; ************* Message alert box for unsaved messages ******************
(defun
  YESNO (MSG0 MSG1 MSG2 MSG3 /)
 (if (not (= (get_tile "newmess") ""))
; is there a message typed in new message box?
   (progn ; if yes show "do you want to save" alert
     (if (not (new_dialog "yes_no" MSG-DCL_ID))
; if dialog box is not loaded
       (exit) ; then exit
     ) ;_ end of if
     (set_tile "msg0" MSG0)
     (set_tile "msg1" MSG1)
     (set_tile "msg2" MSG2)
     (set_tile "msg3" MSG3)
     (action_tile "accept" "(done_dialog 1)")
; if yes then return to main dialog box
     (action_tile "cancel" "(term_dialog)")
; if no then terminate all dialog boxes
     (start_dialog)
   ) ;_ end of progn
   (done_dialog 1) ; if no message close dialog
 ) ;_ end of if
) ;_ end of defun
;;; ************** Message load alert function **************************
(if ; find selected message in dictionary
 (dictsearch (namedobjdict) "message1")
  (progn
    (if (< (setq MSG-DCL_ID (load_dialog "message.dcl")) 0)
; if dialog file is not loaded
      (exit) ; then exit
    ) ;_ end of if
    (if (not (new_dialog "yes_no" MSG-DCL_ID))
; if dialog box is not loaded
      (exit) ; then exit
    ) ;_ end of if
    (set_tile "msg0" "There are messages in this drawing!")
    (set_tile "msg1" "")
    (set_tile "msg2" "Do you want to view messages now?")
    (set_tile "msg3" "")
    (action_tile "accept" "(done_dialog 1)")
; if yes then return to main dialog box
    (action_tile "cancel" "(done_dialog 0)")
; if no then terminate all dialog boxes
    (if (= (start_dialog) 1)
      (C:MESSAGE)
    ) ;_ end of if
  ) ;_ end of progn
) ;_ end of if
(princ "\nType MESSAGE to start program")
(princ)

//;Tip1756b:  MESSAGE.DCL      Message Service            (c)2001, John R. Fair III;  $50 Bonus Winnermessage : dialog {        label = "Message Service" ;        //initial_focus = "exmess" ;        : boxed_column {                label = "Messages: " ;                : list_box {                        //label = "Messages" ;                        key = "exmess" ;                        width = 80 ;                        //height = 10 ;                        value = "1" ;                }                : row {                        : concatenation {                                : text_part {                                        label = "Stored by: " ;                                }                                : text {                                        key = "strdby" ;                                        width = 10 ;                                }                                : text_part {                                        label = "Date Stored: " ;                                }                                : text {                                        key = "datestrd" ;                                        width = 10 ;                                }                                : text_part {                                        label = "Time Stored: " ;                                }                                : text {                                        key = "strdtm" ;                                        width = 10 ;                                }                        }                        : button {                                label = "Delete Message" ;                                key = "delete" ;                        }                }        }        : spacer { }        : row {                : edit_box {                        label = "Message:" ;                        key = "newmess" ;                        width = 60 ;                        edit_limit = 80;                }                : button {                        label = "Store" ;                        key = "store" ;                }        }        : button {                label = "OK" ;                key = "accept" ;                width = 15 ;                fixed_width = true;                alignment = centered;                is_default = true;        }        errtile ;}yes_no : dialog {    label = "Message Alert";    : column {        : text_part {         label = "";         key = "msg0" ;        }        : text_part {         label = "";         key = "msg1" ;        }        : text_part {         label = "";         key = "msg2" ;        }        : text_part {         label = "";         key = "msg3" ;        }    }    : row {      : spacer {}      : button {          label = " Yes ";          mnemonic = "Y";          key = "accept";          is_default=true;          fixed_width=true;          width=12;      }      : button {         label = " No  ";          mnemonic = "N";          key = "cancel";          is_cancel=true;          fixed_width=true;          width=12;      }      : spacer {}   }}