所有明经币求 列乘积 lisp

wchsunshine

QQ 1615388511

bssurvey

我是用笨方法
看是不是您想要的，看可不可幫助到您，不求明經幣
(defun c:t()                                                      
  (setvar "cmdecho" 0)                                            
  (prompt "请选择左侧的列")                                       
  (setq left1(ssget '((0 . "text"))))                             
  (setq lt1(sslength left1))                                      
  (setq i 0)                                                      
  (prompt "\n请选择右侧的列")                                    
  (setq right1(ssget '((0 . "text"))))                           
  (repeat lt1                                                     
    (setq rt1(sslength right1))                                   
    (setq j 0)                                                   
    (setq ent(entget (ssname left1 i)))                           
    (setq l-pt(cdr (assoc 10 ent)))                              
    (setq txth(cdr (assoc 40 ent)))                              
    (setq l-pt-x(car(cdr (assoc 10 ent))))                        
    (setq l-pt-y(cadr(cdr (assoc 10 ent))))                       
    (setq ltxt(cdr (assoc 1 ent)))                                
    (repeat rt1                                                   
      (setq rent(entget (ssname right1 j)))                       
      (setq r-pt(cdr (assoc 10 rent)))                           
      (setq r-pt-x(car(cdr (assoc 10 rent))))                     
      (setq r-pt-y(cadr(cdr (assoc 10 rent))))                    
      (setq rtxt(cdr (assoc 1 rent)))                             
      (if (= l-pt-y r-pt-y)                                       
        (progn                                                   
          (setq x1(rtos (* (atof ltxt) (atof rtxt)) 2 1))         
          (setq ang1(angle l-pt r-pt))                           
          (setq di1(distance l-pt r-pt))                          
          (setq pt1(polar r-pt ang1 (* di1 2)))                  
          (command "text" "c" pt1 txth "0" x1)                    
        )                                                         
      )                                                           
      (setq j(1+ j))                                             
    )                                                            
    (setq i(1+ i))                                                
  )                                                               
  (setvar "cmdecho" 1)                                            
)                                                                 

wchsunshine

坐等大师帮忙看下  ，  必大谢

wchsunshine

大家帮我顶上去哈   ，急用

wchsunshine

求 大师帮写程序  必谢。

vitalgg

http://atlisp.cn  安装数学工具 应用包

wchsunshine

vitalgg 发表于 2021-3-7 21:42
http://atlisp.cn  安装数学工具 应用包

我只要单独的这个功能  我不要软件包    能不能给个lisp？？

vitalgg

wchsunshine 发表于 2021-3-9 21:18
我只要单独的这个功能  我不要软件包    能不能给个lisp？？

我微信只聊天，偶尔看朋友圈，能把其它的游戏，看一看之类的删了吗？

1. (defun @m:sort-by-y (ss-lst)
   
2.   (vl-sort ss-lst '(lambda (e1 e2)
   
3.                     (> (cadr (entity:getdxf e1 10))
   
4.                      (cadr (entity:getdxf e2 10))))))
   
5. (defun @m:column-cal (/ cal-symble number-lst ss i% res-matrix)
   
6.   (initget 1 "+ - * /")
   
7.   (setq cal-symble (getkword "请输入运算符 (+ - * /): "))
   
8.   (setq number-lst '())
   
9.   (setq i% 0)
   
10.   (prompt (strcat "请选择第 " (itoa (1+ i%)) " 列:"))
    
11.   (while (setq ss (ssget '((0 . "text"))))
    
12.     (if number-lst
    
13.         (setq number-lst
    
14.               (append number-lst (list
    
15.                                   (@m:sort-by-y (ss:to-entlist ss)))))
    
16.         (setq number-lst (list  (@m:sort-by-y (ss:to-entlist ss)))))
    
17.     (setq i% (1+ i%))
    
18.     (prompt (strcat "请选择第 " (itoa (1+ i%)) " 列:"))
    
19.     )
    
20.   (setq res-matrix '())
    
21.   (foreach matrix number-lst
    
22.            (if res-matrix
    
23.                (setq res-matrix
    
24.                      (mapcar (read cal-symble) res-matrix
    
25.                              (mapcar
    
26.                               '(lambda (x) (atof (entity:getdxf x 1)))
    
27.                                matrix)))
    
28.                (setq res-matrix
    
29.                      (mapcar '(lambda (x) (atof (entity:getdxf x 1)))
    
30.                              matrix)))
    
31.            )
    
32.   ;; 写图
    
33.   (mapcar '(lambda (x y)
    
34.             (entity:make-text
    
35.              (rtos x 2 2)
    
36.              (polar (entity:getdxf y 10) 0 1000)
    
37.              250 0 0.8 0 13))
    
38.           res-matrix (last number-lst))
    
39.              
    
40.   
    
41.   )

(defun @m:sort-by-y (ss-lst)<br />   (vl-sort ss-lst '(lambda (e1 e2)<br />                     (> (cadr (entity:getdxf e1 10))<br />                      (cadr (entity:getdxf e2 10))))))<br /> (defun @m:column-cal (/ cal-symble number-lst ss i% res-matrix)<br />   (initget 1 "+ - * /")<br />   (setq cal-symble (getkword "请输入运算符 (+ - * /): "))<br />   (setq number-lst '())<br />   (setq i% 0)<br />   (prompt (strcat "请选择第 " (itoa (1+ i%)) " 列:"))<br />   (while (setq ss (ssget '((0 . "text"))))<br />     (if number-lst<br />         (setq number-lst<br />               (append number-lst (list<br />                                   (@m:sort-by-y (ss:to-entlist ss)))))<br />         (setq number-lst (list  (@m:sort-by-y (ss:to-entlist ss)))))<br />     (setq i% (1+ i%))<br />     (prompt (strcat "请选择第 " (itoa (1+ i%)) " 列:"))<br />     )<br />   (setq res-matrix '())<br />   (foreach matrix number-lst<br />            (if res-matrix <br />                (setq res-matrix<br />                      (mapcar (read cal-symble) res-matrix <br />                              (mapcar<br />                               '(lambda (x) (atof (entity:getdxf x 1)))<br />                                matrix)))<br />                (setq res-matrix<br />                      (mapcar '(lambda (x) (atof (entity:getdxf x 1)))<br />                              matrix)))<br />            )<br />   ;; 写图<br />   (mapcar '(lambda (x y)<br />             (entity:make-text<br />              (rtos x 2 2)<br />              (polar (entity:getdxf y 10) 0 1000)<br />              250 0 0.8 0 13))<br />           res-matrix (last number-lst))<br />              <br />   <br />   )

bai2000

我这有个，不知哪位大神的，你看看

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;两列连续相乘
(defun c:*2 ( / ss1 ss2 ss3 ss1len ss2len ss3len tt1 tt2 tt3 str1 str2 str3)
  (while (= ss1 nil)
    (princ "\n选择第一列(行)数据：")
    (setq ss1         (ssget '((0 . "TEXT,MTEXT"))))
    (if        (= ss1 nil)
      (progn
        (princ "\n~~~\n~~~\n***ERROR：没有选择任何文本数据，请重新选择!***")
        (princ)
      )
    )
    (if        (/= ss1 nil)
      (setq ss1len (sslength ss1))
    )
  )  
  (while (= ss2 nil)
    (princ "\n选择第二列(行)数据:")
    (setq ss2         (ssget '((0 . "TEXT,MTEXT")))
    )
    (if        (= ss2 nil)
      (progn
        (princ "\n~~~\n~~~\n***ERROR：没有选择任何数据!请重新选择!***")
        (princ)
      )
    )
    (if        (/= ss2 nil)
      (setq ss2len (sslength ss2))
    )
    (if        (and (/= ss2 nil) (/= ss2len ss1len))
      (progn
        (princ "\n~~~\n~~~\n***ERROR：数据个数不同!!!***\n***第一次共选择了" )
        (princ ss1len)
        (princ "个数据****\n***请选择相同个数!!!!!!*****")
        (princ)
        (setq ss2 nil)
      )
    )      
  )

  (while (= ss3 nil)
    (princ "\n选择第3列(行)数据,存储前两列相乘结果:")
    (setq ss3         (ssget '((0 . "TEXT,MTEXT")))
    )
    (if        (= ss3 nil)
      (progn
        (princ "\n~~~\n~~~\n***ERROR：没有选择任何数据!请重新选择!***")
        (princ)
      )
    )
    (if        (/= ss3 nil)
      (setq ss3len (sslength ss3))
    )
    (if        (and (/= ss3 nil) (/= ss3len ss1len))
      (progn
        (princ "\n~~~\n~~~\n***ERROR：数据个数不同!!!***\n***第一次共选择了" )
        (princ ss1len)
        (princ "个数据****\n***请选择相同个数!!!!!!*****")
        (princ)
        (setq ss3 nil)
      )
    )      
  )
  (setq num 0)
  (repeat ss1len
    (setq tt1  (entget (ssname ss1 num))
          str1 (read (cdr (assoc 1 tt1)))
          tt2  (entget (ssname ss2 num))
          str2 (read (cdr (assoc 1 tt2)))
          tt3  (entget (ssname ss3 num))
          str3 (rtos (* str1 str2) 2 3)
          num (+ num 1)
          tt3  (cdr (assoc -1 tt3))
          tt3  (vlax-ename->vla-object tt3)
    )
    (vla-put-textstring tt3 str3)
  )
)

wchsunshine

bssurvey 发表于 2021-3-11 09:26
我是用笨方法
看是不是您想要的，看可不可幫助到您，不求明經幣
(defun c:t()                           ...

测试了，可以算乘积。希望增加乘积计算后，替换文本功能，这样可以计算后直接替换原文本，就非常好了。