程序求助

newer · 发表于 2013-11-4 08:32:32

hphkjz 发表于 2013-11-4 02:03
我看了看不是标注样式的，好像就是直接在直线上写的单行文字

(command "text" "j" "bc" pt "" (* (/ ang pi) 180) (strcat ""
                                                              (rtos dd 2)
                                                      ) ""
    )

上面这部分代码是写文字的，变量PT是位置的点，你往上面找，看看给PT赋值的地方，自己尝试修改修改。

hphkjz · 发表于 2013-11-9 08:41:52

newer 发表于 2013-11-4 08:32
上面这部分代码是写文字的，变量PT是位置的点，你往上面找，看看给PT赋值的地方，自己尝试修改修改。

没找到啊，是这样的，结构图标注文字和线齐平，建筑图就跑偏了。所以很郁闷。

st788796 · 发表于 2013-11-9 09:47:54

hphkjz 发表于 2013-11-9 08:41
没找到啊，是这样的，结构图标注文字和线齐平，建筑图就跑偏了。所以很郁闷。

有时候和字体有关，字体的基点不同，你修改下字体样式中的字体

hphkjz · 发表于 2013-11-9 12:18:32

st788796 发表于 2013-11-9 09:47
有时候和字体有关，字体的基点不同，你修改下字体样式中的字体

果然，确实跟字体有关。谢谢兄弟啊！哈哈，真好。
兄弟，还是这个代码，能不能修改一下，能让真正的长度都减去60。我画的是钢筋，这样好减去保护层。

st788796 · 发表于 2013-11-9 13:58:33

hphkjz 发表于 2013-11-9 12:18
果然，确实跟字体有关。谢谢兄弟啊！哈哈，真好。
兄弟，还是这个代码，能不能修改一下，能让真正的长度 ...

(rtos dd 2)
->
(rtos (- dd 60) 2)

hphkjz · 发表于 2013-11-9 14:26:26

st788796 发表于 2013-11-9 13:58
(rtos dd 2)
->
(rtos (- dd 60) 2)

原来如此，多谢

hphkjz · 发表于 2013-11-14 06:11:03

hphkjz 发表于 2013-11-9 14:26
原来如此，多谢

仁兄能帮忙给看个代码好吗。这是个图形切割的代码，里面有bug，不知道怎么改。运行时显示 no function definition: XDRX_ENTSEL
源代码是:

(defun c:XDTB_ClipDwg (/ box el e2 entl n pt pts ss ss1)
(if (and
(setq e1 (car (xdrx_entsel "\n拾取封闭的多段线<退出>:" (list (cons 0 "*POLYLINE") '(-4 . "&=") '(70 . 1)))))
(progn
(redraw e1 3)
t
)
(or
(setq pt (getpoint "\n点取裁剪区域<拾取线外多段线>:"))
(setq e2 (car (xdrx_entsel "\n拾取线外封闭多段线确定裁剪区域<退出>:" (list (cons 0 "*POLYLINE") '(-4 . "&=") '
(70 . 1)
)
)
)
)
)
)
(progn
(XD::Begin)
(xdrx_document_ucson)
(xdrx_sysvar_push '("cmdecho" 0))
(setq pts (xdrx_getsamplept e1)
ss2 (ssget "cp" pts)
)
(if pt
(progn
(if (XD::Pnt:isInSide pt pts)
(progn
(ssdel e1 ss2)
(if (setq ss3 (ssget "wp" pts))
(command ".erase" ss3 "")
)
(xdrx_pickset_clipbypoly ss2 e1)
(xdrx_object_regen e1)
)
(progn
(setq ss1 (ssget "x")
ss (xdrx_pickset_subtract ss1 ss2)
)
(command ".erase" ss "")
(setq box (xd::entity:box ss2))
(apply
'xdrx_polyline_make
(cons t (XD::Pnts:UCS2WCS box))
)
(setq e2 (entlast))
)
)
)
)
(if e2
(progn
(setq el (XD::Geom:PathIsland e1 e2)
entl (XD::SS:Ents ss2)
)
(foreach n el
(ssdel e2 ss2)
(setq ss2 (xdrx_pickset_clipbypoly ss2 n))
(setq entl (append
(XD::SS:Ents ss2)
entl
)
)
(setq ss2 (XD::Entity->PickSet entl))
(entdel n)
)
(entdel e1)
)
)
(if (and
pt
e2
)
(entdel e2)
)
)
)
(xdrx_sysvar_pop)
(XD::End)
(princ)
)

(defun c:XDTB_ClipDwg (/ box el e2 entl n pt pts ss ss1) 
  (if (and 
        (setq e1 (car (xdrx_entsel "\n拾取封闭的多段线<退出>:" (list (cons 0 "*POLYLINE") '(-4 . "&=") '(70 . 1))))) 
        (progn 
          (redraw e1 3) 
          t 
        ) 
        (or 
          (setq pt (getpoint "\n点取裁剪区域<拾取线外多段线>:")) 
          (setq e2 (car (xdrx_entsel "\n拾取线外封闭多段线确定裁剪区域<退出>:" (list (cons 0 "*POLYLINE") '(-4 . "&=") ' 
                                                                                     (70 . 1) 
                                                                               ) 
                        ) 
                   ) 
          ) 
        ) 
      ) 
    (progn 
      (XD::Begin) 
      (xdrx_document_ucson) 
      (xdrx_sysvar_push '("cmdecho" 0)) 
      (setq pts (xdrx_getsamplept e1) 
            ss2 (ssget "cp" pts) 
      ) 
      (if pt 
        (progn 
          (if (XD::Pnt:isInSide pt pts) 
            (progn 
              (ssdel e1 ss2) 
              (if (setq ss3 (ssget "wp" pts)) 
                (command ".erase" ss3 "") 
              ) 
              (xdrx_pickset_clipbypoly ss2 e1) 
              (xdrx_object_regen e1) 
            ) 
            (progn 
              (setq ss1 (ssget "x") 
                    ss (xdrx_pickset_subtract ss1 ss2) 
              ) 
              (command ".erase" ss "") 
              (setq box (xd::entity:box ss2)) 
              (apply 
                'xdrx_polyline_make 
                (cons t (XD::Pnts:UCS2WCS box)) 
              ) 
              (setq e2 (entlast)) 
            ) 
          ) 
        ) 
      ) 
      (if e2 
        (progn 
          (setq el (XD::Geom:PathIsland e1 e2) 
                entl (XD::SS:Ents ss2) 
          ) 
          (foreach n el 
            (ssdel e2 ss2) 
            (setq ss2 (xdrx_pickset_clipbypoly ss2 n)) 
            (setq entl (append 
                         (XD::SS:Ents ss2) 
                         entl 
                       ) 
            ) 
            (setq ss2 (XD::Entity->PickSet entl)) 
            (entdel n) 
          ) 
          (entdel e1) 
        ) 
      ) 
      (if (and 
            pt 
            e2 
          ) 
        (entdel e2) 
      ) 
    ) 
  ) 
  (xdrx_sysvar_pop) 
  (XD::End) 
  (princ) 
)

st788796 · 发表于 2013-11-14 06:15:33

hphkjz 发表于 2013-11-14 06:11
仁兄能帮忙给看个代码好吗。这是个图形切割的代码，里面有bug，不知道怎么改。运行时显示 no function de ...

加载相应版本的 xdrxapi 和开源通用lisp函数库，置顶帖子有链接

hphkjz · 发表于 2013-11-18 01:00:14

st788796 发表于 2013-11-14 06:15
加载相应版本的 xdrxapi 和开源通用lisp函数库，置顶帖子有链接

哥好哇，还是那个连续标注的程序能不能再稍微修改一下哇？就是在标注的前面单独显示几个字“长度是”，字高是固定的，还要区别于标注。并且所有的字体都是黑体的。还望哥在代码后面给标注出来哇！
代码去下

(princ "\n程序：连续标注命令：bz ")
(defun c:bz ()
(COMMAND "UCS" "")
(setvar "cmdecho" 1)
(SETVAR "OSMODE" 0)
(setq AcadObject (vlax-get-acad-object)
AcadDocument (vla-get-ActiveDocument Acadobject)
mSpace (vla-get-ModelSpace Acaddocument)
) ; 选取需要测量的样条曲线、圆弧、直线、椭圆
(setq en (ssget (list '(0 . "spline,arc,line,ellipse,LWPOLYLINE"))))
(setq i 0) ; 获取系统参数textsize
(setq shh (getvar "textsize"))
(setq str_hh (strcat "\n文字高度 <" (rtos shh 2) ">: "))
(setq hh (getdist str_hh))
(while hh
(setvar "textsize" hh)
(setq hh nil)
) ; 输入标注文字高度
; 循环开始
(repeat (sslength en)
(setq ss (ssname en i))
(setq endata (entget ss))
(command "lengthen" ss "")
(setq dd (getvar "perimeter"))
(princ (strcat "\n长度=" (rtos dd 2))) ; 寻找代表图层的字符串
(setq aa (assoc 0 endata)) ; 获取图层名称
(setq aa1 (cdr aa)) ; 判断线条种类
(cond
((= aa1 "SPLINE") ; 如果是spline
(progn
(setq arcObj (VLAX-ENAME->VLA-OBJECT ss))
(setq startPnt1 (vla-get-ControlPoints arcObj))
(setq p1 (vlax-safearray->list (vlax-variant-value startPnt1)))
(setq x1 (car p1))
(setq y1 (cadr p1))
(setq z1 (caddr p1))
(setq pp1 (list x1 y1 z1))
(repeat (- (/ (length p1) 3) 1) ; 循环，寻找最后一个控制点
(setq p1 (cdddr p1))
(setq x2 (car p1))
(setq y2 (cadr p1))
(setq z2 (caddr p1))
)
(setq pp2 (list x2 y2 z2))
)
)
((= aa1 "LWPOLYLINE") ; 如果是LWPOLYLINE
(progn
(setq arcObj (VLAX-ENAME->VLA-OBJECT ss))
(setq startPnt1 (vla-get-Coordinates arcObj))
(setq p1 (vlax-safearray->list (vlax-variant-value startPnt1)))
(setq x1 (car p1))
(setq y1 (cadr p1))
(setq z1 (caddr p1))
(setq pp1 (list x1 y1 z1))
(repeat (- (/ (length p1) 3) 1) ; 循环，寻找最后一个控制点
(setq p1 (cdddr p1))
(setq x2 (car p1))
(setq y2 (cadr p1))
(setq z2 (caddr p1))
)
(setq pp2 (list x2 y2 z2))
)
)
(t ; 如果是其他种类线条
(progn
(setq arcObj (VLAX-ENAME->VLA-OBJECT ss))
(setq startPnt1 (vla-get-StartPoint arcObj)) ; 获取起点
(setq endPnt1 (vla-get-EndPoint arcObj)) ; 获取终点
(setq pp1 (vlax-safearray->list (vlax-variant-value startPnt1)))
(setq pp2 (vlax-safearray->list (vlax-variant-value endPnt1)))
)
)
)
(setq x1 (car pp1))
(setq y1 (cadr pp1))
(setq z1 (caddr pp1))
(setq x2 (car pp2))
(setq y2 (cadr pp2))
(setq z2 (caddr pp2))
(setq x (/ (+ x1 x2) 2))
(setq y (/ (+ y1 y2) 2))
(setq z (/ (+ z1 z2) 2))
(setq pt (list x y z)) ; 取得线段两端的中点
(setq ang (angle pp1 pp2)) ; 获取角度
(if (> (* (/ ang pi) 180) 180)
(setq ang (+ ang pi))
)
(command "text" "j" "bc" pt "" (* (/ ang pi) 180) (strcat "" (rtos dd 2 0)) "")
(setq i (1+ i))
)
(prin1)
)

(princ "\n程序：连续标注 命令：bz ") 
(defun c:bz () 
  (COMMAND "UCS" "") 
  (setvar "cmdecho" 1) 
  (SETVAR "OSMODE" 0) 
  (setq AcadObject (vlax-get-acad-object) 
        AcadDocument (vla-get-ActiveDocument Acadobject) 
        mSpace (vla-get-ModelSpace Acaddocument) 
  )                                       ; 选取需要测量的样条曲线、圆弧、直线、椭圆 
  (setq en (ssget (list '(0 . "spline,arc,line,ellipse,LWPOLYLINE")))) 
  (setq i 0)                               ; 获取系统参数textsize 
  (setq shh (getvar "textsize")) 
  (setq str_hh (strcat "\n文字高度 <" (rtos shh 2) ">: ")) 
  (setq hh (getdist str_hh)) 
  (while hh 
    (setvar "textsize" hh) 
    (setq hh nil) 
  )                                       ; 输入标注文字高度 
                                       ; 循环开始 
  (repeat (sslength en) 
    (setq ss (ssname en i)) 
    (setq endata (entget ss)) 
    (command "lengthen" ss "") 
    (setq dd (getvar "perimeter")) 
    (princ (strcat "\n长度=" (rtos dd 2))) ; 寻找代表图层的字符串 
    (setq aa (assoc 0 endata))               ; 获取图层名称 
    (setq aa1 (cdr aa))                       ; 判断线条种类 
    (cond 
      ((= aa1 "SPLINE")                       ; 如果是spline 
        (progn 
          (setq arcObj (VLAX-ENAME->VLA-OBJECT ss)) 
          (setq startPnt1 (vla-get-ControlPoints arcObj)) 
          (setq p1 (vlax-safearray->list (vlax-variant-value startPnt1))) 
          (setq x1 (car p1)) 
          (setq y1 (cadr p1)) 
          (setq z1 (caddr p1)) 
          (setq pp1 (list x1 y1 z1)) 
          (repeat (- (/ (length p1) 3) 1) ; 循环，寻找最后一个控制点 
            (setq p1 (cdddr p1)) 
            (setq x2 (car p1)) 
            (setq y2 (cadr p1)) 
            (setq z2 (caddr p1)) 
          ) 
          (setq pp2 (list x2 y2 z2)) 
        ) 
      ) 
      ((= aa1 "LWPOLYLINE")               ; 如果是LWPOLYLINE 
        (progn 
          (setq arcObj (VLAX-ENAME->VLA-OBJECT ss)) 
          (setq startPnt1 (vla-get-Coordinates arcObj)) 
          (setq p1 (vlax-safearray->list (vlax-variant-value startPnt1))) 
          (setq x1 (car p1)) 
          (setq y1 (cadr p1)) 
          (setq z1 (caddr p1)) 
          (setq pp1 (list x1 y1 z1)) 
          (repeat (- (/ (length p1) 3) 1) ; 循环，寻找最后一个控制点 
            (setq p1 (cdddr p1)) 
            (setq x2 (car p1)) 
            (setq y2 (cadr p1)) 
            (setq z2 (caddr p1)) 
          ) 
          (setq pp2 (list x2 y2 z2)) 
        ) 
      ) 
      (t                               ; 如果是其他种类线条 
        (progn 
          (setq arcObj (VLAX-ENAME->VLA-OBJECT ss)) 
          (setq startPnt1 (vla-get-StartPoint arcObj)) ; 获取起点 
          (setq endPnt1 (vla-get-EndPoint arcObj)) ; 获取终点 
          (setq pp1 (vlax-safearray->list (vlax-variant-value startPnt1))) 
          (setq pp2 (vlax-safearray->list (vlax-variant-value endPnt1))) 
        ) 
      ) 
    ) 
    (setq x1 (car pp1)) 
    (setq y1 (cadr pp1)) 
    (setq z1 (caddr pp1)) 
    (setq x2 (car pp2)) 
    (setq y2 (cadr pp2)) 
    (setq z2 (caddr pp2)) 
    (setq x (/ (+ x1 x2) 2)) 
    (setq y (/ (+ y1 y2) 2)) 
    (setq z (/ (+ z1 z2) 2)) 
    (setq pt (list x y z))               ; 取得线段两端的中点 
    (setq ang (angle pp1 pp2))               ; 获取角度 
    (if (> (* (/ ang pi) 180) 180) 
      (setq ang (+ ang pi)) 
    ) 
    (command "text" "j" "bc" pt "" (* (/ ang pi) 180) (strcat "" (rtos dd 2 0)) "") 
    (setq i (1+ i)) 
  ) 
  (prin1) 
)

st788796 · 发表于 2013-11-18 05:50:02

(strcat "" (rtos dd 2 0))
->
(strcat "长度是" (rtos dd 2 0))

字体，字高在用程序之前自己定义好并设为当前

程序写的太没效率了

hphkjz · 发表于 2013-11-18 06:35:03

st788796 发表于 2013-11-18 05:50
(strcat "" (rtos dd 2 0))
->
(strcat "长度是" (rtos dd 2 0))

嗯，好的，敢问哥是从事什么职业的呀？

st788796 · 发表于 2013-11-18 06:46:08

hphkjz 发表于 2013-11-18 06:35
嗯，好的，敢问哥是从事什么职业的呀？

城市规划

st788796 · 发表于 2013-11-18 07:05:57

hphkjz 发表于 2013-11-18 06:35
嗯，好的，敢问哥是从事什么职业的呀？

就是标一个总长度吗

(defun c:tt (/ ss zh)
(if
(and (setq ss (ssget '((0 . "*line,arc,ellipse"))))
(progn
(if (= (setq
zh (getstring (strcat "\n字高<"
(rtos (getvar "textsize") 2 2)
">: "
)
)
)
""
)
(setq zh (getvar "textsize"))
(setvar "textsize" (distof zh))
)
(setq zh (getvar "textsize"))
)
)
(mapcar '(lambda (x / d pmid an txt)
(setq d (xdrx_curve_getdistatpoint x (xdrx_curve_getendpoint x))
pmid (cadr (xdrx_curve_getpoint x))
an (XD::Geom:AngleFormat
(angle '(0. 0. 0.)
(xdrx_curve_getfirstderiv
x
(xdrx_curve_getparamatpoint x pmid)
)
)
)
txt (xdrx_text_make
pmid
(strcat "长度是" (rtos d))
zh
an
)
)
(xdrx_text_setvermode txt 2)
(xdrx_text_sethozmode txt 1)
)
(xdrx_pickset->ents ss)
)
)
(princ)
)

(defun c:tt (/ ss zh) 
  (if 
    (and (setq ss (ssget '((0 . "*line,arc,ellipse")))) 
         (progn 
           (if (= (setq 
                    zh (getstring (strcat "\n字高<" 
                                          (rtos (getvar "textsize") 2 2) 
                                          ">: " 
                                  ) 
                       ) 
                  ) 
                  "" 
               ) 
             (setq zh (getvar "textsize")) 
             (setvar "textsize" (distof zh)) 
           ) 
           (setq zh (getvar "textsize")) 
         ) 
    ) 
     (mapcar '(lambda (x / d pmid an txt) 
                (setq d           (xdrx_curve_getdistatpoint x (xdrx_curve_getendpoint x)) 
                      pmid (cadr (xdrx_curve_getpoint x)) 
                      an   (XD::Geom:AngleFormat 
                             (angle '(0. 0. 0.) 
                                    (xdrx_curve_getfirstderiv 
                                      x 
                                      (xdrx_curve_getparamatpoint x pmid) 
                                    ) 
                             ) 
                           ) 
                      txt  (xdrx_text_make 
                             pmid 
                             (strcat "长度是" (rtos d)) 
                             zh 
                             an 
                           ) 
                ) 
                (xdrx_text_setvermode txt 2) 
                (xdrx_text_sethozmode txt 1) 
              ) 
             (xdrx_pickset->ents ss) 
     ) 
  ) 
  (princ) 
)

hphkjz · 发表于 2013-11-18 07:09:02

st788796 发表于 2013-11-18 05:50
(strcat "" (rtos dd 2 0))
->
(strcat "长度是" (rtos dd 2 0))

加上那几个字运行时出现了bug，提示错误:no function definition:VLAX-GET-ACAD-OBJECT

st788796 · 发表于 2013-11-18 07:11:00

hphkjz 发表于 2013-11-18 07:09
加上那几个字运行时出现了bug，提示错误:no function definition:VLAX-GET-ACAD-OBJECT

(vl-load-com)

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

[求助] 程序求助

点评

点评

点评

点评

点评

点评

点评

点评

点评

点评

点评

点评

点评