[分享]：［蜜蜂软体］坐标标注----新(源码)[2005.2.17更新]

netbee

这是我更新后的坐标标注程序!
主要应用于测绘。也可用于设计总图时的标注

本程序需要AutoCAD的ET工具库acetutil.arx  acetutil.dll
中的函数acet-ss-drag-move作预览功能
若你没有安装则到这里单独下载2002版:
acetutil.arx
你也可以用晓东工具中的函数代替。
==========
2004.6.12  已经更正错误处理函数
======================
2005.2.17  重写大量代码：
加入坐标转换功能
加入对话框功能
加入比例
加入参数保存在图形中的功能

。。。。。


若你只需要直接使用，则可以下载编译版的：点击下载[/COLOR]

对话框图示：

                               
登录/注册后可看大图

netbee

这是演示：

ydf7332462

是否支持ucs

netbee

数学坐标系及测量坐标系都支持
但在数学坐标系中它会自动对XY进行互换。即正北方向永为X。正东方向永为Y
本来想添加是否进行XY互换的设置功能。但因我是用在测绘方面，所以就一直未添。
你可以对它进行添加嘛。

欢迎大家对它进行修改添加。
并指出不足!

陈老汉

有如此复杂吗?

water02

感觉上，有点复杂，还没有仔细研究一下

netbee

呵呵，大家知道的，功能上越全，使用上越方便，那程序设计上肯定是越复杂的喽!
其实我的这个已经是很简单的啦，已经尽量用模块化。

本程序特点一可以定制标注角度：因为有时在用坐标系进行总图的绘制时，而出图时却由于版面的原因，需要以其他角度的方式进行出图，这时为了让标注与出图时的水平一致，就需要在坐标系统绘制时，让坐标标注与出图时的水平方向一样。

大家可以把动态标注的功能去掉。因为这是为我这儿的测量功能定制的。

3602705

代号了，谢谢！

beesoft

对于我做总图的太方便啦。谢谢

aeo

先不评论好用不好用.
程序差不多每行有注解，我从每有那种耐心^_^

所有参数不是在"基点"的时候改，而在拖拽中改，我不大习惯.

lt_zzy

命令: zbbz
测量坐标标注程序:ZBBZ
数学坐标系![X Y将会互换!!!!!!!!!!!!]; 错误: *error* 函数中出错AutoCAD
变量设置被拒绝: "orthomode" nil

netbee

最初由 lt_zzy 发布
[B]命令: zbbz
测量坐标....... [/B]

呵呵，错误处理函数中没有判断变量orthomode_old的语句，所以当程序在orthomode_old变量赋值之前出错的话，CAD将跳至这个出错处理程序，而此时执行(setvar "orthomode" orthomode_old) 是肯定会出错的。所以这里再出错，它就无法显示出错信息且无法正常退出程序啦。


请你(及名位网友)用这个错误处理函数代替程序中的。
再次运行试试!

2. 
   
3. ;;--------------------------------
   
4.   (defun err_new (msg)
   
5. [color=red]    (if orthomode_old(setvar "orthomode" orthomode_old) )[/color]
   
6.     (princ msg)
   
7.     (setclose_zb)
   
8.   ) ;_ 结束defun
   

<br /> ;;-------------------------------- <br />   (defun err_new (msg) <br /> [color=red]    (if orthomode_old(setvar "orthomode" orthomode_old) )[/color]<br />     (princ msg) <br />     (setclose_zb) <br />   ) ;_ 结束defun <br />

自由的鱼

贴个VBA的注记坐标程序

Sub zzb_CAD()
On Error GoTo ERR
Dim ver(0 To 5) As Double
Dim plineobj As AcadLWPolyline
Dim text_x As AcadText
Dim text_y As AcadText
Dim xins(0 To 2) As Double
Dim yins(0 To 2) As Double
Dim zjlayer As AcadLayer
Dim ltxt As Single
Dim lint As Integer
Dim us1 As String
Dim us2 As String
Dim us3 As String



Set zjlayer = ThisDrawing.Layers.Add("ZJ_NEW")


zjlayer.Color = acCyan

Dim x As String
Dim y As String

Dim p1 As Variant
Dim p2 As Variant
Dim p3(0 To 1) As Double

p1 = ThisDrawing.Utility.GetPoint(, vbCrLf & "选择注记点:")


p2 = ThisDrawing.Utility.GetPoint(p1, vbCr & "注记坐标 ")




ltxt = 17



If p2(0) > p1(0) And p2(1) > p1(1) Then
GoTo 1
ElseIf p2(0) > p1(0) And p2(1) < p1(1) Then
GoTo 1
ElseIf p2(0) < p1(0) And p2(1) < p1(1) Then
GoTo 2
ElseIf p2(0) < p1(0) And p2(1) > p1(1) Then
GoTo 2
End If

1:
p3(0) = p2(0) + ltxt
p3(1) = p2(1)
xins(0) = p2(0) + 1
xins(1) = p2(1) + 1
yins(2) = 0
yins(0) = p2(0) + 1
yins(1) = p2(1) - 3
yins(2) = 0
GoTo zj

2:

p3(0) = p2(0) - ltxt
p3(1) = p2(1)
xins(0) = p3(0) + 1
xins(1) = p3(1) + 1
yins(2) = 0
yins(0) = p3(0) + 1
yins(1) = p3(1) - 3
yins(2) = 0

zj:
ver(0) = p1(0)
ver(1) = p1(1)
ver(2) = p2(0)
ver(3) = p2(1)
ver(4) = p3(0)
ver(5) = p3(1)








p1(0) = p1(0): p1(1) = p1(1)

x = Format(p1(0), "####0.000")
y = Format(p1(1), "####0.000")

Set plineobj = ThisDrawing.ModelSpace.AddLightWeightPolyline(ver)
plineobj.Layer = "ZJ_NEW"


Set text_x = ThisDrawing.ModelSpace.AddText("X=" & " " & y, xins, 2)
Set text_y = ThisDrawing.ModelSpace.AddText("Y=" & " " & x, yins, 2)
text_x.Layer = "ZJ_NEW"
text_y.Layer = "ZJ_NEW"



Exit Sub

ERR:
Resume
End Sub

heliangyu

不是看到很多的坐标标注的lisp程序，老兄你也收钱啊！

netbee

因为我穷啦。（玩笑话）
其实收费只是一种肯定劳动成果的方法，因为我上传的程序全部都是开源的，而且相同的程序每个人都有不同的编程技巧，都有学习之处。这也是我不喜欢ARX的原因，它太自私啦！
你也可以上传一些自己的程序收收费嘛。大家共同至富才是目的哟！^_^