求助：经典输出面积与周长源码，langjs写的

不语勿语

既然发消息给我那就编一个。使用时不保证100％正确。
;;; 框选封闭区域面积到excel    by:langjs
;;; ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
(defun c:qq (/ d ent f i lst m2 obj pt ss txt x y)
(setq TextHeight (getdist "\n输入标注文字高度:")
Textbh (getstring "\n输入编号前缀:"))
  (defun maketext (txt pt)             ; 生成文字子函数
    (entmake (list '(0 . "TEXT") (cons 62 1) (cons 10 pt) (cons 40 TextHeight) (cons 1 txt) '(41 . 0.8)))
  )
  (setvar "cmdecho" 0)
  (vl-load-com)
  (setq ss (ssget) ent (entlast))
  (command ".region" ss "")
  (setq ss (ssadd)  lst nil)
  (while (setq ent (entnext ent))
    (if (= (cdr (assoc 0 (entget ent))) "REGION")
      (setq obj (vlax-ename->vla-object ent) pt (vlax-safearray->list (vlax-variant-value (vla-get-centroid obj)))
            m2 (rtos (vla-get-area obj) 2 2) d (rtos (vla-get-perimeter obj) 2 2) lst (cons (list pt m2 d) lst)
      )
    )
  )                （setq txt (vla-get-perimeter obj))
      
  (command ".undo" "")
  (setq lst (vl-sort lst (function (lambda (x y)(< (car (car x)) (car (car y)))))))
  (setq lst (vl-sort lst (function (lambda (x y)(> (cadr (car x)) (cadr (car y)))))))
  (setq f (getfiled "指定输出文件路径" "" "xls" 1) f (open f "a"))
  (write-line "编号\t周长(mm)\t面积(mm2)" f)
  (setq i 1)
  (foreach x lst
    (setq pt (car x) m2 (cadr x) d (caddr x))
    (maketext (strcat Textbh (itoa i)) (list (car pt) (+ (cadr pt) (* 1.2 TextHeight))))
    (maketext (strcat "L=" d "mm") pt)
    (maketext (strcat "S=" m2 "mm2") (list (car pt) (- (cadr pt) (* 1.2 TextHeight))))
    (write-line (strcat (strcat Textbh (itoa i)) "\t" d "\t" m2) f)
    (setq i (1+ i))
  )
  (close f)
  (princ)
)

红色的那句是我自已加的，程序可以通过，但是不知道为什么提示那句表达式：错误: 参数类型错误: streamp nil，想了好久，本人实在木瓜脑壳想不出来，只能求助大师，如果要那句话定义，不知道如何写？？？

yxp

1. ;; 功能： 输出封闭多边形边长及面积 到 EXCEL 文件
   
2. ;; 编写： yxp   2017-3-31   QQ：9034598
   
3. ;; (vla-get-area (vlax-ename->vla-object (car (entsel "\n选择多段线: "))))
   
4. (vl-load-com)
   
5. (defun c:mjs ( / ent ob S L A d H xy xzz old)
   
6.   (setq old (getvar "osmode") ent (entlast))
   
7.   (mapcar '(lambda(x)(setvar x 0))(list "cmdecho" "osmode" "delobj"))
   
8.   (vl-cmdf "_region" (ssget ":L") "")
   
9.   ;(vla-AddRegion )
   
10.   (while (setq ent (entnext ent))
    
11.     (setq ob (vlax-ename->vla-object ent)
    
12.       L (vla-get-perimeter ob)
    
13.       A (vla-get-Area ob)
    
14.       H (/ (sqrt A) 12.0)
    
15.       S (cdr (assoc 5 (entget ent))) ;; (itoa (if n (setq n (1+ n))(setq n 1)))
    
16.       d (cons (list S L A) d)
    
17.       xy (vlax-safearray->list (vlax-variant-value (vla-get-centroid ob)))
    
18.       xy (polar xy 0 (* -4.0 H))
    
19.       xzz (cons (list (list S (list (car xy)(+ (cadr xy) (* 1.5 H))) H)
    
20.         (list (strcat "S= " (rtos L 2)) xy H)
    
21.         (list (strcat "C= " (rtos A 2))(list (car xy)(- (cadr xy)(* 1.5 H))) H)) xzz))
    
22.     (entdel ent)
    
23.   )
    
24.   (foreach x xzz (foreach y x (apply 'MxTxt y)))
    
25.   (if d (SaveExcel (cons '("编号" "周长" "面积") (reverse d))))
    
26.   (setvar "osmode" old)
    
27.   (princ)
    
28. )
    
29. (defun SaveExcel( Lit / a r c d)
    
30.   (if (null *appxls*) (princ "\n程序首次运行需要打开 excel 程序，请耐心等候..."))
    
31.   (setq *appxls* (vlax-get-or-create-object "excel.application"))
    
32.   (setq a (vl-catch-all-error-p (vl-catch-all-apply 'vlax-get-property (list *appxls* "sheets"))))
    
33.   (vlax-invoke-method (vlax-get-property *appxls*  (if a "workbooks" "sheets")) "add")
    
34.   (setq newite (vlax-get-property (vlax-get-property *appxls* "sheets") "item" 1)
    
35.     xlscells (vlax-get-property newite "cells")
    
36.     r 0 c 0)
    
37.   (vla-put-visible *appxls* 1)
    
38.   (repeat (length Lit)
    
39.     (setq d (nth r Lit) r (1+ r))
    
40.     (repeat (length d)
    
41.       (vlax-put-property xlscells "item" r (1+ c)
    
42.         (vl-princ-to-string (nth c d)))
    
43.       (setq c (1+ c))
    
44.     )(setq c 0)
    
45.   )
    
46.   (vlax-release-object xlscells)
    
47.   (vlax-release-object newite)
    
48.   (vlax-release-object *appxls*)
    
49. )
    
50. (defun MxTxt(s p H)(entmake (list '(0 . "TEXT")(cons 1 s)(cons 10 p)(cons 40 H))))
    
51. (princ "\n文件加载成功，请输入 mjs 命令")
    
52. (princ)

;; 功能： 输出封闭多边形边长及面积 到 EXCEL 文件<br /> ;; 编写： yxp   2017-3-31   QQ：9034598<br /> ;; (vla-get-area (vlax-ename->vla-object (car (entsel "\n选择多段线: "))))<br /> (vl-load-com)<br /> (defun c:mjs ( / ent ob S L A d H xy xzz old)<br />   (setq old (getvar "osmode") ent (entlast))<br />   (mapcar '(lambda(x)(setvar x 0))(list "cmdecho" "osmode" "delobj"))<br />   (vl-cmdf "_region" (ssget ":L") "")<br />   ;(vla-AddRegion )<br />   (while (setq ent (entnext ent))<br />     (setq ob (vlax-ename->vla-object ent)<br />       L (vla-get-perimeter ob)<br />       A (vla-get-Area ob)<br />       H (/ (sqrt A) 12.0)<br />       S (cdr (assoc 5 (entget ent))) ;; (itoa (if n (setq n (1+ n))(setq n 1)))<br />       d (cons (list S L A) d)<br />       xy (vlax-safearray->list (vlax-variant-value (vla-get-centroid ob)))<br />       xy (polar xy 0 (* -4.0 H))<br />       xzz (cons (list (list S (list (car xy)(+ (cadr xy) (* 1.5 H))) H)<br />         (list (strcat "S= " (rtos L 2)) xy H)<br />         (list (strcat "C= " (rtos A 2))(list (car xy)(- (cadr xy)(* 1.5 H))) H)) xzz))<br />     (entdel ent)<br />   )<br />   (foreach x xzz (foreach y x (apply 'MxTxt y)))<br />   (if d (SaveExcel (cons '("编号" "周长" "面积") (reverse d))))<br />   (setvar "osmode" old)<br />   (princ)<br /> )<br /> (defun SaveExcel( Lit / a r c d)<br />   (if (null *appxls*) (princ "\n程序首次运行需要打开 excel 程序，请耐心等候..."))<br />   (setq *appxls* (vlax-get-or-create-object "excel.application"))<br />   (setq a (vl-catch-all-error-p (vl-catch-all-apply 'vlax-get-property (list *appxls* "sheets"))))<br />   (vlax-invoke-method (vlax-get-property *appxls*  (if a "workbooks" "sheets")) "add")<br />   (setq newite (vlax-get-property (vlax-get-property *appxls* "sheets") "item" 1)<br />     xlscells (vlax-get-property newite "cells")<br />     r 0 c 0)<br />   (vla-put-visible *appxls* 1)<br />   (repeat (length Lit)<br />     (setq d (nth r Lit) r (1+ r))<br />     (repeat (length d)<br />       (vlax-put-property xlscells "item" r (1+ c)<br />         (vl-princ-to-string (nth c d)))<br />       (setq c (1+ c))<br />     )(setq c 0)<br />   )<br />   (vlax-release-object xlscells)<br />   (vlax-release-object newite)<br />   (vlax-release-object *appxls*)<br /> )<br /> (defun MxTxt(s p H)(entmake (list '(0 . "TEXT")(cons 1 s)(cons 10 p)(cons 40 H))))<br /> (princ "\n文件加载成功，请输入 mjs 命令")<br /> (princ)

不语勿语

yxp 发表于 2018-4-24 22:30

谢谢回复， 我想知道上面那句（setq txt (vla-get-perimeter obj))，不对的话，我改用了
(setq str "d")
  (atof str)     就是想取"d"这个字符串来转成实数进行加减，可是还是不可以，不知道如何才行呢 ？？

yxp

不语勿语 发表于 2018-4-24 22:42
谢谢回复， 我想知道上面那句（setq txt (vla-get-perimeter obj))，不对的话，我改用了
(setq str "d") ...

(atof "d")  返回 0.0  有什么意义？

不语勿语

，在这个程式里，选取图形后，那个d输出的是周长数值，我就是想提取这个数值进行四则运算

yxp

四则运算可以用字符串 strcat 组成表达式，比如 "(+ 5 5)" ，数字可以是变量，然后用下面函数求值。
(eval (read "(+ 5 5)"))

不语勿语

不明白，举个例子
(setq   cc 20   vv  100   )
(setq xx  (/ ( (eval (read "+d")) (* cc (* vv )) ) 1) )；；；这样表达可以吗

yxp

不语勿语 发表于 2018-4-24 23:31
不明白，举个例子
(setq   cc 20   vv  100   )
(setq xx  (/ ( (eval (read "+d")) (* cc (* vv )) )  ...

汗，搞了半天你对 lisp 一窍不通啊，你那表达式，语法都不对。
(* vv ) 少个乘数，能这么写吗？
多看看基础语法。
我又试了一下， (* vv ) 返回 vv

不语勿语

少写了
(setq   cc 20   vv  100   )
(setq xx  (/ ( *(eval (read "+d+")) (* cc (* vv )) ) 1) )

不语勿语

不懂呀，呵呵，能说明白点不