[编程申请]：请求一个能自动标注所量取距离的小程序

lijinglq · 发表于 2005-11-9 21:29:44

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

我是做市政排水的，有时需要标注管道长度。我想实现以下功能：先点取需修改的文字如“d300-40.5”然后运行测量距离的命令点选起始点（要支持对象捕捉），命令运行完毕以后前面所点选文字中的“40.5”变为所测量的长度，最好保留的小数位可调。在论坛里发现了一个类似的，但是更我的要求还是差一点。请高手们借鉴一下。http://www.xdcad.net/forum/showthre...threadid=406895

yshf · 发表于 2005-11-10 11:05:38

;请试用以下程序
(defun c:etext()
(setq xtblm '("cmdecho" "osmode" "dimzin")
   xtblz (mapcar 'getvar xtblm)
   ws (getint "\n请指定要保留的小数位:")
)
(mapcar 'setvar xtblm '(0 33 0))
(while (setq ent (entsel "\n请选取需修改的文字:"))
   (setq ent (car ent)  db (entget ent))
   (if (wcmatch (cdr (assoc 0 db)) "*TEXT")
   (progn
      (redraw  ent 3)
         (setq zf (cdr (assoc 1 db))
               zf (vl-string-subst
   (rtos (getdist (getpoint "\n请选取起点:") "\n请选取止点:") 2 ws)
                  (substr zf (+ 2 (vl-string-search "-" zf )))
                  zf
      )
            db (subst (cons 1 zf) (assoc 1 db) db)
         )
         (entmod db)
   )
   (alert "所选取的图元不是文字，请重新选取！")
   )

)
(mapcar 'setvar xtblm xtblz)(princ)
)

这样就更可读了

[FONT=courier new]
(defun c:etext ()
(setq xtblm '("cmdecho" "osmode" "dimzin")
xtblz (mapcar 'getvar xtblm)
ws (getint "\n请指定要保留的小数位:")
)
(mapcar 'setvar xtblm '(0 33 0))
(while (setq ent (entsel "\n请选取需修改的文字:"))
(setq ent (car ent)
db (entget ent)
)
(if (wcmatch (cdr (assoc 0 db)) "*TEXT")
(progn
(redraw ent 3)
(setq zf (cdr (assoc 1 db))
zf (vl-string-subst
(rtos (getdist (getpoint "\n请选取起点:") "\n请选取止点:")
2
ws
)
(substr zf (+ 2 (vl-string-search "-" zf)))
zf
)
db (subst (cons 1 zf) (assoc 1 db) db)
)
(entmod db)
)
(alert "所选取的图元不是文字，请重新选取！")
)
)
(mapcar 'setvar xtblm xtblz)
(princ)
)
[/FONT]

[FONT=courier new] 
(defun c:etext () 
  (setq        xtblm '("cmdecho" "osmode" "dimzin") 
        xtblz (mapcar 'getvar xtblm) 
        ws    (getint "\n请指定要保留的小数位:") 
  ) 
  (mapcar 'setvar xtblm '(0 33 0)) 
  (while (setq ent (entsel "\n请选取需修改的文字:")) 
    (setq ent (car ent) 
          db  (entget ent) 
    ) 
    (if        (wcmatch (cdr (assoc 0 db)) "*TEXT") 
      (progn 
        (redraw ent 3) 
        (setq zf (cdr (assoc 1 db)) 
              zf (vl-string-subst 
                   (rtos (getdist (getpoint "\n请选取起点:") "\n请选取止点:") 
                         2 
                         ws 
                   ) 
                   (substr zf (+ 2 (vl-string-search "-" zf))) 
                   zf 
                 ) 
              db (subst (cons 1 zf) (assoc 1 db) db) 
        ) 
        (entmod db) 
      ) 
      (alert "所选取的图元不是文字，请重新选取！") 
    ) 
  ) 
  (mapcar 'setvar xtblm xtblz) 
  (princ) 
) 
[/FONT]

cqsnowfox · 发表于 2005-11-10 15:11:26

Sub JLZJ()
 AppActivate AcadApp.Caption
Dim txtobj As AcadText
Dim returnObj As AcadObject
Dim basePnt As Variant
Dim p1 As Variant
Dim p2 As Variant
Dim distance As Double
Dim sp(0 To 2) As Double
Dim ep(0 To 2) As Double
On Error Resume Next
RETRY:
acaddoc.Utility.GetEntity returnObj, basePnt, "请选择要修改的文本对象："
If Err <> 0 Then
 Err.Clear
 GoTo RETRY
Else
End If
If returnObj.EntityName = "AcDbText" Then
 Set txtobj = returnObj
Else
 GoTo RETRY
End If
p1 = acaddoc.Utility.GetPoint(, "请点取第一点：")
p2 = acaddoc.Utility.GetPoint(, "请点取第二点：")
sp(0) = Val(p1(0)): sp(1) = Val(p1(1)): sp(2) = Val(p1(2))
ep(0) = Val(p2(0)): ep(1) = Val(p2(1)): ep(2) = Val(p2(2))
distance = Sqr((ep(0) - sp(0)) ^ 2 + (ep(1) - sp(1)) ^ 2 + (ep(2) - sp(2)) ^ 2)
distance = QUWEI(distance, 2)
txtobj.TextString = Str(distance)
END SUB

Public Function QUWEI(X As Double, Y As Integer) As Double '数据四舍五入取位函数
 'X为需要四舍五入的字符串数据，Y为小数点后保留的位数
 Dim p As String
 Dim g As Integer
 Dim dotback As String '小数点后数据
Dim dotbefore As String '小数点前数据
Dim n As String
 Dim k As String

p = Str(X)
p = RTrim(LTrim(p))
g = InStr(1, p, ".")
dotbefore = Left(p, g - 1)
dotback = Right$(p, Len(p) - g)
dotback = Left(dotback, Y + 1)
n = Right(dotback, 1)
dotback = Left(dotback, Y)
k = Right(dotback, 1)
dotback = Left(dotback, Y - 1)
If Val(n) > 5 Then
 k = Str(Val(k) + 1)
End If
dotback = dotback + k
QUWEI = Val(dotbefore + "." + dotback)
End Function

lijinglq · 发表于 2005-11-10 21:11:02

谢谢楼上2位的帮忙，由于我不会生成VBA的程序，所以3楼楼主的程序我没有用，但是仍深深地表示感谢！！
2楼楼主的lisp我用了，完全满足我的要求。我测试了一下，支持捕捉、支持任意坐标系、支持文字倾斜、标注出的数字为实际距离。但是我还有一个小请求，就是有时我们的表示方法为“d400-30.00”意思是“管径-管长”，而有时是“d400-30.00-1%”意思是“管径-管长-坡度”，可不可以改进一下您的程序，让它只改中间的“管长”，我试了一下您的程序即使文字是“管径-管长-坡度”的形式，运行程序以后“管长”的数字是对的，而“坡度”就没了。能不能编一个同时支持以上两种表示形式的程序，谢谢。

yshf · 发表于 2005-11-10 23:29:31

;请试用以下程序
(defun c:etext()
   (setq xtblm '("cmdecho" "osmode" "dimzin")
         xtblz (mapcar 'getvar xtblm)
         ws (getint "\n请指定要保留的小数位:")
   )
  (mapcar 'setvar xtblm '(0 33 0))
  (while (setq ent (entsel "\n请选取需修改的文字:"))
   (setq ent (car ent) db (entget ent))
   (if (wcmatch (cdr (assoc 0 db)) "*TEXT")
      (progn
      (redraw ent 3)
      (setq zf (cdr (assoc 1 db))
               z1 (substr zf (1+ (vl-string-search "-" zf )))
               n2 (vl-string-search "-" z1 2)
               dd (strcat"-" (rtos (getdist (getpoint "\n请选取起点:") "\n请选取止点:") 2 ws))
   )
   (if (/= n2 nil)
      (setq z1 (substr z1 1 (1+ n2))
            dd (strcat dd "-")
      )
   )
   (setq zf (vl-string-subst dd z1 zf)
            db (subst (cons 1 zf) (assoc 1 db) db)
      )
      (entmod db)
   )
   (alert "所选取的图元不是文字，请重新选取！")
)
  )
  (mapcar 'setvar xtblm xtblz)(princ)
)
程序不错，就是看起来有点累，再替你改一次。by xyp1964[/COLOR]

[FONT=courier new]
(defun c:etext ()
(setq xtblm '("cmdecho" "osmode" "dimzin")
xtblz (mapcar 'getvar xtblm)
ws (getint "\n请指定要保留的小数位:")
)
(mapcar 'setvar xtblm '(0 33 0))
(while (setq ent (entsel "\n请选取需修改的文字:"))
(setq ent (car ent)
db (entget ent)
)
(if (wcmatch (cdr (assoc 0 db)) "*TEXT")
(progn
(redraw ent 3)
(setq zf (cdr (assoc 1 db))
z1 (substr zf (1+ (vl-string-search "-" zf)))
n2 (vl-string-search "-" z1 2)
dd (strcat "-"
(rtos (getdist (getpoint "\n请选取起点:") "\n请选取止点:")
2
ws
)
)
)
(if (/= n2 nil)
(setq z1 (substr z1 1 (1+ n2))
dd (strcat dd "-")
)
)
(setq zf (vl-string-subst dd z1 zf)
db (subst (cons 1 zf) (assoc 1 db) db)
)
(entmod db)
)
(alert "所选取的图元不是文字，请重新选取！")
)
)
(mapcar 'setvar xtblm xtblz)
(princ)
)[/FONT]

[FONT=courier new] 
(defun c:etext () 
  (setq        xtblm '("cmdecho" "osmode" "dimzin") 
        xtblz (mapcar 'getvar xtblm) 
        ws    (getint "\n请指定要保留的小数位:") 
  ) 
  (mapcar 'setvar xtblm '(0 33 0)) 
  (while (setq ent (entsel "\n请选取需修改的文字:")) 
    (setq ent (car ent) 
          db  (entget ent) 
    ) 
    (if        (wcmatch (cdr (assoc 0 db)) "*TEXT") 
      (progn 
        (redraw ent 3) 
        (setq zf (cdr (assoc 1 db)) 
              z1 (substr zf (1+ (vl-string-search "-" zf))) 
              n2 (vl-string-search "-" z1 2) 
              dd (strcat "-" 
                         (rtos (getdist (getpoint "\n请选取起点:") "\n请选取止点:") 
                               2 
                               ws 
                         ) 
                 ) 
        ) 
        (if (/= n2 nil) 
          (setq        z1 (substr z1 1 (1+ n2)) 
                dd (strcat dd "-") 
          ) 
        ) 
        (setq zf (vl-string-subst dd z1 zf) 
              db (subst (cons 1 zf) (assoc 1 db) db) 
        ) 
        (entmod db) 
      ) 
      (alert "所选取的图元不是文字，请重新选取！") 
    ) 
  ) 
  (mapcar 'setvar xtblm xtblz) 
  (princ) 
)[/FONT]

lijinglq · 发表于 2005-11-11 08:55:40

十分感谢yshf 同志的热心帮忙，完全满足我的要求，谢谢，谢谢。

232800088817 · 发表于 2005-11-21 11:21:11

编程怎么这样难，，我英语不好，下辈子能不能学会呀

yshf · 发表于 2005-11-22 14:36:57

xyp1964版主,"code或php代码发布程序"具体是怎样操作，热切盼望您发一份到hrycly@126.com，不然以后说不定又要麻烦您帮修改了，真是不好意思。

li809 · 发表于 2005-11-25 23:31:27

VBA是怎么用的呀？

mann_ygw · 发表于 2005-11-26 10:35:48

我想问问如果原来没有文字如何通过测量两点距离把结果写出文字,要写在自己希望的位置上,

28648387 · 发表于 2005-11-26 19:25:00

最初由 lijinglq 发布
[B]十分感谢yshf 同志的热心帮忙，完全满足我的要求，谢谢，谢谢。 [/B]

我同感，

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

[编程申请]：请求一个能自动标注所量取距离的小程序

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

浏览过的版块