阿甘计算器1.1（lsp源码版）加了2个小功能

Haoyi · 发表于 2025-7-3 10:31:40

终于让我找到可以加载的计算器了，感谢修改

kuseok · 发表于 2025-7-8 23:22:13

非常感谢，终于可以摆脱到处找计算器的日子了~！

nuan1989 · 发表于 2025-7-31 19:20:00

cad自带了计算器, 你们不会都没用过吧?

bbswen · 发表于 7 天前

有个BUG，选择5个150相乘时，出现表达式错误。

bbswen · 发表于 7 天前

依托AI，修正大数据情况下错误情况

;阿甘CAD计算器命令ad
;结果自动复制到剪贴板，支持天正文字、天正标高
;;;修正大数据情况下计算错误
(setq GL-precision 2) ;2为计算结果保留位数自己根据需要修改
(setq alttz_v "0") ;"0"为不消去计算结果小数点后面的零，改为"1"则为消去
(setq GL-text "D:/历史记录.txt") ;历史记录文件路径，注意路径为反斜杠“/”，可根据需要修改位置
;不出现对话框，直接计算命令：y1=加法 y2=减法 y3=乘法 y4=除法
(defun c:y1 () (GL:jiafa))
(defun c:y2 () (GL:jianfa))
(defun c:y3 () (GL:chengfa))
(defun c:y4 () (GL:chufa))
;阿甘CAD计算器
(vl-load-com)
(command "cal")
(command) ;先调用cal，否则后面cal函数无法使用
(setq GL-result "") ;计算结果，全局变量
(setq GL-lst (list ""))
(defun c:ad (/ file)
(if (not (setq file (open GL-text "r")))
(progn
(setq file (open GL-text "w"))
(close file)
)
(close file)
)
(GL-xxjsq)
)
(defun GL-xxjsq (/ fname fn x dclid lin re file txt value reason)
(if (not GL-result)
(setq GL-result "")
)
(setq fname (vl-filename-mktemp nil nil ".dcl"))
(setq fn (open fname "w"))
(foreach x
'(" xxjsq : dialog{"
" label="阿甘CAD计算器V1.1";"
" :boxed_column{"
" label="自动计算";"
" :row {"
" :button{key="1";label="+";width=4;}"
" :button{key="2";label="-";width=4;}"
" :button{key="3";label="*";width=4;}"
" :button{key="4";label="/";width=4;}"
" }"
" spacer_1;"
" }"
" :boxed_column{"
" label="手动计算";"
" :row {"
" :edit_box{width=35;key ="5";allow_accept = true;}"
" :button {"
" is_default = true ;"
" key = "6" ;"
" label = "计算" ;"
" width = 4 ;"
" }"
" }"
" spacer_1;"
" :row {"
" :button{key="11";label="C↑";width=4;}"
" :button{key="12";label="C↓";width=4;}"
" :button{key="8";label="拾取";width=4;}"
" :button{key="10";label="插算式";width=4;}"
" :button{key="7";label="插结果";width=4;}"
" }"
" spacer_1;"
" }"
" :list_box {key="9";label="历史记录";width=40;height=10;}"
" spacer_1;"
" :row {"
" :toggle{key="alttz";label="消去小数点后后续零";width=10;}"
" :edit_box{edit_width=5;key="GL_precision";label="保留小数位数：";allow_accept=true;width=10;}"
" }"
" spacer_1;"
" cancel_button;"
"}"
)
(princ x fn)
(write-line "" fn)
)
(close fn)
(setq fn (open fname "r"))
(setq dclid (load_dialog fname))
(while
(or
(eq
(substr
(setq lin (vl-string-right-trim
"" fn)"
(vl-string-left-trim "(write-line "" (read-line fn))
)
)
1
2
)
"//"
)
(eq (substr lin 1 (vl-string-search " " lin)) "")
(not (eq (substr lin (+ (vl-string-search " " lin) 1) 9) " : dialog"))
)
)
(new_dialog (substr lin 1 (vl-string-search " " lin)) dclid)
(start_list "9")
(if (equal GL-lst (list ""))
(progn
(setq file (open GL-text "r")
txt (read-line file)
)
(while (/= txt nil)
(setq GL-lst (append GL-lst (list txt)))
(setq txt (read-line file))
)
(close file)
(setq GL-lst (cdr GL-lst))
(setq GL-lst (reverse GL-lst))
)
)
(mapcar 'add_list GL-lst)
(end_list)
(set_tile "GL_precision" (itoa GL-precision))
(set_tile "5" GL-result)
(set_tile "alttz" alttz_v)
(mode_tile "5" 2)
(Vlax-Invoke-Method
(Vlax-Get-Or-Create-Object "WScript.Shell")
'Sendkeys
"{End}"
)
(action_tile "5" "(setq GL-result $Value)")
(action_tile "GL_precision" "(setq GL-precision (atoi $Value))")
(action_tile "alttz" "(setq alttz_v $Value)")
(action_tile "1" "(done_dialog 1)")
(action_tile "2" "(done_dialog 2)")
(action_tile "3" "(done_dialog 3)")
(action_tile "4" "(done_dialog 4)")
(action_tile "6" "(GL:key6)")
(action_tile "7" "(done_dialog 7)")
(action_tile "8" "(done_dialog 8)")
(action_tile "9" "(GL:update-edit $value $reason)")
(action_tile "10" "(done_dialog 10)")
(action_tile "11" "(GL:key11)")
(action_tile "12" "(GL:key12)")
(action_tile "cancel" "(done_dialog 0)")
(setq re (start_dialog))
(cond
((= re 1) (GL:jiafa) (GL:update) (GL-xxjsq))
((= re 2) (GL:jianfa) (GL:update) (GL-xxjsq))
((= re 3) (GL:chengfa) (GL:update) (GL-xxjsq))
((= re 4) (GL:chufa) (GL:update) (GL-xxjsq))
((= re 7) (GL:crjswz GL-result))
((= re 8) (GL:key8))
((= re 10) (GL:crjswz (strcat GL-Num "=" GL-result)))
)
(unload_dialog dclid)
(close fn)
(vl-file-delete fname)
(princ)
)
(defun GL:jiafa () (GL:Galculate (GL:GetNumber "+")))
(defun GL:jianfa () (GL:Galculate (GL:GetNumber "-")))
(defun GL:chengfa () (GL:Galculate (GL:GetNumber "*")))
(defun GL:chufa () (GL:Galculate (GL:GetNumber "/")))
;手动计算
(defun GL:key6 ()
(setq GL-result (get_tile "5"))
(if (/= GL-result "")
(progn
(if (GL:Galculate GL-result)
(progn
(set_tile "5" GL-result)
(mode_tile "5" 2)
(Vlax-Invoke-Method
(Vlax-Get-Or-Create-Object "WScript.Shell")
'Sendkeys
"{End}"
)
(GL:update)
)
)
)
)
)
;拾取
(defun GL:key8 (/ num)
(if (setq num (GL:GetNumber "+"))
(progn
(if (/= GL-result "")
(setq GL-result (strcat GL-result "+" num))
(setq GL-result (strcat GL-result num))
)
)
)
(GL-xxjsq)
)
;清空计算框
(defun GL:key11 ()
(set_tile "5" "")
(mode_tile "5" 2)
(Vlax-Invoke-Method
(Vlax-Get-Or-Create-Object "WScript.Shell")
'Sendkeys
"{End}"
)
)
;清空历史记录
(defun GL:key12 ()
(if (GL-qrdhk)
(progn
(setq GL-lst (list ""))
(start_list "9")
(mapcar 'add_list GL-lst)
(end_list)
(setq file (open GL-text "w"))
(write-line "" file)
(close file)
)
)
(mode_tile "5" 2)
(Vlax-Invoke-Method
(Vlax-Get-Or-Create-Object "WScript.Shell")
'Sendkeys
"{End}"
)
)
;提取数字和运算符
(defun GL:GetNumber (ope / en num i regex ss text tn)
(setq regex (vlax-create-object "Vbscript.RegExp")) ;引用正则表达式控件
(vlax-put-property regex "IgnoreCase" 0) ;不忽略大小写
(vlax-put-property regex "Global" 1) ;全文匹配，而不是只匹配第一处
(setq ss (ssget '((0 . "*TEXT,TCH_ELEVATION,DIMENSION")))) ;只拾取文字、天正标高
(if ss
(progn
(setq i 0
Num ""
)
(repeat (sslength ss)
(setq en (ssname ss i))
(setq GL-ed (entget en))
(if (= "DIMENSION" (cdr (assoc 0 GL-ed)))
(setq text (atof (rtos (cdr (assoc 42 GL-ed)) 2 3)))
(setq text (cdr (assoc 1 GL-ed)))
) ; 补充标注文字提取
(vlax-put-property regex "Pattern" "[^0-9\\+\\-\\*\\/\\.\$\$]") ;匹配数字和运算符
(setq text (vlax-invoke-method regex "Replace" text ""))
(if (/= text "")
(progn
(if (= Num "") ;表达式加括号
(if (wcmatch text "*`+*,*`-*,*`**,*`/*")
(setq Num (strcat "(" text ")")
TN nil
)
(setq Num text
TN nil
)
)
(setq TN T)
)
(if TN ;表达式加括号
(if (wcmatch text "*`+*,*`-*,*`**,*`/*")
(setq Num (strcat Num ope "(" text ")"))
(setq Num (strcat Num ope text))
)
)
;(if (= Num "")(setq Num text TN nil)(setq TN T));表达式不加括号
;(if TN (setq Num (strcat Num ope text)));表达式不加括号
)
)
(setq i (1+ i))
)
)
)
Num
)
; 1. 定义运算符优先级（数字越大优先级越高）
(defun op-priority (op)
(cond
((member op '(+ -)) 1)
((member op '(* /)) 2)
(T 0) ; 括号优先级最低
)
)
; 2. 分词函数：将表达式拆分为数字、运算符、括号
(defun tokenize (expr / len i char token tokens)
(setq len (strlen expr)
i 1
tokens '()
)
(while (<= i len)
(setq char (substr expr i 1))
(cond
; 跳过空格
((= char " ") (setq i (1+ i)))
; 处理运算符和括号
((member char '( "+" "-" "*" "/" "(" ")" ))
(setq tokens (append tokens (list char))
i (1+ i)
)
)
; 处理数字（包括小数和负数）
((or (vl-string-search char "0123456789.")
(and (= char "-")
(or (= i 1)
(member (last tokens) '( "+" "-" "*" "/" "(" ))
)
)
)
(setq token char
i (1+ i)
)
; 继续读取多位数或小数
(while (and (<= i len)
(vl-string-search (substr expr i 1) "0123456789.")
)
(setq token (strcat token (substr expr i 1))
i (1+ i)
)
)
(setq tokens (append tokens (list (atof token)))) ; 转换为数值
)
(T (error (strcat "无效字符: " char))) ; 报错无效字符
)
)
tokens
)
; 3. 中缀转后缀表达式（逆波兰式）
(defun infix-to-postfix (tokens / stack postfix token op)
(setq stack '()
postfix '()
)
(foreach token tokens
(cond
; 数字直接加入后缀列表
((numberp token)
(setq postfix (append postfix (list token)))
)
; 左括号入栈
((= token "(")
(setq stack (cons token stack))
)
; 右括号：弹出栈中元素直到左括号
((= token ")")
(while (not (= (car stack) "("))
(setq postfix (append postfix (list (car stack)))
stack (cdr stack)
)
)
(setq stack (cdr stack)) ; 弹出左括号（不加入后缀列表）
)
; 运算符：按优先级处理
(T
(while (and stack (/= (car stack) "(")
(>= (op-priority (car stack)) (op-priority token))
)
(setq postfix (append postfix (list (car stack)))
stack (cdr stack)
)
)
(setq stack (cons token stack))
)
)
)
; 弹出栈中剩余运算符
(while stack
(setq postfix (append postfix (list (car stack)))
stack (cdr stack)
)
)
postfix
)
; 4. 后缀表达式转前缀表达式（LISP格式）
(defun postfix-to-prefix (postfix / stack op a b)
(foreach token postfix
(if (numberp token)
(setq stack (cons token stack)) ; 数字入栈
(progn ; 运算符：弹出两个操作数组合为前缀表达式
(setq b (car stack)
stack (cdr stack)
a (car stack)
stack (cdr stack)
stack (cons (list (read token) a b) stack) ; 构建前缀表达式（如 (* 2 3)）
)
)
)
)
(car stack) ; 栈顶即为最终前缀表达式
)
; 5. 主函数：计算包含+-*/的表达式
(defun calc-expr (expr / tokens postfix prefix result)
(setq tokens (tokenize expr) ; 分词
postfix (infix-to-postfix tokens) ; 中缀转后缀
prefix (postfix-to-prefix postfix) ; 后缀转前缀
result (eval prefix) ; 计算结果
)
result
)
;计算
(defun GL:Galculate (Num / odimzin)
(if Num
(progn
(if (setq GL-result (calc-expr Num)) ;*1.0将整数转换为小数，整数只能介于-32768和32767之间
(progn
(setq odimzin (getvar "dimzin"))
(if (= alttz_v "0")
(setvar "dimzin" 0)
;;else
(setvar "dimzin" 8)
)
(setq GL-result (rtos GL-result 2 GL-precision))
(setvar "dimzin" odimzin)
(set-clip-string GL-result) ;向系统剪贴板写入文字
(setq GL-Num Num)
(princ (strcat "\n表达式：" Num "=" GL-result " >>>>计算结果：" GL-result))
(princ)
)
(alert (strcat Num " 表达式语法错误!"))
)
)
)
)
;向系统剪贴板写入文字
(defun set-clip-string (STR / HTML RESULT)
(and
(= (type STR) 'STR)
(setq HTML (vlax-create-object "htmlfile"))
(setq RESULT (vlax-invoke
(vlax-get
(vlax-get HTML 'PARENTWINDOW)
'CLIPBOARDDATA
)
'SETDATA
"Text"
STR
)
)
(vlax-release-object HTML)
)
)
;插入计算文字
(defun GL:crjswz (GL-result / h la pt sc st ty tzbl)
(if (/= GL-result "")
(if (setq pt (getpoint "\n请点取插入点:"))
(if GL-ed
(progn
(setq ty (cdr (assoc 0 GL-ed)) ;字体类型
st (if (= "DIMENSION" (cdr (assoc 0 GL-ed)))
(getvar "TEXTSTYLE")
(cdr (assoc 7 GL-ed))
) ;字体样式
la (cdr (assoc 8 GL-ed)) ;图层
h (if (= "DIMENSION" (cdr (assoc 0 GL-ed)))
(*
(cdr
(assoc
40
(tblsearch
"DIMSTYLE"
(cdr (assoc 3 (entget (cdr (assoc -1 GL-ed)))))
)
)
)
(cdr
(assoc
140
(tblsearch
"DIMSTYLE"
(cdr (assoc 3 (entget (cdr (assoc -1 GL-ed)))))
)
)
)
)
(cdr (assoc 40 GL-ed))
) ;文字高度
sc (cdr (assoc 47 GL-ed)) ;天正比例
;ar (cdr (assoc 41 GL-ed));文字宽高比
;co (cdr (assoc 62 GL-ed));颜色
)
(if (wcmatch ty "TCH_*")
(entmake
(list
'(0 . "TEXT")
(cons 1 GL-result)
(cons 7 st)
(cons 8 la)
(cons 10 pt)
(cons 40 (* h sc))
(cons 41 0.8)
)
)
(entmake
(list
'(0 . "TEXT")
(cons 1 GL-result)
(cons 7 st)
(cons 8 la)
(cons 10 pt)
(cons 40 h)
(cons 41 0.8)
)
)
)
)
(progn
;(setq h (getvar 'textsize)) ;当前样式文字高度
(setq tzbl (getvar "HPSCALE") ;天正比例
h (* tzbl 3)
)
(entmake
(list
'(0 . "TEXT")
(cons 1 GL-result)
(cons 10 pt)
(cons 40 h)
)
)
)
)
)
)
)
;更新历史记录数据，并保存
(defun GL:update (/ file ex)
(if GL-result
(progn
(setq ex (strcat GL-Num "=" GL-result))
(setq GL-lst (append (list ex) GL-lst))
(start_list "9")
(mapcar 'add_list GL-lst)
(end_list)
(setq file (open GL-text "a"))
(write-line ex file)
(close file)
)
)
)
;将历史记录上到计算框
(defun GL:update-edit (value reason / a b ex i len)
(if (= reason 4)
(progn
(setq ex (nth (atoi value) GL-lst)
len (strlen ex)
i 1
b ""
)
(while (<= i len)
(setq a (substr ex i 1))
(if (= a "=")
(setq i (1+ len))
(setq b (strcat b a))
)
(setq i (1+ i))
)
(set_tile "5" b)
(mode_tile "5" 2)
(Vlax-Invoke-Method
(Vlax-Get-Or-Create-Object "WScript.Shell")
'Sendkeys
"{End}"
)
)
)
)
(defun GL-qrdhk (/ fname fn x dclid lin re YorN)
(setq fname (vl-filename-mktemp nil nil ".dcl"))
(setq fn (open fname "w"))
(foreach x
'(" qrdhk : dialog{" " spacer_1;" " :text{key="2";label="是否清除历史记录";}"
" spacer_1;" " :row {" " :button{key="1";label="是";width=8;}"
" spacer_1;" " cancel_button;" " }" " spacer_1;" "}"
)
(princ x fn)
(write-line "" fn)
)
(close fn)
(setq fn (open fname "r"))
(setq dclid (load_dialog fname))
(while
(or
(eq
(substr
(setq lin (vl-string-right-trim
"" fn)"
(vl-string-left-trim "(write-line "" (read-line fn))
)
)
1
2
)
"//"
)
(eq (substr lin 1 (vl-string-search " " lin)) "")
(not (eq (substr lin (+ (vl-string-search " " lin) 1) 9) " : dialog"))
)
)
(new_dialog (substr lin 1 (vl-string-search " " lin)) dclid)
(action_tile "1" "(done_dialog 1)")
(action_tile "cancel" "(done_dialog 0)")
(setq re (start_dialog))
(cond
((= re 1) (setq YorN T))
)
(unload_dialog dclid)
(close fn)
(vl-file-delete fname)
YorN
)

;阿甘CAD计算器 命令ad 
;结果自动复制到剪贴板，支持天正文字、天正标高 
;;;修正大数据情况下计算错误 
(setq GL-precision 2)  ;2为计算结果保留位数 自己根据需要修改 
(setq alttz_v "0")  ;"0"为不消去计算结果小数点后面的零，改为"1"则为消去 
(setq GL-text "D:/历史记录.txt") ;历史记录文件路径，注意路径为反斜杠“/”，可根据需要修改位置 
 
;不出现对话框，直接计算 命令：y1=加法 y2=减法 y3=乘法 y4=除法 
(defun c:y1 () (GL:jiafa)) 
(defun c:y2 () (GL:jianfa)) 
(defun c:y3 () (GL:chengfa)) 
(defun c:y4 () (GL:chufa)) 
 
;阿甘CAD计算器 
(vl-load-com) 
(command "cal") 
(command)     ;先调用cal，否则后面cal函数无法使用 
(setq GL-result "")          ;计算结果，全局变量 
(setq GL-lst (list "")) 
(defun c:ad (/ file) 
  (if (not (setq file (open GL-text "r"))) 
    (progn 
      (setq file (open GL-text "w")) 
      (close file) 
    ) 
    (close file) 
  ) 
  (GL-xxjsq) 
) 
(defun GL-xxjsq (/ fname fn x dclid lin re file txt value reason) 
  (if (not GL-result) 
    (setq GL-result "") 
  ) 
  (setq fname (vl-filename-mktemp nil nil ".dcl")) 
  (setq fn (open fname "w")) 
  (foreach x 
    '("  xxjsq : dialog{" 
      "  label="阿甘CAD计算器V1.1";" 
      "  :boxed_column{" 
      "  label="自动计算";" 
      "  :row {" 
      "      :button{key="1";label="+";width=4;}" 
      "      :button{key="2";label="-";width=4;}" 
      "      :button{key="3";label="*";width=4;}" 
      "      :button{key="4";label="/";width=4;}" 
      "  }" 
      "  spacer_1;" 
      "  }" 
      "  :boxed_column{" 
      "  label="手动计算";" 
      "  :row {" 
      "     :edit_box{width=35;key ="5";allow_accept = true;}" 
      "            :button {" 
      "                is_default = true ;" 
      "                key = "6" ;" 
      "                label = "计算" ;" 
      "                width = 4 ;" 
      "            }" 
      "  }" 
      "  spacer_1;" 
      "  :row {" 
      "      :button{key="11";label="C↑";width=4;}" 
      "      :button{key="12";label="C↓";width=4;}" 
      "      :button{key="8";label="拾取";width=4;}" 
      "      :button{key="10";label="插算式";width=4;}" 
      "      :button{key="7";label="插结果";width=4;}" 
      "  }" 
      "  spacer_1;" 
      "  }" 
      "  :list_box {key="9";label="历史记录";width=40;height=10;}" 
      "  spacer_1;" 
      "  :row {" 
      "      :toggle{key="alttz";label="消去小数点后后续零";width=10;}" 
      "      :edit_box{edit_width=5;key="GL_precision";label="保留小数位数：";allow_accept=true;width=10;}" 
      "  }" 
      "  spacer_1;" 
      "      cancel_button;" 
      "}" 
     ) 
    (princ x fn) 
    (write-line "" fn) 
  ) 
  (close fn) 
  (setq fn (open fname "r")) 
  (setq dclid (load_dialog fname)) 
  (while 
    (or 
      (eq 
        (substr 
          (setq lin (vl-string-right-trim 
                      "" fn)" 
                      (vl-string-left-trim "(write-line "" (read-line fn)) 
                    ) 
          ) 
          1 
          2 
        ) 
        "//" 
      ) 
      (eq (substr lin 1 (vl-string-search " " lin)) "") 
      (not (eq (substr lin (+ (vl-string-search " " lin) 1) 9) " : dialog")) 
    ) 
  ) 
  (new_dialog (substr lin 1 (vl-string-search " " lin)) dclid) 
 
  (start_list "9") 
  (if (equal GL-lst (list "")) 
    (progn 
      (setq file (open GL-text "r") 
            txt  (read-line file) 
      ) 
      (while (/= txt nil) 
        (setq GL-lst (append GL-lst (list txt))) 
        (setq txt (read-line file)) 
      ) 
      (close file) 
      (setq GL-lst (cdr GL-lst)) 
      (setq GL-lst (reverse GL-lst)) 
    ) 
  ) 
  (mapcar 'add_list GL-lst) 
  (end_list) 
  (set_tile "GL_precision" (itoa GL-precision)) 
  (set_tile "5" GL-result) 
  (set_tile "alttz" alttz_v) 
  (mode_tile "5" 2) 
  (Vlax-Invoke-Method 
    (Vlax-Get-Or-Create-Object "WScript.Shell") 
    'Sendkeys 
    "{End}" 
  ) 
  (action_tile "5" "(setq GL-result $Value)") 
  (action_tile "GL_precision" "(setq GL-precision (atoi $Value))") 
  (action_tile "alttz" "(setq alttz_v $Value)") 
  (action_tile "1" "(done_dialog 1)") 
  (action_tile "2" "(done_dialog 2)") 
  (action_tile "3" "(done_dialog 3)") 
  (action_tile "4" "(done_dialog 4)") 
  (action_tile "6" "(GL:key6)") 
  (action_tile "7" "(done_dialog 7)") 
  (action_tile "8" "(done_dialog 8)") 
  (action_tile "9" "(GL:update-edit $value $reason)") 
  (action_tile "10" "(done_dialog 10)") 
  (action_tile "11" "(GL:key11)") 
  (action_tile "12" "(GL:key12)") 
  (action_tile "cancel" "(done_dialog 0)") 
 
  (setq re (start_dialog)) 
  (cond 
    ((= re 1) (GL:jiafa) (GL:update) (GL-xxjsq)) 
    ((= re 2) (GL:jianfa) (GL:update) (GL-xxjsq)) 
    ((= re 3) (GL:chengfa) (GL:update) (GL-xxjsq)) 
    ((= re 4) (GL:chufa) (GL:update) (GL-xxjsq)) 
    ((= re 7) (GL:crjswz GL-result)) 
    ((= re 8) (GL:key8)) 
    ((= re 10) (GL:crjswz (strcat GL-Num "=" GL-result))) 
  ) 
  (unload_dialog dclid) 
  (close fn) 
  (vl-file-delete fname) 
  (princ) 
) 
 
(defun GL:jiafa () (GL:Galculate (GL:GetNumber "+"))) 
(defun GL:jianfa () (GL:Galculate (GL:GetNumber "-"))) 
(defun GL:chengfa () (GL:Galculate (GL:GetNumber "*"))) 
(defun GL:chufa () (GL:Galculate (GL:GetNumber "/"))) 
 
;手动计算 
(defun GL:key6 () 
  (setq GL-result (get_tile "5")) 
  (if (/= GL-result "") 
    (progn 
      (if (GL:Galculate GL-result) 
        (progn 
          (set_tile "5" GL-result) 
          (mode_tile "5" 2) 
          (Vlax-Invoke-Method 
            (Vlax-Get-Or-Create-Object "WScript.Shell") 
            'Sendkeys 
            "{End}" 
          ) 
          (GL:update) 
        ) 
      ) 
    ) 
  ) 
) 
 
;拾取 
(defun GL:key8 (/ num) 
  (if (setq num (GL:GetNumber "+")) 
    (progn 
      (if (/= GL-result "") 
        (setq GL-result (strcat GL-result "+" num)) 
        (setq GL-result (strcat GL-result num)) 
      ) 
    ) 
  ) 
  (GL-xxjsq) 
) 
 
;清空计算框 
(defun GL:key11 () 
  (set_tile "5" "") 
  (mode_tile "5" 2) 
  (Vlax-Invoke-Method 
    (Vlax-Get-Or-Create-Object "WScript.Shell") 
    'Sendkeys 
    "{End}" 
  ) 
) 
 
;清空历史记录 
(defun GL:key12 () 
  (if (GL-qrdhk) 
    (progn 
      (setq GL-lst (list "")) 
      (start_list "9") 
      (mapcar 'add_list GL-lst) 
      (end_list) 
      (setq file (open GL-text "w")) 
      (write-line "" file) 
      (close file) 
    ) 
  ) 
  (mode_tile "5" 2) 
  (Vlax-Invoke-Method 
    (Vlax-Get-Or-Create-Object "WScript.Shell") 
    'Sendkeys 
    "{End}" 
  ) 
) 
 
;提取数字和运算符 
(defun GL:GetNumber (ope / en num i regex ss text tn) 
  (setq regex (vlax-create-object "Vbscript.RegExp")) ;引用正则表达式控件 
  (vlax-put-property regex "IgnoreCase" 0) ;不忽略大小写 
  (vlax-put-property regex "Global" 1) ;全文匹配，而不是只匹配第一处 
  (setq ss (ssget '((0 . "*TEXT,TCH_ELEVATION,DIMENSION")))) ;只拾取文字、天正标高 
  (if ss 
    (progn 
      (setq i   0 
            Num "" 
      ) 
      (repeat (sslength ss) 
        (setq en (ssname ss i)) 
        (setq GL-ed (entget en)) 
        (if (= "DIMENSION" (cdr (assoc 0 GL-ed))) 
          (setq text (atof (rtos (cdr (assoc 42 GL-ed)) 2 3))) 
          (setq text (cdr (assoc 1 GL-ed))) 
        ) ; 补充标注文字提取 
        (vlax-put-property regex "Pattern" "[^0-9\\+\\-\\*\\/\\.\$\$]") ;匹配数字和运算符 
        (setq text (vlax-invoke-method regex "Replace" text "")) 
        (if (/= text "") 
          (progn 
            (if (= Num "")  ;表达式加括号 
              (if (wcmatch text "*`+*,*`-*,*`**,*`/*") 
                (setq Num (strcat "(" text ")") 
                      TN  nil 
                ) 
                (setq Num text 
                      TN  nil 
                ) 
              ) 
              (setq TN T) 
            ) 
            (if TN  ;表达式加括号 
              (if (wcmatch text "*`+*,*`-*,*`**,*`/*") 
                (setq Num (strcat Num ope "(" text ")")) 
                (setq Num (strcat Num ope text)) 
              ) 
            ) 
            ;(if (= Num "")(setq Num text TN nil)(setq TN T));表达式不加括号 
            ;(if TN (setq Num (strcat Num ope text)));表达式不加括号 
          ) 
        ) 
        (setq i (1+ i)) 
      ) 
    ) 
  ) 
  Num 
) 
 
 
; 1. 定义运算符优先级（数字越大优先级越高） 
(defun op-priority (op) 
  (cond 
    ((member op '(+ -)) 1) 
    ((member op '(* /)) 2) 
    (T 0)  ; 括号优先级最低 
  ) 
) 
 
; 2. 分词函数：将表达式拆分为数字、运算符、括号 
(defun tokenize (expr / len i char token tokens) 
  (setq len (strlen expr) 
        i 1 
        tokens '() 
  ) 
  (while (<= i len) 
    (setq char (substr expr i 1)) 
    (cond 
      ; 跳过空格 
      ((= char " ") (setq i (1+ i))) 
      ; 处理运算符和括号 
      ((member char '( "+" "-" "*" "/" "(" ")" )) 
       (setq tokens (append tokens (list char)) 
             i (1+ i) 
       ) 
      ) 
      ; 处理数字（包括小数和负数） 
      ((or (vl-string-search char "0123456789.") 
           (and (= char "-") 
                (or (= i 1) 
                    (member (last tokens) '( "+" "-" "*" "/" "(" )) 
                ) 
           ) 
      ) 
       (setq token char 
             i (1+ i) 
       ) 
       ; 继续读取多位数或小数 
       (while (and (<= i len) 
                   (vl-string-search (substr expr i 1) "0123456789.") 
              ) 
         (setq token (strcat token (substr expr i 1)) 
               i (1+ i) 
         ) 
       ) 
       (setq tokens (append tokens (list (atof token))))  ; 转换为数值 
      ) 
      (T (error (strcat "无效字符: " char)))  ; 报错无效字符 
    ) 
  ) 
  tokens 
) 
 
; 3. 中缀转后缀表达式（逆波兰式） 
(defun infix-to-postfix (tokens / stack postfix token op) 
  (setq stack '() 
        postfix '() 
  ) 
  (foreach token tokens 
    (cond 
      ; 数字直接加入后缀列表 
      ((numberp token) 
       (setq postfix (append postfix (list token))) 
      ) 
      ; 左括号入栈 
      ((= token "(") 
       (setq stack (cons token stack)) 
      ) 
      ; 右括号：弹出栈中元素直到左括号 
      ((= token ")") 
       (while (not (= (car stack) "(")) 
         (setq postfix (append postfix (list (car stack))) 
               stack (cdr stack) 
         ) 
       ) 
       (setq stack (cdr stack))  ; 弹出左括号（不加入后缀列表） 
      ) 
      ; 运算符：按优先级处理 
      (T 
       (while (and stack (/= (car stack) "(") 
                   (>= (op-priority (car stack)) (op-priority token)) 
              ) 
         (setq postfix (append postfix (list (car stack))) 
               stack (cdr stack) 
         ) 
       ) 
       (setq stack (cons token stack)) 
      ) 
    ) 
  ) 
  ; 弹出栈中剩余运算符 
  (while stack 
    (setq postfix (append postfix (list (car stack))) 
          stack (cdr stack) 
    ) 
  ) 
  postfix 
) 
 
; 4. 后缀表达式转前缀表达式（LISP格式） 
(defun postfix-to-prefix (postfix / stack op a b) 
  (foreach token postfix 
    (if (numberp token) 
      (setq stack (cons token stack))  ; 数字入栈 
      (progn  ; 运算符：弹出两个操作数组合为前缀表达式 
        (setq b (car stack) 
              stack (cdr stack) 
              a (car stack) 
              stack (cdr stack) 
              stack (cons (list (read token) a b) stack)  ; 构建前缀表达式（如 (* 2 3)） 
        ) 
      ) 
    ) 
  ) 
  (car stack)  ; 栈顶即为最终前缀表达式 
) 
 
; 5. 主函数：计算包含+-*/的表达式 
(defun calc-expr (expr / tokens postfix prefix result) 
  (setq tokens (tokenize expr)          ; 分词 
        postfix (infix-to-postfix tokens)  ; 中缀转后缀 
        prefix (postfix-to-prefix postfix)  ; 后缀转前缀 
        result (eval prefix)  ; 计算结果 
  ) 
  result 
) 
 
 
 
 
;计算 
(defun GL:Galculate (Num / odimzin) 
  (if Num 
    (progn 
      (if (setq GL-result (calc-expr Num))  ;*1.0将整数转换为小数，整数只能介于-32768和32767之间 
        (progn 
          (setq odimzin (getvar "dimzin")) 
          (if (= alttz_v "0") 
            (setvar "dimzin" 0) 
            ;;else 
            (setvar "dimzin" 8) 
          ) 
          (setq GL-result (rtos GL-result 2 GL-precision)) 
          (setvar "dimzin" odimzin) 
          (set-clip-string GL-result) ;向系统剪贴板写入文字 
          (setq GL-Num Num) 
          (princ (strcat "\n表达式：" Num "=" GL-result "  >>>>计算结果：" GL-result)) 
          (princ) 
        ) 
        (alert (strcat Num "   表达式语法错误!")) 
      ) 
    ) 
  ) 
) 
 
;向系统剪贴板写入文字 
(defun set-clip-string (STR / HTML RESULT) 
  (and 
    (= (type STR) 'STR) 
    (setq HTML (vlax-create-object "htmlfile")) 
    (setq RESULT (vlax-invoke 
                   (vlax-get 
                     (vlax-get HTML 'PARENTWINDOW) 
                     'CLIPBOARDDATA 
                   ) 
                   'SETDATA 
                   "Text" 
                   STR 
                 ) 
    ) 
    (vlax-release-object HTML) 
  ) 
) 
 
;插入计算文字 
(defun GL:crjswz (GL-result / h la pt sc st ty tzbl) 
  (if (/= GL-result "") 
    (if (setq pt (getpoint "\n请点取插入点:")) 
      (if GL-ed 
        (progn 
          (setq ty (cdr (assoc 0 GL-ed)) ;字体类型 
                st (if (= "DIMENSION" (cdr (assoc 0 GL-ed))) 
                     (getvar "TEXTSTYLE") 
                     (cdr (assoc 7 GL-ed)) 
                   ) ;字体样式 
                la (cdr (assoc 8 GL-ed)) ;图层 
                h  (if (= "DIMENSION" (cdr (assoc 0 GL-ed))) 
                     (* 
                       (cdr 
                         (assoc 
                           40 
                           (tblsearch 
                             "DIMSTYLE" 
                             (cdr (assoc 3 (entget (cdr (assoc -1 GL-ed))))) 
                           ) 
                         ) 
                       ) 
                       (cdr 
                         (assoc 
                           140 
                           (tblsearch 
                             "DIMSTYLE" 
                             (cdr (assoc 3 (entget (cdr (assoc -1 GL-ed))))) 
                           ) 
                         ) 
                       ) 
                     ) 
                     (cdr (assoc 40 GL-ed)) 
                   ) ;文字高度 
                sc (cdr (assoc 47 GL-ed)) ;天正比例 
                 ;ar (cdr (assoc 41 GL-ed));文字宽高比 
                 ;co (cdr (assoc 62 GL-ed));颜色 
          ) 
          (if (wcmatch ty "TCH_*") 
            (entmake 
              (list 
                '(0 . "TEXT") 
                (cons 1 GL-result) 
                (cons 7 st) 
                (cons 8 la) 
                (cons 10 pt) 
                (cons 40 (* h sc)) 
                (cons 41 0.8) 
              ) 
            ) 
            (entmake 
              (list 
                '(0 . "TEXT") 
                (cons 1 GL-result) 
                (cons 7 st) 
                (cons 8 la) 
                (cons 10 pt) 
                (cons 40 h) 
                (cons 41 0.8) 
              ) 
            ) 
          ) 
        ) 
        (progn 
          ;(setq h (getvar 'textsize)) ;当前样式文字高度 
          (setq tzbl (getvar "HPSCALE") ;天正比例 
                h    (* tzbl 3) 
          ) 
          (entmake 
            (list 
              '(0 . "TEXT") 
              (cons 1 GL-result) 
              (cons 10 pt) 
              (cons 40 h) 
            ) 
          ) 
        ) 
      ) 
    ) 
  ) 
) 
 
;更新历史记录数据，并保存 
(defun GL:update (/ file ex) 
  (if GL-result 
    (progn 
      (setq ex (strcat GL-Num "=" GL-result)) 
      (setq GL-lst (append (list ex) GL-lst)) 
      (start_list "9") 
      (mapcar 'add_list GL-lst) 
      (end_list) 
      (setq file (open GL-text "a")) 
      (write-line ex file) 
      (close file) 
    ) 
  ) 
) 
 
;将历史记录上到计算框 
(defun GL:update-edit (value reason / a b ex i len) 
  (if (= reason 4) 
    (progn 
      (setq ex  (nth (atoi value) GL-lst) 
            len (strlen ex) 
            i   1 
            b   "" 
      ) 
      (while (<= i len) 
        (setq a (substr ex i 1)) 
        (if (= a "=") 
          (setq i (1+ len)) 
          (setq b (strcat b a)) 
        ) 
        (setq i (1+ i)) 
      ) 
      (set_tile "5" b) 
      (mode_tile "5" 2) 
      (Vlax-Invoke-Method 
        (Vlax-Get-Or-Create-Object "WScript.Shell") 
        'Sendkeys 
        "{End}" 
      ) 
    ) 
  ) 
) 
 
(defun GL-qrdhk (/ fname fn x dclid lin re YorN) 
  (setq fname (vl-filename-mktemp nil nil ".dcl")) 
  (setq fn (open fname "w")) 
  (foreach x 
    '("  qrdhk : dialog{" "  spacer_1;" "      :text{key="2";label="是否清除历史记录";}" 
      "  spacer_1;" "  :row {" "      :button{key="1";label="是";width=8;}" 
      "  spacer_1;" "      cancel_button;" "  }" "  spacer_1;" "}" 
     ) 
    (princ x fn) 
    (write-line "" fn) 
  ) 
  (close fn) 
  (setq fn (open fname "r")) 
  (setq dclid (load_dialog fname)) 
  (while 
    (or 
      (eq 
        (substr 
          (setq lin (vl-string-right-trim 
                      "" fn)" 
                      (vl-string-left-trim "(write-line "" (read-line fn)) 
                    ) 
          ) 
          1 
          2 
        ) 
        "//" 
      ) 
      (eq (substr lin 1 (vl-string-search " " lin)) "") 
      (not (eq (substr lin (+ (vl-string-search " " lin) 1) 9) " : dialog")) 
    ) 
  ) 
  (new_dialog (substr lin 1 (vl-string-search " " lin)) dclid) 
  (action_tile "1" "(done_dialog 1)") 
  (action_tile "cancel" "(done_dialog 0)") 
  (setq re (start_dialog)) 
  (cond 
    ((= re 1) (setq YorN T)) 
  ) 
  (unload_dialog dclid) 
  (close fn) 
  (vl-file-delete fname) 
  YorN 
)

账号		自动登录	找回密码
密码			注册

[源码] 阿甘计算器1.1（lsp源码版）加了2个小功能