[求助]植被填充好程序，明总能不能翻译成Ｃ＃或VB版本？？

菜鸟Liu

在CAD二次开发应该会经常遇到（闭合）Polyline的填充问题，在论坛里没有找到类似的例子？？由于是填充自定义的各种符号（如自定义块参照），使用Hatch命令未能实现或达到效果，偶然发现下面这个植被填充程序，可惜是Lisp版本，很难看懂，能不能麻烦各位明总和高手们抽时间帮忙翻译成VB或C#版本（最好是最新的.Net API版本），选择新的开发方式缺乏这样好的资源做参考。

// 问题定义：植被填充
// 转载自：http://www.objectarx.net/forum.php?mod=viewthread&tid=8985
// 理想效果：

// Lisp版本如下：

选择多段线，重量线  如果是轻量线可以用convertpoly 命令来转换

(DEFUN C:ZB()
   (setq os (getvar "osmode"))   ;获取系统当前点捕捉模式
   (setvar "osmode" 0)           ;取消点捕捉
   (command "linetype" "s" "continuous" "")   ;设置线型
   (command "layer" "m" "ZB" "s" "ZB" "")     ;设置图层
   (setq sn (entsel "\n选择要填充植被符号的Polyline封闭线:"))
   (setq sn (car sn))
   (setq s1 sn)
   (setq pname (getstring "\n输入植被符号图块名称:"))
   (Point_Pline)          ;获取Polyline线顶点坐标
;计算多边形外接最大矩形----------------------开始
   (setq n (length b) n0 0)
   (while (< n0 n)
       (setq p (nth n0 b) n0 (+ n0 1))
       (setq x (car p) y (cadr p))
       (if (= n0 1) (setq x1 x y1 y x2 x y2 y)
           (progn (if (< x x1) (setq x1 x))
                  (if (< y y1) (setq y1 y))
                  (if (> x x2) (setq x2 x))
                  (if (> y y2) (setq y2 y))
           )
       )
   )
;计算多边形外接最大矩形----------------------结束
  (setq s_long 0);判断插入1个符号或多个符号的标志(0一个/1多个)
  (if (and (> (- x2 x1) 5)(> (- y2 y1) 5))  
      (progn
         ;当外接矩形长、宽都大于5mm时，计算并填充植被符号
         (setq p1 '(0 0) p2 p1)
         (while (< (distance p1 p2) 0.00001)
                (setq p1 (nth 0 b) p2 (nth 1 b))
                (setq b (cdr b))
         )   ;排除距离小于0.00001的点
         (setq a1 (+ (angle p1 p2) (* pi 0.5)))     
         (setq p (list (* 0.5 (+ (car p1) (car p2)))
                       (* 0.5 (+ (cadr p1) (cadr p2)))
                 )
         )
         (setq poin (polar p a1 0.1)) ;计算填充多边形内或外的一点
         (command "area" "E" sn)   ;计算填充多边形的面积
         (setq s2 (getvar "area"))  ;s2=面积值
         (SETQ ROWD 10.0)   ;设置填充距离
         (if (> s2 (* rowd rowd))
             (progn
              ;如果填充多边形面积s2>100,计算植被符号插入位置
                (setq s_long 1)
              ;绘填充多边形内或外的平行多边形
                (command "offset" "0.4" S1 poin "")
                (setq sn (entlast))
                (command "area" "E" sn)  ;计算平行多边形的面积
                (setq s3 (getvar "area"))  ;s3=平行多边形的面积
                (entdel sn)         ;删除平行多边形的面积
                (if (> s3 s2)
                    (command "OFFSET" "2" s1
                                      (polar p (+ a1 pi) 0.1)
                              ""
                    )
                    (command "OFFSET" "2" S1 poin "")
                ) ;确认填充多边形的内多边形并绘制
                (setq sn (entlast))
                (Point_Pline)  ;取得内多边形顶点坐标表B
                (entdel sn)  ;删除内多边形
            );progn
         );if s2
       )
    )
    (if (= s_long 0)
        ;只绘一个符号
        (COMMAND "INSERT" pname
                          (list (* 0.5 (+ x1 x2)) (* 0.5 (+ y1 y2)))
                          1 1 ""
        )
       (progn
        ;绘多个符号
        ;计算内多边形外接最大矩形----------------------开始
        (setq n (length b))
        (setq n0 0)
        (while (< n0 n)
               (setq p (nth n0 b) n0 (+ n0 1))
               (setq x (car p) y (cadr p))
               (if (= n0 1) (setq x1 x y1 y x2 x y2 y)
                   (progn (if (< x x1) (setq x1 x))
                          (if (< y y1) (setq y1 y))
                          (if (> x x2) (setq x2 x))
                          (if (> y y2) (setq y2 y))
                   )
               );if
        )  ;while
        ;计算内多边形外接最大矩形----------------------结束
        ;计算符号插入点并插入符号----------------------开始
        (SETQ  L (- X2 X1) W (- Y2 Y1))
        (SETQ COLD (/ ROWD 2.0) DY 0.0 NUM 1)
        (setq n (- n 1))
        (setq p '(-1000000 -100000)) ;在填充区域外设定一点
        (WHILE (<= DY W)
               (SETQ DPC COLD)
               (IF (/= (REM NUM 2.0) 0.0)(SETQ DPC 0.0))
               (SETQ PC (LIST (+ X1 DPC) (+ (* (- NUM 1) COLD) Y1)))
               (SETQ DX 0.0)
               (WHILE (<= DX L)
                      (setq n0 0 k 0)
                      (while (< n0 n)
                             (setq p1 (nth n0 b) n0 (+ n0 1)
                                   p2 (nth n0 b)
                             )
                             (setq p0 (inters (LIST (CAR pc)
                                                    (CADR PC)
                                              )
                                              (LIST (CAR p)
                                                    (CADR P)
                                              )
                                              (LIST (CAR p1)
                                                    (CADR P1)
                                              )
                                              (LIST (CAR P2)
                                                    (CADR p2)
                                              )
                                              T
                              )
                              )   ;计算交点
                              (if p0 (setq k (+ k 1)))
                       )
                       (setq kk (- (* 2 (fix (/ k 2))) k))
                       (if (/= kk 0)
                           (COMMAND "INSERT" pname PC 1 1 "")
                       ) ;绘符号
                       (SETQ DX (+ DX ROWD))
                       (SETQ PC (POLAR PC 0.0 ROWD))
               )
               (SETQ DY (+ DY COLD) NUM (+ NUM 1))
       )  ;while
       ;计算符号插入点并插入符号------------------------结束
     ) ;progn s_long
  );if s_long
  (command "layer" "s" "0" "")  ;置当前层为0层
  (setvar "osmode" os)          ;恢复系统捕捉模式
  (princ)
)        ;END
;本函数需Polyline线图素名 sn   
;还回：  PolyLine线的顶点坐标b表 （p1 p2 p3 …）
(DEFUN Point_pline(/ entp mark end nump ed dp c p poi nb nb0 b0 bb b1)
        (setq entp (entnext sn))
        (setq entp (cdr (assoc 10 (entget entp))))
        (setq entp (osnap entp "NEAREST"))
        (setq mm (assoc 70 (entget sn))) (setq mark (cdr mm))
        (setq p (entnext sn))
        (SETQ POI "VERTEX")
        (SETQ END "VERTEX")
        (setq b '())
        (WHILE (= END POI)
                (setq ed (entget p))
                (setq end (assoc 0 ed))
                (setq end (cdr end))
                (IF (= END "VERTEX") (PROGN
                    (setq dp (cdr (assoc 70 ed)))
                    (if (= dp 0) (progn
                        (setq c (cdr (assoc 10 ed)) b (cons c b))
                    ))
                    (setq p (entnext p))
                ))
        )  ;while
        (if (or (= mark 1)(= mark 3)(= mark 129)(= mark 131))
            (setq b (cons (last b) b))
        )
;剔除重点
        (setq nb (length b) nb0 0 b0 (list -9999.99 -99999.99) bb '())
        (while (< nb0 nb)
                         (setq b1 (nth nb0 b))
                         (if (> (distance b0  b1) 0.004)
                             (setq bb (cons b1 bb))
                         )
                         (setq b0 b1)
                         (setq nb0 (+ nb0 1))
        )
        (setq b (reverse bb))
);END


该贴已经同步到 菜鸟Liu的微博

菜鸟Liu

都没人顶啊，高手麻烦指导一下，自己顶一下吧

zz0147

哈哈，我给你顶一下，好像也有个类似vba的。。记不清了

mkhsj928

应该是跟EXPPRESS中的SupperHatch命令一样的吧？但这个应该没SupperHatch命令强
原理好像是这样：
1求出要填充多边形的外接矩形
2计算要填充的块的外接矩形
3然后就是矩阵排列了
最后的边界部分怎么处理不清楚

菜鸟Liu

mkhsj928 发表于 2012-3-20 12:55
应该是跟EXPPRESS中的SupperHatch命令一样的吧？但这个应该没SupperHatch命令强
原理好像是这样：
1求出要 ...

从Lisp版本的来看，应该是你这个思路，可是试了好久，没转过来，请问有没有类似的程序啊，VB或者C#的

菜鸟Liu

菜鸟Liu 发表于 2012-3-21 17:43
从Lisp版本的来看，应该是你这个思路，可是试了好久，没转过来，请问有没有类似的程序啊，VB或者C#的

对不起，好像回复错位了，没有用过你说的这个命令，能具体说说吗

菜鸟Liu

mkhsj928 发表于 2012-3-20 12:55
应该是跟EXPPRESS中的SupperHatch命令一样的吧？但这个应该没SupperHatch命令强
原理好像是这样：
1求出要 ...

从Lisp版本的来看，应该是你这个思路，可是试了好久，没转过来，请问有没有类似的程序啊，VB或者C#的

caogis

测量填充植被符号有用