不好意思，刚才点错，发了个空帖子~~

myfreemind

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

mccad

myfreemind

我经常和图形打交道，为了把图形做的美观一点，所以不太满意CAD中的一些功能，总想自己做程序来改进，比如我写的那个坐标注记程序，X，Y坐标中间的分隔线在不同的比例尺下是不同长短的，因为我不知道文本的屏幕距离怎么获得，所以就用笨办法每个比例尺都取取一个值，做到分隔线和文本长度一样，这样才比较美观~~~

efan2000

单行的文字可以用GetBoundingBox来获取，但是文字必须是水平的，并且不能使用ScaleFactor设置了缩放。
而多行的文字要用到组码来获取，可以参考其它资料。

myfreemind