坐标注记程序原代码!

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)

'*********'测量坐标与屏幕坐标的转换

us1 = ThisDrawing.GetVariable("userr1")
us2 = ThisDrawing.GetVariable("userr2")
us3 = ThisDrawing.GetVariable("userr3")

If ThisDrawing.GetVariable("useri5") = 666 Then
Select Case us1
Case 500
If us2 = 100 And us3 = 100 Then
p1(0) = (p1(0) + 100) / 2: p1(1) = (p1(1) + 100) / 2
ElseIf us2 = 0 And us3 = 0 Then

p1(0) = (p1(0) - 100) / 2: p1(1) = (p1(1) - 100) / 2
End If
Case 1000
If us2 = 100 And us3 = 100 Then
p1(0) = p1(0): p1(1) = p1(1)
ElseIf us2 = 0 And us3 = 0 Then
p1(0) = p1(0) - 100: p1(1) = p1(1) - 100
End If
Case 2000
If us2 = 100 And us3 = 100 Then
p1(0) = p1(0) * 2 - 100: p1(1) = p1(1) * 2 - 100
ElseIf us2 = 0 And us3 = 0 Then
p1(0) = (p1(0) - 100) * 2: p1(1) = (p1(1) - 100) * 2
End If
Case 5000
If us2 = 100 And us3 = 100 Then
p1(0) = p1(0) * 5 - 400: p1(1) = p1(1) * 5 - 400
ElseIf us2 = 0 And us3 = 0 Then
p1(0) = p1(0) * 5 - 500: p1(1) = p1(1) * 5 - 500
End If
End Select
End If
'********






Set plineobj = ThisDrawing.ModelSpace.AddLightWeightPolyline(ver) '二维轻量多段线
plineobj.Layer = "ZJ_NEW"
If p1(1) = Int(p1(1)) Then
x = p1(1) & ".000"
Else
x = Int(p1(1) * 1000) / 1000
Dim lx As String
lx = Int(x)
If Len(x) = Len(lx) + 3 Then
x = x & "0"
ElseIf Len(x) = Len(lx) + 2 Then
x = x & "00"
End If
End If

If p1(0) = Int(p1(0)) Then
y = p1(0) & ".000"
Else
y = Int(p1(0) * 1000) / 1000
Dim ly As String
ly = Int(y)
If Len(y) = Len(ly) + 3 Then
y = y & "0"
ElseIf Len(y) = Len(ly) + 2 Then
y = y & "00"
End If
End If

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"



UnloadDVB "K:\VBA作品\zzb.dvb"
Exit Sub

ERR:
Resume
End Sub




Private Sub AcadDocument_BeginRightClick(ByVal PickPoint As Variant)
UnloadDVB "K:\VBA作品\zzb.dvb"
ThisDrawing.Utility.Prompt "*取消*"
End

End Sub

Private Sub AcadDocument_BeginSave(ByVal FileName As String)

End Sub

HQ_2003

为什么我在2004中运行，导致cad“死记“

myfreemind

这个我就说不清楚了，呵呵，我用的是2002没有问题,你可以添加一些断点，自己调试一下

ltqt007

cad2000中也死机。

myfreemind

哦，我的程序你一点都没有改吗？那我修改一下再帖上来！

myfreemind

呵，我知道你说的“死机”是怎么回事了，其实不是“死机”，而是我写的程序里面有一段是判断比例尺的，可能是在这里死的，你需要的是不是1:1的比例？

这样，你先设置一些断点，看程序中断在什么地方，然后告诉我，然后我做修改给你！

siiling16

好東西!學習!學習!!