hn10183051 发表于 2019-8-19 15:20:08

批量绘制四边形

本帖最后由 hn10183051 于 2019-8-19 15:21 编辑

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


yshf 发表于 2019-8-19 15:20:09

已加入绘制起点。

yshf 发表于 2019-8-19 16:59:11

;试用以下程序
(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 发表于 2019-8-19 17:09:47

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

hn10183051 发表于 2019-8-19 17:11:07

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


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

hn10183051 发表于 2019-8-19 17:15:03

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

hn10183051 发表于 2019-8-19 17:23:02

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

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

hn10183051 发表于 2019-8-19 18:21:59

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

xyp1964 发表于 2019-8-19 22:49:12

本帖最后由 xyp1964 于 2019-8-19 22:50 编辑

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

yshf 发表于 2019-8-20 07:17:26

将四边形数据文件.xls别存为以逗号分隔的*.csv文件，加载附件中plhzsbx.fas，使用命令PLHZSBX，即可绘制。
页: [1] 2 3
查看完整版本: 批量绘制四边形