[原创][源码]整合多个GetXXX用户输入函数在一块
本帖最后由 USER2128 于 2013-6-18 11:08 编辑;;;整合多个GetXXX用户输入函数在一块
; ======================================================================================= ;
; 作者：HLCAD（USER2128），版本1.1，完工日期：2013.06.18，转载请保留本信息 ;
; 版本1.1 增加getpoint、getcorner 内容，纠正了1.0版本中的一些小错误 ;
; Get a keyword from the user ;
;Var - GetXXX函数结果值存放到 (read(Var))/Var变量中 ;
; 如Var本身有值，则作为缺省值 ;
;GetXXX - 'GetAngle、getorient、'GetDist、'GetInt、'GetKword、'GetReal、 ;
; 'GetString、getpoint、getcorner 其中之一, 也可为字符如"GetAngle" ;
;init - initget函数用，格式：(Bit整数 Keys文本) ;
; 如 '(4 "Yes No")、'(nil "Yes No")、'("Yes No")、(4) 、4、"Yes No" ;
;Msg- query text 文本提示信息(要包含关键字信息) ;
;DefB - default keyword. 当Var有值且合法, 用Var值, 否则用DefB值 ;
; 当GetXXX=getpoint、getcorner时, 要利用DefB来提供基点位置 ;
; --------------------------------------------------------------------------------------- ;
; (HLCAD-GetXXXnil 'GetAngle nil "输入度数" 90) ;不受Initge正负限制 ;
; (HLCAD-GetXXXnil "GetDist" 4 "输入距离值" "必须输入") ;
; (HLCAD-GetXXX 'aaa 'GetInt 5 "输入正整数(不许负值)" "要输正整数") ;
; (HLCAD-GetXXX 'aaa 'GetKWord '(1 "Yes No") "重定义块吗(Y/N)" "Y") ;必须输入 ;
; (HLCAD-GetXXX 'aaa 'GetString nil "输入任意字符" "默认字符") ;不受Initge影响 ;
; (HLCAD-GetXXX""'GetString nil "输入任意字符" "默认字符") ;不受Initge影响 ;
; (HLCAD-GetXXXnil 'GetPoint1 "请提供一点位" nil) ;无起点, 必输 ;
; (HLCAD-GetXXXnil 'GetCorner 1 "请提供一点位" nil) ;错误，未供基点 ;
; (HLCAD-GetXXX 'aaa 'GetCorner nil "请提供一点位" '(0 0 0)) ; ;
; (HLCAD-GetXXX""'Get-KWord '(1 "Yes No") "重定义块吗(Y/N)" "Y");错误的系统函数 ;
; ======================================================================================= ;
顶一个，学习了 先帖两个出来看看, 1993063 发表于 2013-6-18 16:10 static/image/common/back.gif
先帖两个出来看看,
;;;V1.0版现免费给大家，请多提宝贵意见。; ======================================================================================= ;
; 作者：HLCAD（USER2128），版本1.0，完工日期：2013.06.16，转载请保留本信息
; Get a keyword from the user ;
;Var - GetXXX函数结果值存放到 (read(Var))/Var变量中 ;
; 如Var本身有值，则作为缺省值 ;
;GetXXX - 'GetAngle、'GetDist、'GetInt、'GetKword、'GetReal、'GetString其中之一 ;
;init - initget函数用，格式：(Bit整数 Keys文本) ;
; 如 '(4 "Yes No")、'(nil "Yes No")、'("Yes No")、(4) ;
;Msg- query text 文本提示信息(要包含关键字信息) ;
;DefB - default keyword. 当Var有值且合法, 用Var值, 否则用DefB值 ;
; --------------------------------------------------------------------------------------- ;
; (HLCAD-GetXXXnil 'GetAngle nil "输入度数" 90) ;不受Initge正负限制 ;
; (HLCAD-GetXXXnil "GetDist" 4 "输入距离(不许负值)" "必须输入") ;
; (HLCAD-GetXXX 'aaa 'GetInt 5 "输入距离(不许负值)" "必须输入正整数") ;
; (HLCAD-GetXXX 'aaa 'GetKWord '(1 "Yes No") "重定义块吗(Y/N)" "Y") ;必须输入 ;
; (HLCAD-GetXXX 'aaa 'GetString nil "输入任意字符" "默认字符") ;不受Initge影响 ;
; (HLCAD-GetXXX""'GetString nil "输入任意字符" "默认字符") ;不受Initge影响 ;
; (HLCAD-GetXXX""'Get-KWord '(1 "Yes No") "重定义块吗(Y/N)" "Y");错误的系统函数 ;
; ======================================================================================= ;
(defun HLCAD-GetXXX (Var GetXXX init Msg DefB / Def tmp pro-mpt res)
(vl-load-com)
;;; 处理—Var
(cond ((andVar (= (type Var) 'SYM))
(if (setq tmp (eval Var)) (setq Def tmp))
(setq Var (vl-symbol-name Var)) ;sym=>str.
)
((andVar (= (type Var) 'STR) (/= Var ""))
(if (setq tmp (eval (read Var))) (setq Def tmp))
)
(t (setq Var nil Def nil))
)
;;; 处理—GetXXX
(if (= (type GetXXX) 'SYM)
(setq GetXXX (vl-symbol-name GetXXX))) ;sym=>str.
(if (and GetXXX (= (type GetXXX) 'STR)
(setq tmp (car (atoms-family 1 (list GetXXX)))) ;检查函数是否已定义
(member tmp '("GETANGLE" "GETDIST" "GETINT" "GETKWORD" "GETREAL" "GETSTRING"))
)
(progn
(cond ;处理—Def
((= GetXXX "GETANGLE")
(setq Def (cond ((numberp Def) (/ (* Def 180.) pi))
((numberp DefB) DefB)
(t nil))))
((or (= GetXXX "GETDIST") (= GetXXX "GETREAL"))
(setq Def (cond ((numberp Def)Def)
((numberp DefB) DefB)
(t nil))))
((= GetXXX "GETINT")
(setq Def (cond ((= (type Def) 'INT) Def)
((= (type DefB)'INT) DefB)
(t nil))))
((or (= GetXXX "GETKWORD") (= GetXXX "GETSTRING"))
(setq Def (cond ((and (= (type Def)'STR) (/= Def"")) Def)
((and (= (type DefB) 'STR) (/= DefB "")) DefB)
(t nil))))
)
(cond ;处理—Msg、Def及其组合
((and Msg (= (type Msg) 'STR)
(setq Msg (if (= (substr Msg 1 1) "\n") Msg (strcat "\n" Msg)))
nil))
((not (or (and Msg (= (type Msg) 'STR))
(setq Msg "\n输入值"))))
((and Def (= (type Def) 'INT))
(setq pro-mpt (strcat Msg "/<" (itoa Def) ">: ")))
((and Def (= (type Def) 'REAL))
(setq pro-mpt (strcat Msg "/<" (rtos Def 2) ">: ")))
((and Def (= (type Def) 'STR))
(setq pro-mpt (strcat Msg "/<" Def ">: ")))
((and (not Def) (= (type Msg) 'STR))
(setq pro-mpt (strcat Msg ": ")))
)
(if (not Def)
(setq logi 1)
(setq logi 0)
)
(cond ;处理—initget
((= getXXX "GETSTRING") nil) ;GetString 不需要 initge.
((and init (or (= (type init) 'INT) (= (type init) 'STR)))
(if (= (type init) 'INT)
(initget (logior logi init))
(initget logi init)
))
((and init (= (type init) 'LIST) (= (length init) 1)
(or (= (type (car init)) 'INT) (= (type (car init)) 'STR)))
(if (= (type (car init)) 'INT)
(initget (logior logi (car init)))
(initget logi (car init))
))
((and init (= (type init) 'LIST) (= (length init) 2)
(= (type (car init)) 'INT) (= (type (cadr init)) 'STR))
(initget (logior logi (car init)) (cadr init)))
)
;;;正式求用户输入值
(if (or (not (setq res (vl-catch-all-apply (read getxxx) (list pro-mpt))))
(= res "")) ;getstring专用
(if (= GetXXX "GETANGLE")
(setq res (/ (* Def pi) 180.))
(setq res Def)
))
(if Var (set (read Var) res))
) ;_progn
(progn
(princ "\n系统不支持的函数\"")
(princ GetXXX)
(princ "\"")
(setq res nil)
) ;_progn
) ;_if
res)
; ======================================================================================= ;
不错，留个记号 不得不佩服楼主，牛。 大佬出品必属精品呀，先收藏好评。好久没逛论坛了
页:
[1]