求根据图上三角网自动生成范围线程序。

lizhgang.jin · 发表于 2015-1-10 12:45:55

本帖最后由 lizhgang.jin 于 2015-1-10 14:15 编辑

每次生成地形图后要修改三角网，后用多断线将范围围出来，原来全手工，如果三角网太多就很费时间。想请高手帮编写一个选定三角网后自动标注范围的程序。三角网在我附件里，这个程序应该不难，最好是LSP,能解决就好。谢谢各位大师了又来求教了。

dnbcgrass · 发表于 2015-1-10 12:45:56

请试用以下程序:

(defun c:sjwbj()
(defun bjjc(Xbhb Xp1 Xp2 / pdbz i n pt1 pt2 ptb)
(if (= Xbhb nil)
(setq Xbhb (cons (list 1 Xp1 Xp2) Xbhb))
(progn
(setq pdbz nil i 0 n (length Xbhb))
(while (< i n)
(setq ptb (nth i Xbhb)
pt1 (cadr ptb)
pt2 (caddr ptb)
)
(if (or (and (equal Xp1 pt1 1e-6) (equal Xp2 pt2 1e-6))
(and (equal Xp1 pt2 1e-6) (equal Xp2 pt1 1e-6))
)
(setq pdbz ptb i n)
)
(setq i (1+ i))
)
(if (= pdbz nil)
(setq Xbhb (cons (list 1 Xp1 Xp2) Xbhb))
(setq Xbhb (subst (subst (1+ (car pdbz)) (car pdbz) pdbz) pdbz Xbhb))
)
)
)
(setq Xbhb Xbhb)
)
(vl-load-com)
(setq cm (getvar "cmdecho")
os (getvar "osmode")
)
(setvar "cmdecho" 0)
(setvar "osmode" 0)
(command "_undo" "be")
(if (setq ssa (ssget '((0 . "POLYLINE") (8 . "SJW") (66 . 1))))
(progn
(setq bjb nil
tymb (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssa)))
)
(foreach ent tymb
(setq obj (vlax-ename->vla-object ent)
pts (vlax-get obj "Coordinates")
p1 (list (car pts) (cadr pts) (caddr pts))
pts (cdr (cdr (cdr pts)))
p2 (list (car pts) (cadr pts) (caddr pts))
p3 (cdr (cdr (cdr pts)))
bjb (bjjc bjb p1 p2)
bjb (bjjc bjb p2 p3)
bjb (bjjc bjb p3 p1)
)
)
(setq bjb (vl-remove-if '(lambda(x)(> (car x) 1)) bjb)
bpt (mapcar 'cdr bjb)
pts (reverse (car bpt))
pt (car pts)
bpt (cdr bpt)
n (length bpt)
)
(repeat n
(setq pdbz nil zbb bpt)
(while (= pdbz nil)
(setq ptt (car zbb)
zbb (cdr zbb)
p1 (car ptt)
p2 (cadr ptt)
)
(if (equal pt p1 1e-6)
(setq pt p2
pts (cons pt pts)
pdbz ptt
)
(if (equal pt p2 1e-6)
(setq pt p1
pts (cons pt pts)
pdbz ptt
)
)
)
)
(if pdbz (setq bpt (vl-remove pdbz bpt)))
)
(setq pts (cdr pts))
(command "_pline")
(foreach pt pts
(command pt)
)
(command "c")
)
)
(command "_undo" "e")
(setvar "osmode" os)
(setvar "cmdecho" cm)
(princ)
)

(defun c:sjwbj() 
     (defun bjjc(Xbhb Xp1 Xp2 / pdbz i n pt1 pt2 ptb) 
         (if (= Xbhb nil) 
             (setq Xbhb (cons (list 1 Xp1 Xp2) Xbhb)) 
             (progn 
                 (setq pdbz nil  i 0  n (length Xbhb)) 
                 (while (
                      (setq ptb (nth i Xbhb) 
                            pt1  (cadr  ptb) 
                            pt2  (caddr ptb) 
                      ) 
                      (if (or (and (equal Xp1 pt1 1e-6) (equal Xp2 pt2 1e-6)) 
                              (and (equal Xp1 pt2 1e-6) (equal Xp2 pt1 1e-6)) 
                          ) 
                          (setq pdbz ptb  i n) 
                     ) 
                     (setq i (1+ i)) 
                 ) 
                 (if (= pdbz nil) 
                     (setq Xbhb (cons (list 1 Xp1 Xp2) Xbhb)) 
                     (setq Xbhb (subst (subst (1+ (car pdbz)) (car pdbz) pdbz) pdbz Xbhb)) 
                 ) 
             ) 
         ) 
         (setq Xbhb Xbhb) 
     ) 
   
     (vl-load-com) 
     (setq cm (getvar "cmdecho") 
           os (getvar "osmode") 
     ) 
     (setvar "cmdecho" 0) 
     (setvar "osmode" 0) 
     (command "_undo" "be") 
 
     (if (setq ssa (ssget '((0 . "POLYLINE") (8 . "SJW") (66 . 1)))) 
         (progn 
             (setq bjb nil 
                   tymb (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssa))) 
             ) 
             (foreach ent tymb 
                  (setq obj (vlax-ename->vla-object ent) 
                        pts (vlax-get obj "Coordinates") 
                        p1  (list (car pts) (cadr pts) (caddr pts)) 
                        pts (cdr (cdr (cdr pts))) 
                        p2  (list (car pts) (cadr pts) (caddr pts)) 
                        p3  (cdr (cdr (cdr pts))) 
                        bjb (bjjc bjb p1 p2) 
                        bjb (bjjc bjb p2 p3) 
                        bjb (bjjc bjb p3 p1) 
                  )        
             ) 
             (setq bjb (vl-remove-if '(lambda(x)(> (car x) 1)) bjb) 
                   bpt (mapcar 'cdr bjb) 
                   pts (reverse (car bpt)) 
                   pt  (car pts) 
                   bpt (cdr bpt) 
                   n   (length bpt) 
             ) 
             (repeat n 
                  (setq pdbz nil  zbb bpt) 
                  (while (= pdbz nil) 
                      (setq ptt (car zbb) 
                            zbb (cdr zbb) 
                            p1  (car ptt) 
                            p2  (cadr ptt) 
                      ) 
                      (if (equal pt p1 1e-6) 
                          (setq pt p2 
                                pts (cons pt pts) 
                                pdbz ptt 
                          ) 
                          (if (equal pt p2 1e-6) 
                              (setq pt p1 
                                    pts (cons pt pts) 
                                    pdbz ptt 
                              ) 
                          ) 
                      ) 
                  ) 
                  (if pdbz (setq bpt (vl-remove pdbz bpt))) 
             ) 
             (setq pts (cdr pts)) 
             (command "_pline") 
             (foreach pt pts 
                 (command pt) 
             ) 
             (command "c") 
         ) 
     ) 
 
     (command "_undo" "e") 
     (setvar "osmode" os) 
     (setvar "cmdecho" cm) 
     (princ) 
)

csharp · 发表于 2015-1-10 17:09:19

画一个大的矩形然后用 bpoly 点一个点生成，然后删除矩形

newer · 发表于 2015-1-10 19:53:16

很简单的一行主要代码就搞定了。

;|
生成选择集的边界
|;
(defun c:tt()
(if (and (xdrx_prompt "\n选取要生成边界的实体<退出>:")
(setq ss (ssget))
(xdrx_geom_searchoutline ss 0)
)
(princ "\n边界创建成功。")
)
(princ)
)

lizhgang.jin · 发表于 2015-1-10 21:11:39

本帖最后由 lizhgang.jin 于 2015-1-10 21:13 编辑

newer 发表于 2015-1-10 19:53
很简单的一行主要代码就搞定了。

晓东开源通用LISP函数库1108下载
老师上面这个东西我这个级别的人下载不了，是不是非要这个才能用你那个程序，你能否编个不需要加载晓东的LSP,直接加载就能用的，谢谢，您的程序演示效果达到了我的需求，可是我用不了，暂时

lizhgang.jin · 发表于 2015-1-10 21:19:25

csharp 发表于 2015-1-10 17:09
画一个大的矩形然后用 bpoly 点一个点生成，然后删除矩形

老师方法不可行，地形图三角网是三维的，不是平面的哟。你可以下载附件研究一下了，谢谢！

newer · 发表于 2015-1-10 21:20:21

lizhgang.jin 发表于 2015-1-10 21:11
晓东开源通用LISP函数库1108下载
老师上面这个东西我这个级别的人下载不了，是不是非要这个才能用你那个 ...

上面的程序不需要通用LISP函数库，你只需下载XDRX API加载即可。

lizhgang.jin · 发表于 2015-1-11 09:26:42

dnbcgrass 发表于 2015-1-11 00:15
请试用以下程序:

程序不错，直接复制改lsp使用，能用。

csharp · 发表于 2015-1-11 11:46:28

lizhgang.jin 发表于 2015-1-10 21:19
老师方法不可行，地形图三角网是三维的，不是平面的哟。你可以下载附件研究一下了，谢谢！

不用写程序可以这样，用复制的副本消除 Z 值，然后画矩形再 BO，删除没用的留下边界

zml84 · 发表于 2018-10-2 16:41:36

[Actionscript3] 纯文本查看 复制代码

(vl-load-com)
(defun c:tt (/ lst_pt bjjc ss lst_en en obj pts p1 p2 p3 tmp)
  ;;========================
  ;;边界表
  (setq lst_pt '())

  ;;========================
  ;;定义函数，边界检查。
  (defun bjjc (Xp1 Xp2 / n0 n1 tmp)
    (if	lst_pt
      (progn
	(setq n0  (length lst_pt)
	      tmp (vl-remove-if
		    (function (lambda (x)
				(or (equal x (list Xp2 Xp1) 1e-6)
				    (equal x (list Xp1 Xp2) 1e-6)
				)
			      )
		    )
		    lst_pt
		  )
	      n1  (length tmp)
	)
	(if (= n0 n1)
	  (setq lst_pt (cons (list Xp1 Xp2) lst_pt))
	  (setq lst_pt tmp)
	)
      )
      (setq lst_pt (list (list Xp1 Xp2)))
    )
  )

  ;;========================
  (if (setq ss (ssget '((0 . "POLYLINE") (8 . "SJW") (66 . 1))))
    (progn
      ;;第一步，获取线段表
      (setq lst_en (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
      )
      (foreach en lst_en
	(setq obj (vlax-ename->vla-object en)
	      pts (vlax-get obj "Coordinates")
	      p1  (list (car pts) (cadr pts) (caddr pts))
	      pts (cdr (cdr (cdr pts)))
	      p2  (list (car pts) (cadr pts) (caddr pts))
	      p3  (cdr (cdr (cdr pts)))
	)
	(bjjc p1 p2)
	(bjjc p2 p3)
	(bjjc p3 p1)
      )
      ;;第二步，逐段绘制
      (command "_undo" "be")
      (foreach tmp lst_pt
	(entmake (list '(0 . "LINE")
		       '(8 . "0")
		       (cons 10 (car tmp))
		       (cons 11 (cadr tmp))
		 )
	)
      )
      (command "_undo" "e")
    )
  )

  ;;========================
  ;;静默退出
  (princ)
)

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

[已解决] 求根据图上三角网自动生成范围线程序。

最佳答案

相关帖子

点评

评分

点评

点评

点评

点评