本帖最后由 mandala 于 2011-4-11 00:12 编辑
写了一个画宗地图的lsp，运行结果基本还是比较满意的。但发现在有些情况下，程序的运行会不正确，如附图中的几种情况。
在附图中的四条多段线，运行程序后分别会出现一种错误。
请各位大佬帮忙看看，原因何在，以及该如何改进呢？先谢谢了。
这是正常情况下程序make运行后的效果图：
这是正常情况下make1运行后的效果：
 - ;;两种方式制作宗地图。
- ;;第一种方式make：
- ;;指定一条闭合的pline，指定起点，
- ;;程序会自动顺向标注界址点号、界址尺寸，加粗界址线、圈上界址点、输出界址点坐标（idout），并算出宗地面积。
- ;;程序中用到了本单位系统专用的几个层名，在上传时已屏蔽掉相关语句，用户可正常使用。
- (defun c:make (/ *error* os zin lay ltp pl
- startpoint mj j plst ll plename
- p plast pnext pt1 pt2 pt3 p4
- n ss1 jzx jzxename jzxout
- jzxoutename d l dist m angle1
- angle2 start end col
- )
- (defun *error* (msg)
- (prompt "\n没搞定")
- (print msg)
- (setvar "DIMZIN" zin)
- (setvar "OSMODE" os)
- (setvar "clayer" lay)
- (setvar "celtype" ltp)
- (setvar "cecolor" col)
- (redraw pl 4)
- (command "._UNDO" "E")
- (prompt "\n可以用Undo命令返回起始状态。")
- ) ;_ 结束defun
- ;;变量设置：
- (setvar "CMDECHO" 0)
- (command "._UNDO" "BE")
- (setq os (getvar "OSMODE")
- zin (getvar "DIMZIN")
- ) ;_ 结束SETQ
- (setq lay (getvar "clayer"))
- (setq ltp (getvar "celtype"))
- (setq col (getvar "cecolor"))
- (setvar "DIMZIN" 0)
- (setvar "celtype" "continuous")
- (setvar "cecolor" "bylayer")
- (princ "\n请选择已封闭的pline界址线: ")
- (setq pl (car (entsel)))
- (redraw pl 3)
- (command "_.area" "o" pl)
- (setq mj (getvar "area"))
- (setq plename (vlax-ename->vla-object pl))
- (while (or (= pl nil)
- (/= (cdr (assoc 0 (entget pl))) "LWPOLYLINE")
- (= mj 0)
- (and (= (vlax-curve-isclosed plename) nil)
- (= (equal (vlax-curve-getstartpoint plename)
- (vlax-curve-getendpoint plename)
- ) ;_ 结束equal
- nil) ;_ 结束=
- ) ;_ 结束and
- ) ;_ 结束or
- ;;所点中的东西，不可以为空、必须为pline、不可以为一直线、不可以为开口的pline。
- (princ "\n你点错了……拜托请选择一条封闭的pline: ")
- (redraw pl 4)
- (setq pl (car (entsel)))
- (redraw pl 3)
- (command "_.area" "o" pl)
- (setq mj (getvar "area"))
- (setq plename (vlax-ename->vla-object pl))
- ) ;_ 结束while
- (if (= (fangxiang pl) 0)
- (reverselwp pl)
- ) ;_ 结束if
- (setq startpoint (getpoint "\n请指定界址线1号点的位置："))
- (while (= (equal startpoint
- (vlax-curve-getclosestpointto
- (vlax-ename->vla-object pl)
- startpoint
- ) ;_ 结束vlax-curve-getClosestPointTo
- 0.001
- ) ;_ 结束equal
- nil
- ) ;_ 结束=
- (setq startpoint
- (getpoint "\n你指定的点不在线上……请重新指定1号点的位置：")
- ) ;_ 结束setq
- ) ;_ 结束while
- (setvar "OSMODE" 0)
- (redraw pl 4)
- (setq ent (plchangestart pl startpoint))
- (setq j 0
- plst (list)
- ) ;_ 结束setq
- (repeat (length ent)
- (if (= (car (nth j ent)) 10)
- (setq plst (append plst (list (cdr (nth j ent)))))
- ) ;_ 结束IF
- (setq j (1+ j))
- ) ;_ 结束REPEAT
- (pointout plst)
- ;;将界址点坐标输出到idout.dat
- ;;以下开始标注点号：
- (setq j 0
- ll (length plst)
- ) ;_ 结束SETQ
- (setq plename (vlax-ename->vla-object pl))
- (repeat ll
- (setq p (nth j plst))
- (if (= j 0)
- (setq plast (nth (- ll 1) plst))
- (setq plast (nth (- j 1) plst))
- ) ;_ 结束if
- (if (= j (- ll 1))
- (setq pnext (nth 0 plst))
- (setq pnext (nth (1+ j) plst))
- ) ;_ 结束if
- ;;确定上一点和下一点的位置，以求得角平分线
- (setq pt1 (polar p (angle p plast) 1))
- (setq pt2 (polar p (angle p pnext) 1))
- (setq
- pt3 (polar pt1 (angle pt1 pt2) (* 0.5 (distance pt1 pt2)))
- ) ;_ 结束setq
- ;;以这种方式来求得角平分线，得到点位用以标注点号。
- ;;这样点号的位置会比较美观
- (setq p4 (polar p (angle pt3 p) 2))
- ; (setvar "clayer" "jzd")
- (command "._circle" p "0.4")
- ; (setvar "clayer" "jzdh")
- (setq n (rtos (1+ j) 2 0))
- (command "._text" "j" "m" p4 "1.5" "0" n)
- (setq j (1+ j))
- ) ;_ 结束REPEAT
- ;;标注点号结束，接下来开始处理jzxout：
- (command "_.explode" pl)
- (setq ss1 (ssget "P")
- n 0
- ) ;_ 结束setq
- (repeat ll
- (setq jzx (ssname ss1 n))
- (setq jzxename (vlax-ename->vla-object jzx))
- (vla-offset jzxename 0.1)
- (setq jzxout (entlast))
- (command "_.chprop" jzxout "" "la" "jzxout" "")
- (setq jzxout (entlast))
- (setq jzxoutename (vlax-ename->vla-object jzxout))
- (vla-offset jzxoutename -0.1)
- (entdel jzxout)
- (setq jzxout (entlast))
- (if (= (cdr (assoc 0 (entget jzxout))) "ARC")
- (setq d -2.5)
- (setq d 2.5)
- ) ;_ 结束if，该段为下面标注距离时的注记位置做准备。在宗地图里，绝大多数圆弧需要的d是负的。
- (command "_.pedit" jzxout "y" "w" "0.3" "")
- (setq jzxout (entlast))
- ;;以上偏移了每段jzx，变成jzxout后偏移回原位，变粗，得到对应的图元jzxout。
- (setq jzxoutename (vlax-ename->vla-object jzxout))
- (setq l (vlax-curve-getdistatpoint
- jzxoutename
- (vlax-curve-getendpoint jzxoutename)
- ) ;_ 结束vlax-curve-getDistAtPoint
- ) ;_ 结束setq
- ;;l为线长
- (setq dist (rtos (/ l 2) 2 2))
- (setq m (vlax-curve-getpointatdist jzxoutename (/ l 2)))
- ;;m为中点
- (setq angle1 (angle (vlax-curve-getstartpoint jzxoutename)
- (vlax-curve-getendpoint jzxoutename)
- ) ;_ 结束angle
- ) ;_ 结束setq
- ;;angle1为距离注记的旋转弧度
- (setq angle2 (/ (* angle1 180) pi))
- ;;angle2为注记旋转的角度,在某些情况下注记的旋转角度需要反转
- (if (and (> angle2 90) (< angle2 270))
- (setq angle2 (+ angle2 180))
- ) ;_ 结束if
- ;;以下的if分别考虑线长小于0.8和大于0.8两种情况下，jzxout的处理。
- ;;为了留出界址点位置，jzxout小于0.8，删除；大于0.8，截短。
- (if (<= l 0.8)
- (entdel jzxout)
- (progn (setq start (vlax-curve-getstartpoint jzxoutename))
- (setq end (vlax-curve-getendpoint jzxoutename))
- (command "_.lengthen"
- "de"
- "-0.4"
- (list jzxout start)
- (list jzxout end)
- ""
- ) ;_ 结束command
- ) ;_ 结束progn
- ) ;_ 结束if
- ; (setvar "clayer" "jzxl")
- (command "._text"
- "j"
- "m"
- (polar m (+ angle1 (/ pi 2)) d)
- "2"
- angle2
- dist
- ) ;_ 结束command
- ;;标注距离
- (setq n (1+ n))
- ) ;_ 结束REPEAT
- (setvar "OSMODE" os)
- (setvar "clayer" lay)
- (setvar "celtype" ltp)
- (setvar "DIMZIN" zin)
- (setvar "cecolor" col)
- (command "._UNDO" "E")
- (prompt "\n搞定！")
- (prompt "\n该区域面积 = ")
- (princ (rtos mj 2 4))
- (prompt " ")
- (prompt "如果当前比例尺为1:500，那么实际面积= ")
- (princ (rtos (/ mj 4) 2 4))
- (princ)
- ) ;_ 结束DEFUN make
- ;;;;;;;;;;;;;;;;
- ;;另一种方式制作宗地图。
- ;;界址点不是默认全选，而是由用户来逐一指定。
- ;;也就是说，碰到一宗地的某段界址线形状复杂、点数较多、需要精简时，
- ;;可以用make1这种指定界址点的方式来跳开不需要的界址点。
- ;;例如，做耕地垦造的图纸时，往往会碰到一条界址线是河滩。
- (defun c:make1 ( / *error* os zin lay ltp col
- pl mj plename srartpoint ent
- plst pxlst j nextpoint jzxout n
- psc1 ll p plast pnext pt1 pt2
- pt3 pt4 px1 px2 lx dist m
- angle1 angle2 jzxoutx
- )
- (defun *error* (msg)
- (prompt "\n没搞定")
- (print msg)
- (setvar "DIMZIN" zin)
- (setvar "OSMODE" os)
- (setvar "clayer" lay)
- (setvar "celtype" ltp)
- (setvar "cecolor" col)
- (redraw pl 4)
- (command "._UNDO" "E")
- (prompt "\n可以用Undo命令返回起始状态。")
- ) ;_ 结束defun
- (setvar "CMDECHO" 0)
- (command "._UNDO" "BE")
- (setq os (getvar "OSMODE")
- zin (getvar "DIMZIN")
- ) ;_ 结束SETQ
- (setq lay (getvar "clayer"))
- (setq ltp (getvar "celtype"))
- (setq col (getvar "cecolor"))
- (setvar "DIMZIN" 0)
- (setvar "celtype" "continuous")
- (setvar "cecolor" "bylayer")
- (princ "\n请选择一条已封闭的pline界址线: ")
- (setq pl (car (entsel)))
- (redraw pl 3)
- (command "_.area" "o" pl)
- (setq mj (getvar "area"))
- (setq plename (vlax-ename->vla-object pl))
- (while (or (= pl nil)
- (/= (cdr (assoc 0 (entget pl))) "LWPOLYLINE")
- (= mj 0)
- (and (= (vlax-curve-isclosed plename) nil)
- (= (equal (vlax-curve-getstartpoint plename)
- (vlax-curve-getendpoint plename)
- ) ;_ 结束equal
- nil
- ) ;_ 结束=
- ) ;_ 结束and
- ) ;_ 结束or
- ;;所点中的东西，不可以为空、必须为pline、不可以为一直线、不可以为开口的pline。
- (princ "\n你点错了……拜托请选择一条封闭的pline: ")
- (redraw pl 4)
- (setq pl (car (entsel)))
- (redraw pl 3)
- (command "_.area" "o" pl)
- (setq mj (getvar "area"))
- (setq plename (vlax-ename->vla-object pl))
- ) ;_ 结束while
- (setq mj (getvar "area"))
- (if (= (fangxiang pl) 0)
- (reverselwp pl)
- ) ;_ 结束if
- (setq startpoint (getpoint "\n请指定界址线1号点的位置："))
- (while (= (equal startpoint
- (vlax-curve-getclosestpointto
- (vlax-ename->vla-object pl)
- startpoint
- ) ;_ 结束vlax-curve-getClosestPointTo
- 0.001
- ) ;_ 结束equal
- nil
- ) ;_ 结束=
- (setq startpoint
- (getpoint
- "\n你指定的点不在线上……请重新指定1号点的位置："
- ) ;_ 结束getpoint
- ) ;_ 结束setq
- ) ;_ 结束while
- (redraw pl 4)
- (setq ent (plchangestart pl startpoint))
- (setq j 0
- plst (list)
- pxlst (list)
- pxlst (append (list startpoint))
- ) ;_ 结束setq
- (repeat (length ent)
- (if (= (car (nth j ent)) 10)
- (setq plst (append plst (list (cdr (nth j ent)))))
- ) ;_ 结束IF
- (setq j (1+ j))
- ) ;_ 结束REPEAT,得到所有顶点的列表plst。
- ;;;;;;;;;;;
- (while (setq nextpoint (getpoint "\n请指定下一点的位置："))
- (while (= (equal nextpoint
- (vlax-curve-getclosestpointto
- (vlax-ename->vla-object pl)
- nextpoint
- ) ;_ 结束vlax-curve-getClosestPointTo
- 0.001
- ) ;_ 结束equal
- nil
- ) ;_ 结束=
- (setq
- nextpoint (getpoint
- "\n你指定的点不在线上……请重新指定下一点的位置："
- ) ;_ 结束getpoint
- ) ;_ 结束setq
- ) ;_ 结束while
- (setq pxlst (append pxlst (list nextpoint)))
- );结束while,定点结束，得到所有选定点的列表pxlst。
- ;;开始处理jzxout：
- (setvar "OSMODE" 0)
- (setq plename (vlax-ename->vla-object pl))
- (vla-offset plename 0.1)
- (setq jzxout (entlast))
- (command "_.chprop" jzxout "" "la" "jzxout" "")
- (setq jzxout (entlast))
- (vla-offset (vlax-ename->vla-object jzxout) -0.1)
- (entdel jzxout)
- (setq jzxout (entlast))
- (command "_.pedit" jzxout "w" "0.3" "")
- ;;将jzx平移，加粗，变为jzxout之后平移回去。
- ;;然后开始圈界址点，并裁剪掉圈内的jzxout。
- (setq n (- (length pxlst) 1))
- (repeat (length pxlst)
- (setq ps (nth n pxlst))
- ; (setvar "clayer" "jzd")
- (command "._circle" ps "0.4")
- (setq c1 (entlast))
- (command "._trim" c1 "" (list jzxout ps) "")
- (setq n (- n 1))
- );repeat,
- ;;trim了界址点内之后，图元名jzxout变为该界址点之前的那段jzxout，所以要从最后一点trim起。
- ;;开始标注点号和距离。考虑到今后可能有其它运用，所以没有和以上的repeat并到一起去。
- (setq j 0
- ll (length plst)
- ) ;_ 结束SETQ
- (repeat (length pxlst)
- (setq p (list (car (nth j pxlst)) (cadr (nth j pxlst))))
- (setq n (- (length (member p (reverse plst))) 1))
- ;;p为选定点，n为点p在所有顶点列表中的序号
- (if (= n 0)
- (setq plast (nth (- ll 1) plst))
- (setq plast (nth (- n 1) plst))
- ) ;_ 结束if
- (if (= n (- ll 1))
- (setq pnext (nth 0 plst))
- (setq pnext (nth (1+ n) plst))
- ) ;_ 结束if
- ;;确定点p的上一点和下一点的位置，以求得角平分线
- (setq pt1 (polar p (angle p plast) 1))
- (setq pt2 (polar p (angle p pnext) 1))
- (setq pt3 (polar pt1 (angle pt1 pt2) (* 0.5 (distance pt1 pt2)))) ;_ 结束setq
- ;;以这种方式来求得角平分线，得到点位用以标注点号。
- ;;这样点号的位置会比较美观
- (setq pt4 (polar p (angle pt3 p) 2))
- ; (setvar "clayer" "jzdh")
- (setq nn (rtos (1+ j) 2 0))
- (command "._text" "j" "m" pt4 "1.5" "0" nn)
- ;;标注点号结束
- (setq px1 (nth j pxlst)
- px2 (nth (1+ j) pxlst)
- ) ;_ 结束setq
- ;;px1为p的三维点形式，px2为p在pxlst中的下一点
- (if (= j (- (length pxlst) 1))
- (setq lx (/ (- (getvar "PERIMETER") (vlax-curve-getDistAtPoint plename px1)) 2))
- (setq lx (/ (- (vlax-curve-getDistAtPoint plename px2)
- (vlax-curve-getDistAtPoint plename px1)
- ) ;_ 结束-
- 2
- ) ;_ 结束/
- ) ;_ 结束setq
- ) ;_ 结束if
- ;;lx为每段的长度，即px1到px2的jzx线上距离。最后一段距离的计算方法与众不同。
- (setq dist (rtos lx 2 2))
- (setq m (vlax-curve-getpointatdist
- plename
- (+ lx (vlax-curve-getDistAtPoint plename px1))
- ) ;_ 结束vlax-curve-getpointatdist
- ) ;_ 结束setq
- ;;m为中点
- (setq angle1 (angle m
- (mapcar '+
- m
- (vlax-curve-getFirstDeriv
- plename
- (vlax-curve-getparamatpoint plename m)
- ) ;_ 结束vlax-curve-getFirstDeriv
- ) ;_ 结束mapcar
- ) ;_ 结束angle
- ) ;_ 结束setq
- ;;angle1为m点所在的jzx的法线角度，即注记的旋转弧度。
- (setq angle2 (/ (* angle1 180) pi))
- ;;angle2为注记旋转的角度,
- (if (and (> angle2 90) (< angle2 270))
- (setq angle2 (+ angle2 180))
- ) ;_ 结束if,在某些情况下注记的旋转角度需要反转
- ; (setvar "clayer" "jzxl")
- (command "._text"
- "j"
- "m"
- (polar m (+ angle1 (/ pi 2)) 2.5)
- "2"
- angle2
- dist
- ) ;_ 结束command
- ;;标注距离结束
- (setq j (1+ j))
- ) ;_ 结束REPEAT ，
- (setvar "OSMODE" os)
- (setvar "clayer" lay)
- (setvar "celtype" ltp)
- (setvar "DIMZIN" zin)
- (setvar "cecolor" col)
- (command "._UNDO" "E")
- (prompt "\n搞定！")
- (prompt "\n该区域面积 = ")
- (princ (rtos mj 2 4))
- (prompt " ")
- (prompt "如果当前比例尺为1:500，那么实际面积= ")
- (princ (rtos (/ mj 4) 2 4))
- (princ)
- ) ;_ 结束DEFUN make1
- ;;;;;;;;;;;;;;;;
- ;;程序make1在设计中使用了一些跟make不同的思路，如jzxout的处理、距离标注角度的确定等等。
- ;;子程序，判断pline方向，返回1为顺时针，0为逆时针
- (defun fangxiang (xx / fd ang offsetplineobj plineobj x fx)
- (setq plineobj (vlax-ename->vla-object xx))
- (setq fd (vlax-curve-getfirstderiv plineobj 0.5))
- (setq ang (atan (/ (cadr fd) (car fd))))
- (setq offsetplineobj
- (car
- (vlax-safearray->list
- (vlax-variant-value (vla-offset plineobj 0.0001)) ;_ 结束vlax-variant-value
- ) ;_ 结束vlax-safearray->list
- ) ;_ 结束car
- ) ;_ 结束setq
- (if (> (vla-get-length plineobj)
- (vla-get-length offsetplineobj)
- ) ;_ 结束>
- (setq x 1)
- (setq x 0)
- ) ;_ 结束if
- (vla-delete offsetplineobj)
- (setq fx x)
- ) ;_ 结束defun
- ;;;子程序：pline顶点逆序
- (defun reverselwp (ent1 / a pl how li1 li2 li3)
- (setq pl (entget ent1 '("*"))
- how nil
- ) ;_ 结束setq
- (foreach an pl
- (if (setq a (member (car an) '(10 40 41 42)))
- (setq how t)
- ) ;_ 结束if
- (cond ((not how) (setq li1 (cons an li1)))
- ((and how a)
- (cond ((= (car an) 40) (setq an (cons 41 (cdr an))))
- ((= (car an) 41) (setq an (cons 40 (cdr an))))
- ((= (car an) 42) (setq an (cons 42 (- 0 (cdr an)))))
- (t an)
- ) ;_ 结束cond
- (setq li2 (cons an li2))
- )
- ((and how (not a)) (setq li3 (cons an li3)))
- ) ;_ 结束cond
- ) ;_ 结束foreach
- (entmod
- (append (reverse li1)
- (append (cdddr li2) (list (car li2) (cadr li2) (caddr li2)))
- (reverse li3)
- ) ;_ 结束append
- ) ;_ 结束entmod
- ) ;_ 结束defun
- ;;子程序，修改不闭合的pline使其闭合，并按指定点作为起点重绘pline，
- ;;返回pline的组码。
- (defun plchangestart
- (ee p1 / pt dat ptfrst ename aa data datb dat0 dat1 dat9)
- (setq pt (list (car p1) (cadr p1)))
- (setq dat (entget ee))
- (setq ptfrst (cons 10 pt))
- (setq ename (vlax-ename->vla-object ee))
- (if (vlax-curve-isclosed ename)
- (setq dat dat)
- (progn
- (setq dat (subst (cons 70 129) (assoc 70 dat) dat))
- (setq data (list (last dat)))
- (setq datb (reverse (cdr (cdr (cdr (cdr (cdr (reverse dat))))))))
- (setq dat (entmod (append datb data)))
- ) ;_ 结束progn
- ) ;_ 结束if
- ;;以上一段：如果pl最终不是以“c”闭合而是以捕捉端点方式“闭合”，
- ;;则修改组码使其达到闭合效果。
- (setq
- dat0 (reverse (member '(39 . 0.0) (reverse dat)))
- dat1 (cdr (member '(39 . 0.0) dat))
- dat9 (list (last dat1))
- dat1 (reverse (cdr (reverse dat1)))
- data (member ptfrst dat1)
- datb (reverse (cdr (member ptfrst (reverse dat1))))
- ) ;_ 结束setq
- (entmod (append dat0 data datb dat9))
- ;;以上一段：修改组码，使pline从指定点开始。
- ) ;_ 结束defun
- ;;子程序，将界址点号输出到idout.dat
- (defun pointout
- (pointlist / f i point x y point1)
- (setq f (open "idout.dat" "w"))
- (setq i 0)
- (repeat (length pointlist)
- (setq point (nth i pointlist))
- (setq x (/ (car point) 2)
- y (/ (cadr point) 2)
- ) ;_ 结束setq
- (setq x (/ (fix (* x 1e5)) 1e5)
- y (/ (fix (* y 1e5)) 1e5)
- ) ;_ 结束setq
- (princ (strcat (if (= i 0)
- ""
- "\n"
- ) ;_ 结束if
- (itoa (1+ i))
- ","
- (rtos x 2 5)
- ","
- (rtos y 2 5)
- ) ;_ 结束strcat
- f
- ) ;_ 结束princ
- (setq i (1+ i))
- );repeat
- (setq point1 (nth 0 pointlist)
- x (/ (car point1) 2)
- y (/ (cadr point1) 2)
- ) ;_ 结束setq
- (setq x (/ (fix (* x 1e5)) 1e5)
- y (/ (fix (* y 1e5)) 1e5)
- ) ;_ 结束setq
- (princ (strcat "\n" (itoa 1) "," (rtos x 2 5) "," (rtos y 2 5))
- f
- ) ;_ 结束princ
- (close f)
- ) ;_ 结束dufun
| 
[复制链接]
发表于 2011-4-9 15:39:40
置顶卡
变色卡
显身卡
楼主
不错很实用