打印当前定义的所有函数信息到屏幕或文件

marting

(defun C:LISTFUNS (/ *error* vars str vtype ans mode item items)
                                        ;* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
                                        ;*                                                                           *
                                        ;*         LISTFUNS.LSP  by  John F. Uhden                                   *
                                        ;*                           2 Village Road                                  *
                                        ;*                           Sea Girt, NJ  08750                             *
                                        ;*                                                                           *
                                        ;* * * * * * * * * * * * * * * * * * * * * * * * *
                                        ; v2.2 (10-10-00) added (wcmatch) search for both input and (strcase) of input
                                        ; v15.00 (04-07-00) for R15
                                        ; v15.01 (11-05-01) finally added choices for pageTb saFearray vAriant Vla-Object
                                        ; v15.01F (01-04-17) removed security for release as freeware to AutoCAD forum.

  ;; Function lists all atoms in the (atoms-family) via wildcard match,
  ;; and let's you restrict the search to atoms of certain types.

  (gc)
  (prompt "\nLISTFUNS v15.01F (c)1994-2016, John F. Uhden")
  (setq items (atoms-family 1))                ; set list before this program adds any items, er atoms.

  (defun *error* (err)
    (if        (= (type fp) 'FILE)
      (setq fp (close fp))
    )
    (mapcar '(lambda (x) (setvar (car x) (cdr x))) vars)
    (vla-endundomark *doc*)
    (if        (wcmatch (strcase err) "*CANCEL*,*QUIT*")
      (vl-exit-with-error
        "\r                                              "
      )
      (vl-exit-with-error (strcat "\r*ERROR*: " err))
    )
  )
  (or *acad* (setq *acad* (vlax-get-acad-object)))
  (or *doc* (setq *doc* (vla-get-ActiveDocument *acad*)))
  (vla-endundomark *doc*)
  (vla-startundomark *doc*)
  ;; Kent Cooper's method is much cleaner, but I am not Kent Cooper, just a fan.
  (setq vars (mapcar '(lambda (x) (cons x (getvar x))) '("cmdecho")))
  (mapcar '(lambda (x) (setvar (car x) 0)) vars)
  (command "_.expert" (getvar "expert"))
  ;; dummy command
  (if (/= (type $cv_lf_str) 'STR)
    (setq $cv_lf_str "*")
  )
  (if (/= (type $cv_lf_file) 'STR)
    (setq $cv_lf_file "LISTFUNS.TXT")
  )

  (if (/= (setq        str
                 (getstring (strcat "\nFunction name(s)/<" $cv_lf_str ">: "))
          )
          ""
      )
    (setq $cv_lf_str str)
  )
  (if (not (vl-position
             $cv_lf_vtype
             '("Exsubr"           "eXrxsubr"  "File"           "Int"
               "List"           "eName"     "paGetb"           "Pickset"
               "Real"           "Safearray" "sTr"           "sUbr"
               "sYm"           "vAriant"   "Vla-object"
               "*"
              )
           )
      )
    (setq $cv_lf_vtype "*")
  )
  (initget
    "Exsubr eXrxsubr File Int List eName paGetb Pickset Real Safearray sTr sUbr sYm vAriant Vla-object *"
  )
  (setq        ans
         (getkword
           (strcat
             "\nVariable Type...\n Exsubr/eXrxsubr/File/Int/List/eName/paGetb/Pickset/Real/Safearray/sTr/sUbr/sYm/vAriant/Vla-object/*, <"
             $cv_lf_vtype
             ">:"
           )
         )
  )
  (if ans
    (setq $cv_lf_vtype ans)
  )
  (initget "Append Overwrite No")
  (setq ans (getkword "\nWrite to file?  Append/Overwrite/<No>: "))
  (cond
    ((= ans "Append") (setq mode "a"))
    ((= ans "Overwrite") (setq mode "w"))
    (1 (setq mode nil))
  )
  (if (and mode
           (setq ans (getfiled "Enter File Name" $cv_lf_file "" 5))
      )
    (setq $cv_lf_file ans
          fp              (open $cv_lf_file mode)
    )
    (setq fp nil)
  )
  (foreach item        items
    (if
      (and item
           (wcmatch item (strcat $cv_lf_str "," (strcase $cv_lf_str)))
           (or (= $cv_lf_vtype "*")
               (= (type (eval (read item))) (read $cv_lf_vtype))
           )
      )
       (if fp
         (progn
           (princ (strcat "\n" item "\t") fp)
           (prin1 (eval (read item)) fp)
         )
         (progn
           (princ (strcat "\n" item "\t"))
           (prin1 (eval (read item)))
         )
       )
    )
  )
  (*error* nil)
)
(defun c:LF () (c:listfuns))

WhoCanSay

悄悄问一下楼主，对于(atoms-family 1)可有研究？

(atoms-family 1)改为(atoms-family 2)会怎么样？

Lisphk

WhoCanSay 发表于 2017-1-13 15:49

这个值好像就0和1有用吧

kqqt6236

这个牛啊。

xvjiex

感谢分享打印当前定义的所有函数信息到屏幕或文件