修改后的坐标注记程序!现在不会导致"死机了"!
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 好程序啊！怎么跑到后面来了！
顶！ 能否批量标注块的坐标？ 程序改一下应该可以的，你修改一下！ 好东西。。。顶。。。可是请问楼主。。程序该放在那个文件内啊？？？？我的时ACAD2002+天正6 先顶一下 <P>先顶一下再说</P>
<P> </P> 不知道怎么用，支持一下：） 函数错误:0
页:
[1]