scs2000图纸模式坐标注记程序程序代码，有改进方法请告诉我！请告诉我！
不好意思，忘了贴代码，：），帖在取直线端点坐标那个贴子下面的程序其实是坐标注记
不好意思，忘了贴代码，：），帖在取直线端点坐标那个贴子下面的程序其实是坐标注记程序！Sub zzb()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 '引线终点
'ThisDrawing.SetVariable "OSMODE", 1
p1 = ThisDrawing.Utility.GetPoint(, vbCrLf & "请选择注记点")
p2 = ThisDrawing.Utility.GetPoint(p1, vbCr & "注记坐标 ")
lint = Len(Int(p1(0) * 1000))
Select Case lint
Case 8
ltxt = Len(Int(p1(1) * 1000)) * 2.2
Case 7
ltxt = Len(Int(p1(1) * 1000)) * 2.4
Case 10
ltxt = Len(Int(p1(1) * 1000)) * 2
Case 6
ltxt = Len(Int(p1(1) * 1000)) * 2.4
End Select
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) '引线终点Y坐标
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"
Exit Sub
'错误处理
ERR:
Resume
End Sub
页:
[1]