[VBA函数]：坐标注记程序原代码!

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

*-*1