xiaodao520 发表于 2012-7-2 16:25:00

请langs大师帮帮忙。

本帖最后由 xiaodao520 于 2012-7-2 20:15 编辑

要求增加将周长和面积标注到图形中功能，如L= ****mm,S=*****mm2，同时输出到EXCEL中。

以下代码来自：http://bbs.mjtd.com/forum.php?mod=viewthread&tid=92023

;;; 框选封闭区域面积到excel   
;;; ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
(defun c:qq (/ appxls col ent ent1 ent2 f i lst lst1 m2 maxpoint minpoint na
      newbook newitem newsheet numrow pc pmax pmin pt sc snap ss
      txt value vh viewsize vw x xlscells xlsworkbooks y
   )
(defun GetViewSize (/ pc vh sc vw vh pmin pmax)
    (setq pc (getvar "viewctr")
   vh (getvar "viewsize")
   sc (getvar "screensize")
   vw (* vh (/ (car sc) (cadr sc)))
   pmin (list (- (car pc) (* 0.5 vw)) (- (cadr pc) (* 0.5 vh)))
   pmax (list (+ (car pc) (* 0.5 vw)) (+ (cadr pc) (* 0.5 vh)))
    )
    (list pmin pmax)
)
(defun initexcel ()
    (setq appxls (vlax-get-or-create-object "excel.application")
   xlsworkbooks (vlax-get-property appxls "workbooks")
   newbook (vlax-invoke-method xlsworkbooks "add")
   newsheet (vlax-get-property newbook "sheets")
   newitem (vlax-get-property newsheet "item" 1)
   xlscells (vlax-get-property newitem "cells")
    )
    (vla-put-visible appxls :vlax-true)
)
(defun endexcel ()
    (vlax-release-object xlscells)
    (vlax-release-object newitem)
    (vlax-release-object newsheet)
    (vlax-release-object newbook)
    (vlax-release-object xlsworkbooks)
    (vlax-release-object appxls)
)
(defun datacell (nurow col value)
    (vlax-put-property xlscells "item" numrow col
         (vl-princ-to-string value)
    )
)
(vl-load-com)
(setvar "cmdecho" 0)
(setq snap (getvar "osmode"))      ; 关闭捕捉
(setvar "osmode" 0)
(if (setq ss (ssget '((0 . "*TEXT"))))
    (progn
      (setq ViewSize (GetViewSize))
      (setq lst1 '())
      (repeat (setq i (sslength ss))
(setq ent (entget (ssname ss (setq i (1- i))))
       pt (cdr (assoc 10 ent))
       txt (cdr (assoc 1 ent))
)
(command "-boundary" pt "")
(setq ent2 (entlast))
(if (= (cdr (assoc 0 (entget ent2))) "LWPOLYLINE")
   (progn
   (vla-getboundingbox (vlax-ename->vla-object ent2) 'minpoint
    'maxpoint
   )
   (setq pmax (vlax-safearray->list maxpoint)
    pmin (vlax-safearray->list minpoint)
   )
   (entdel ent2)
   (setq lst1 (cons (list pmin pmax pt txt) lst1))
   )
)
      )
      (= lst nil)
      (repeat (setq i (length lst1))
(setq na (nth (setq i (1- i))
      lst1
   )
       pmin (car na)
       pmax (cadr na)
       pt (caddr na)
       txt (cadddr na)
)
(command ".zoom" "W" pmin pmax)
(command "-boundary" pt "")
(command ".region" (entlast) "")
(setq ent1 (entlast))
(if (= (cdr (assoc 0 (entget ent1))) "REGION")
   (setq ent (vlax-ename->vla-object ent1)
m2 (rtos (vla-get-area ent) 2 2)
lst (cons (list txt m2) lst)
f (entdel ent1)
   )
)
      )
      (command ".zoom" "W" (car ViewSize) (cadr ViewSize))
      (setq lst (vl-sort lst (function (lambda (x y)
      (< (car x) (car y))
         )
      )
)
      )
      (setq lst (cons (list "版号" "面积") lst))
      (initexcel)
      (setq numrow 1)
      (foreach f lst
(datacell numrow 1 (car f))
(datacell numrow 2 (cadr f))
(setq numrow (1+ numrow))
      )
      (endexcel)
    )
)
(setvar "osmode" snap)      ; 恢复捕捉
(princ)
)


xiaodao520 发表于 2012-7-2 17:48:03

langs哥帮帮忙，

xiaodao520 发表于 2012-7-2 22:35:44

自己顶下

xiaodao520 发表于 2012-7-3 07:08:43

没人过问，

langjs 发表于 2012-7-3 21:35:12

才看到，最近没泡论坛

九日生 发表于 2016-4-22 19:49:50

区域一多就出问题啦
页: [1]
查看完整版本: 请langs大师帮帮忙。