[已解决]各位大师：小弟求一个程序：在画出图形的同时，自动生成图形的尺寸并统计

金鹅起飞 · 发表于 2013-10-17 08:15:22

期待高手们的帮助.......................

金鹅起飞 · 发表于 2013-10-17 17:30:05

期待高手们的出现.............

st788796 · 发表于 2013-10-19 08:10:46

金鹅起飞发表于 2013-10-17 17:30
期待高手们的出现.............

用 XD::Curve:ToPopoly 找出所有的 Region，删除最大的三个，剩下就是你要的那些

金鹅起飞 · 发表于 2013-10-19 08:17:41

st788796:您好！可以请您帮忙编写一个LSP文件吗？cad原图在14楼。谢谢您了！

st788796 · 发表于 2013-10-19 09:11:36

本帖最后由 newer 于 2013-10-20 18:30 编辑

金鹅起飞发表于 2013-10-19 08:17
st788796:您好！可以请您帮忙编写一个LSP文件吗？cad原图在14楼。谢谢您了！

我的机子上 Xdrx_curve_intersectbreak 运行不稳定，没法调试，基本的都写出来了，
思路就是做 Line 的一个副本，对这个副本进行交点断开，在断开的选择集中生成面域，去掉最大

(defun c:tt (/ ss s1 region areal ar)
(if (setq ss (ssget '((0 . "line"))))
(progn
(setq s1 (xdrx_entity_transformedcopy ss (xdrx_matrix_identity 3))
ar (apply
'xdrx_points_area
(xdrx_entity_box ss)
) ; s1 (xdrx_curve_intersectbreak ss 0);_此句运行不稳定
region (vl-sort (xdrx_pickset->ents (xdrx_curve->region s1 t)) '(lambda (e1 e2)
(> (xdrx_region_area e1)
(xdrx_region_area e2)
)
)
)
areal (vl-remove-if '(lambda (a)
(equal a ar 0.001)
) (mapcar
'(lambda (x / box w h)
(setq box (xdrx_entity_box x)
w (fix (car (mapcar
'-
(cadr box)
(car box)
)
)
)
h (fix (cadr (mapcar
'-
(last box)
(car box)
)
)
)
)
(list (xdrx_region_area x) w h)
)
(cdddr region)
)
)
)
(xdrx_entity_delete s1)
(foreach x region
(xdrx_entity_delete x)
)
(princ areal)
)
)
(princ)
)

(defun c:tt (/ ss s1 region areal ar) 
  (if (setq ss (ssget '((0 . "line")))) 
    (progn 
      (setq s1 (xdrx_entity_transformedcopy ss (xdrx_matrix_identity 3)) 
            ar (apply 
                 'xdrx_points_area 
                 (xdrx_entity_box ss) 
               )                       ; s1     (xdrx_curve_intersectbreak ss 0);_此句运行不稳定 
            region (vl-sort (xdrx_pickset->ents (xdrx_curve->region s1 t)) '(lambda (e1 e2) 
                                                                              (> (xdrx_region_area e1) 
                                                                                 (xdrx_region_area e2) 
                                                                              ) 
                                                                            ) 
                   ) 
            areal (vl-remove-if '(lambda (a) 
                                   (equal a ar 0.001) 
                                 ) (mapcar 
                                     '(lambda (x / box w h) 
                                        (setq box (xdrx_entity_box x) 
                                              w (fix (car (mapcar 
                                                            '- 
                                                            (cadr box) 
                                                            (car box) 
                                                          ) 
                                                     ) 
                                                ) 
                                              h (fix (cadr (mapcar 
                                                             '- 
                                                             (last box) 
                                                             (car box) 
                                                           ) 
                                                     ) 
                                                ) 
                                        ) 
                                        (list (xdrx_region_area x) w h) 
                                      ) 
                                     (cdddr region) 
                                   ) 
                  ) 
      ) 
      (xdrx_entity_delete s1) 
      (foreach x region 
        (xdrx_entity_delete x) 
      ) 
      (princ areal) 
    ) 
  ) 
  (princ) 
)

金鹅起飞 · 发表于 2013-10-19 09:25:33

st788796:您好！
太感谢您了！我先试试，再来感谢您！

金鹅起飞 · 发表于 2013-10-19 10:31:35

本帖最后由金鹅起飞于 2013-10-19 10:33 编辑

st788796 发表于 2013-10-19 09:11
我的机子上 Xdrx_curve_intersectbreak 运行不稳定，没法调试，基本的都写出来了，
思路就是做 Line 的 ...

我刚才试了一下，请看看图片，不知是我的哪一步有问题，没有出现预期效果。请看图片：
如果看不清楚请下载到您的电脑再看，就很清楚了。谢谢您的帮助！

st788796 · 发表于 2013-10-19 10:43:21

金鹅起飞发表于 2013-10-19 10:31
我刚才试了一下，请看看图片，不知是我的哪一步有问题，没有出现预期效果。请看图片：

要先执行交点断开, 需要 xd::list:groupbyindex 函数

(defun c:tt (/ ss d region areal ar txt)
(if (and
(setq ss (ssget '((0 . "line"))))
(setq d (getdist "\nInput Thickness: "))
(setq p (getpoint "\nTextposition: "))
)
(progn
(setq d (fix d)
ar (apply
'xdrx_points_area
(xdrx_entity_box ss)
)
region (vl-sort (xdrx_pickset->ents (xdrx_curve->region ss t)) '(lambda (e1 e2)
(> (xdrx_region_area e1)
(xdrx_region_area e2)
)
)
)
areal (cdddr (vl-remove-if '(lambda (a)
(equal a ar 0.1)
) (mapcar
'(lambda (x / box w h lst)
(setq box (xdrx_entity_box x)
w (fix (car (mapcar
'-
(cadr box)
(car box)
)
)
)
h (fix (+ 0.1 (cadr (mapcar
'-
(last box)
(car box)
)
)
)
)
lst (if (> w h)
(list w h d)
(list h w d)
)
)
(list (xdrx_region_area x) lst)
)
region
)
)
)
)
(foreach x region
(xdrx_entity_delete x)
)
(foreach x (vl-sort (mapcar
'(lambda (x)
(reverse (cons (length x) (reverse (car x))))
)
(mapcar
'cdr
(xd::list:groupbyindex areal 1.)
)
) '(lambda (x1 x2)
(> (last x1) (last x2))
)
)
(setq txt (xdrx_text_make p (strcat (itoa (car x)) "x" (itoa (cadr x)) "x" (itoa (caddr x)) "=" (itoa
(last x)
)
) 17.5 0.
)
)
(xdrx_setpropertyvalue txt "widthfactor" 0.6)
(setq p (polar p (* 1.5 pi) 30.))
)
)
)
(princ)
)

(defun c:tt (/ ss d region areal ar txt) 
  (if (and 
        (setq ss (ssget '((0 . "line")))) 
        (setq d (getdist "\nInput Thickness: ")) 
        (setq p (getpoint "\nTextposition: ")) 
      ) 
    (progn 
      (setq d (fix d) 
            ar (apply 
                 'xdrx_points_area 
                 (xdrx_entity_box ss) 
               ) 
            region (vl-sort (xdrx_pickset->ents (xdrx_curve->region ss t)) '(lambda (e1 e2) 
                                                                              (> (xdrx_region_area e1) 
                                                                                 (xdrx_region_area e2) 
                                                                              ) 
                                                                            ) 
                   ) 
            areal (cdddr (vl-remove-if '(lambda (a) 
                                          (equal a ar 0.1) 
                                        ) (mapcar 
                                            '(lambda (x / box w h lst) 
                                               (setq box (xdrx_entity_box x) 
                                                     w (fix (car (mapcar 
                                                                   '- 
                                                                   (cadr box) 
                                                                   (car box) 
                                                                 ) 
                                                            ) 
                                                       ) 
                                                     h (fix (+ 0.1 (cadr (mapcar 
                                                                           '- 
                                                                           (last box) 
                                                                           (car box) 
                                                                         ) 
                                                                   ) 
                                                            ) 
                                                       ) 
                                                     lst (if (> w h) 
                                                           (list w h d) 
                                                           (list h w d) 
                                                         ) 
                                               ) 
                                               (list (xdrx_region_area x) lst) 
                                             ) 
                                            region 
                                          ) 
                         ) 
                  ) 
      ) 
      (foreach x region 
        (xdrx_entity_delete x) 
      ) 
      (foreach x (vl-sort (mapcar 
                            '(lambda (x) 
                               (reverse (cons (length x) (reverse (car x)))) 
                             ) 
                            (mapcar 
                              'cdr 
                              (xd::list:groupbyindex areal 1.) 
                            ) 
                          ) '(lambda (x1 x2) 
                               (> (last x1) (last x2)) 
                             ) 
                 ) 
        (setq txt (xdrx_text_make p (strcat (itoa (car x)) "x" (itoa (cadr x)) "x" (itoa (caddr x)) "=" (itoa 
                                                                                                              (last x) 
                                                                                                        ) 
                                    ) 17.5 0. 
                  ) 
        ) 
        (xdrx_setpropertyvalue txt "widthfactor" 0.6) 
        (setq p (polar p (* 1.5 pi) 30.)) 
      ) 
    ) 
  ) 
  (princ) 
)

st788796 · 发表于 2013-10-19 13:51:33

金鹅起飞发表于 2013-10-19 10:31
我刚才试了一下，请看看图片，不知是我的哪一步有问题，没有出现预期效果。请看图片：
如果看不清楚请下 ...

翻了翻 API 手册，可以不用生成面域的

(defun c:tt (/ ss d p pts)
(if (and
(setq ss (ssget '((0 . "line"))))
(setq d (getdist "\nInput Thickness: "))
(setq p (getpoint "\nTextposition: "))
)
(progn
(setq ;;ss (xdrx_curve_intersectbreak ss 0)
d (fix d)
pts (vl-remove
nil
(mapcar
'(lambda (x / box w h lst s1)
(if (and (setq s1 (ssget "wp" x '((0 . "text"))))
(= (sslength s1) 1)
)
(progn
(setq box (apply 'xdrx_points_box x)
w (rtos (car (mapcar '- (cadr box) (car box)))
2
0
)
h (rtos (cadr (mapcar '- (last box) (car box)))
2
0
)
lst (if (> w h)
(list w h d)
(list h w d)
)
)
(cons (abs (apply 'xdrx_points_area x))
(cons (xdrx_getpropertyvalue
(ssname s1 0)
"textstring"
)
lst
)
)
)
nil
)
)
(xdrx_geom_searchregions ss)
)
)
pts (vl-sort pts '(lambda (e1 e2) (> (car e1) (car e2))))
)
(foreach x pts
(princ "\n")
(princ x)
)
)
)
(princ)
)

(defun c:tt (/ ss d p pts) 
  (if (and 
 (setq ss (ssget '((0 . "line")))) 
 (setq d (getdist "\nInput Thickness: ")) 
 (setq p (getpoint "\nTextposition: ")) 
      ) 
    (progn 
      (setq ;;ss (xdrx_curve_intersectbreak ss 0) 
     d (fix d) 
     pts (vl-remove 
    nil 
    (mapcar 
      '(lambda (x / box w h lst s1) 
         (if (and (setq s1 (ssget "wp" x '((0 . "text")))) 
    (= (sslength s1) 1) 
      ) 
    (progn 
      (setq box (apply 'xdrx_points_box x) 
     w   (rtos (car (mapcar '- (cadr box) (car box))) 
        2 
        0 
         ) 
     h   (rtos (cadr (mapcar '- (last box) (car box))) 
        2 
        0 
         ) 
     lst (if (> w h) 
           (list w h d) 
           (list h w d) 
         ) 
      ) 
      (cons (abs (apply 'xdrx_points_area x)) 
     (cons (xdrx_getpropertyvalue 
      (ssname s1 0) 
      "textstring" 
           ) 
           lst 
     ) 
      ) 
    ) 
    nil 
         ) 
       ) 
      (xdrx_geom_searchregions ss) 
    ) 
  ) 
     pts (vl-sort pts '(lambda (e1 e2) (> (car e1) (car e2)))) 
      ) 
      (foreach x pts 
 (princ "\n") 
 (princ x) 
      ) 
    ) 
  ) 
  (princ) 
)

金鹅起飞 · 发表于 2013-10-22 08:14:19

st788796 发表于 2013-10-19 13:51
翻了翻 API 手册，可以不用生成面域的

st788796:您好！非常感谢您在百忙之中编写的程序，谢谢您！
我下载使用了一下，不知哪里我没有操作对，请您看看下面的图片，特别是命令栏，我不知道怎样操作是不是对的，请指教！如果图片看不清楚，请下载到自己的电脑，打开看就清楚了，谢谢！

Free-Lancer · 发表于 2013-10-22 10:26:45

金鹅起飞发表于 2013-10-22 08:14
st788796:您好！非常感谢您在百忙之中编写的程序，谢谢您！
我下载使用了一下，不知哪里我没有操作对， ...

试了试，结果没有排序，还差写字部分

写诗天涯 · 发表于 2013-10-22 11:18:12

学习一下这个帖子

金鹅起飞 · 发表于 2013-10-22 11:44:00

Free-Lancer 发表于 2013-10-22 10:26
试了试，结果没有排序，还差写字部分

Free-Lancer:
您好！您能帮忙写一个程序吗？谢谢您！

金鹅起飞 · 发表于 2013-10-22 11:44:41

写诗天涯发表于 2013-10-22 11:18
学习一下这个帖子

谢谢关注！

st788796 · 发表于 2013-10-22 22:37:11

本帖最后由 st788796 于 2013-10-22 22:45 编辑

金鹅起飞发表于 2013-10-22 11:44
谢谢关注！

已经完成，和 API更新同时发布

账号		自动登录	找回密码
密码			立即注册

[已解决] [已解决]各位大师：小弟求一个程序：在画出图形的同时，自动生成图形的尺寸并统计

点评

点评

点评

点评

点评

点评

点评

点评

点评

点评

浏览过的版块