批量绘制四边形

hn10183051

求个批量绘制四边形程序，知道4条边的长度和1条对角线，数据见表格

yshf

已加入绘制起点。

yshf

;试用以下程序
(defun c:test()
     (setq bcsjb '(("A1" 9549.31 6977.53 7180.75 7155.97 11015.11)
                   ("A2" 10814.00 7468.76 6367.24 7155.97 11072.28)
                   ("A3" 4563.99 6621.92 6732.4        7155.97        10938.9)
                   ("A4" 4911.96 6422.68 11368.55 7538.32 10932.26)
                  )
     )
     (setq cmd (getvar "cmdecho"))
     (setq osm (getvar "osmode"))
     (setvar "cmdecho" 0)
     (setvar "osmode" 0)
     (command "_undo" "be")
     (setq ljc 0.0)
     (setq i 0)
     (setq n (length bcsjb))
     (repeat n
         (setq sjb (nth i bcsjb))
         (mapcar 'set '(zfc c a d e b) sjb)
         (setq CosA (/ (- (+ (* b b) (* c c)) (* a a)) 2.0 b c))
         (setq jdA (atan (/ (sqrt (- 1.0 (* CosA CosA))) CosA )))
         (setq p1 (list ljc 0))
         (setq p2 (mapcar '+ p1 (list c 0)))
         (setq p3 (polar p1 jdA b))
         
         (setq CosB (/ (- (+ (* b b) (* e e)) (* d d)) 2.0 b e))
         (setq jdB (atan (/ (sqrt (- 1.0 (* CosB CosB))) CosB)))
         (setq p4 (polar p1 (+ jdA jdB) e))
         (setq pmid (mapcar '(lambda(x y)(* 0.5 (+ x y))) p1 p3))
         (command "_pline" p1 p2 p3 p4 "c")
         (command "_text" pmid 1000 0 zfc)
         (setq ptmin (apply 'mapcar (cons 'min (list p1 p2 p3 p4))))
         (setq ptmax (apply 'mapcar (cons 'max (list p1 p2 p3 p4))))
         (setq dxy (mapcar '- ptmax ptmin))
         (setq ljc (+ ljc (car dxy) 2000.0))
         (setq i (1+ i))
     )
     (command "_undo" "e")
     (setvar "osmode" osm)
     (setvar "cmdecho" cmd)
     (princ)
)             

yshf

在H2单元格写入以下公式：
="("&CHAR(34)&B2&CHAR(34)&" "&C2&" "&D2&" "&E2&" "&F2&" "&G2&")"
往下填充，再复制，再粘贴。或者存入文件中，因为不直接读Excel文件。

hn10183051

yshf 发表于 2019-8-19 16:59
;试用以下程序
(defun c:test()
     (setq bcsjb '(("A1" 9549.31 6977.53 7180.75 7155.97 11015.11)

您这个程序是可以用，但不是从EXCEL里导入进来。每次的数据都不一样。求大神更改一下。。谢谢

hn10183051

每次的数据都不一样，想直接从ECECL里提取数据，

hn10183051

yshf 发表于 2019-8-19 17:09
在H2单元格写入以下公式：
="("&CHAR(34)&B2&CHAR(34)&" "&C2&" "&D2&" "&E2&" "&F2&" "&G2&")"
往下填充 ...

能不能帮忙改成读取EXCEL呢？  谢谢

hn10183051

没有大师帮忙吗？  版主帮帮忙~~

xyp1964

1. (defun c:tt ()
   
2.   ;; tt(数据四边形)
   
3.   (xyp-StartSc)
   
4.   (setq lst (xyp-xls2list "11.xlsx")
   
5.         p1  '(0 0)
   
6.   )
   
7.   (foreach a (cdr lst)
   
8.     (setq bh (nth 1 a)
   
9.           a  (mapcar 'distof (cddr a))
   
10.           s1 (xyp-Square p1 (nth 0 a)  (nth 1 a) (nth 2 a) (nth 3 a) (nth 4 a) nil t)
    
11.     )
    
12.     (entdel s1)
    
13.     (setq s2 (entlast))
    
14.     (entdel s1)
    
15.     (setq s3 (xyp-Text 5 (xyp-cpt s2) bh)
    
16.           p1 (xyp-Pt2X (xyp-9pt s2 3) 500)
    
17.     )
    
18.   )
    
19.   (xyp-End)
    
20. )

(defun c:tt ()<br />   ;; tt(数据四边形)<br />   (xyp-StartSc)<br />   (setq lst (xyp-xls2list "11.xlsx")<br />         p1  '(0 0)<br />   )<br />   (foreach a (cdr lst)<br />     (setq bh (nth 1 a)<br />           a  (mapcar 'distof (cddr a))<br />           s1 (xyp-Square p1 (nth 0 a)  (nth 1 a) (nth 2 a) (nth 3 a) (nth 4 a) nil t)<br />     )<br />     (entdel s1)<br />     (setq s2 (entlast))<br />     (entdel s1)<br />     (setq s3 (xyp-Text 5 (xyp-cpt s2) bh)<br />           p1 (xyp-Pt2X (xyp-9pt s2 3) 500)<br />     )<br />   )<br />   (xyp-End)<br /> )

yshf

将四边形数据文件.xls别存为以逗号分隔的*.csv文件，加载附件中plhzsbx.fas，使用命令PLHZSBX，即可绘制。