修改后的坐标注记程序!现在不会导致"死机了"!

myfreemind

Sub zzb()
On Error GoTo ERR
Dim ver(0 To 5) As Double '多段线顶点坐标
Dim plineobj As AcadLWPolyline '多段线
Dim text_x As AcadText 'X坐标
Dim text_y As AcadText 'Y坐标
Dim xins(0 To 2) As Double 'X坐标插入点
Dim yins(0 To 2) As Double 'Y坐标插入点
Dim zjlayer As AcadLayer '注记层
Dim ltxt As Single '坐标文本长度
Dim lint As Integer '坐标文本长度
Dim us1 As String '比例尺
Dim us2 As String '左下角X坐标
Dim us3 As String ''左下角Y坐标



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
'  ThisDrawing.SetVariable "OSMODE", 1
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" & " " & x, xins, 2)
Set text_y = ThisDrawing.ModelSpace.AddText("NY" & " " & y, yins, 2)
text_x.Layer = "ZJ_NEW"
text_y.Layer = "ZJ_NEW"



Exit Sub

ERR:
Resume
End Sub

yfy2003

好程序啊！怎么跑到后面来了！
顶！

2002-ytf

能否批量标注块的坐标？

myfreemind

程序改一下应该可以的，你修改一下！

kent-liu

好东西。。。顶。。。可是请问楼主。。程序该放在那个文件内啊？？？？我的时ACAD2002+天正6

wcl3260

先顶一下

chm10

先顶一下再说

 

冰山雪莲

不知道怎么用，支持一下：）

叶文军

函数错误:0