[下载]：提供坐标标注的VB源代码！

心梦相随

我也在学VB。这个源码编译成。EXE后在CAD2002通过
希望大家共同学习进步啊。有什么好的拿出来共享啊
免费

kingbird

已经下载，谢谢

mikewolf2k

下不了？

xxbobo81

穷人家的孩子就是惨，看到想要的东东下不了

pfrao

没关系  多来就可以下 努力ing

lixd17820

顶,既然是免费不妨下载了看看.

gjliang

Sub pi()
Dim pt1 As Variant
Dim pt2 As Variant
Dim pt3 As Variant
Dim line1 As AcadLine
On Error Resume Next
pt1 = ThisDrawing.Utility.GetPoint(, "起点：") ''定义坐标点,既是引线的起点
pt2 = ThisDrawing.Utility.GetPoint(pt1, "终点：")
Set line1 = ThisDrawing.ModelSpace.AddLine(pt1, pt2)
Dim lcx As AcadLayer
Set lcx = ThisDrawing.Layers.Add("点坐标")
lcx.Lineweight = acLnWt025
lcx.Color = acRed  '设置层的颜色
line1.Layer = "点坐标"
line2.Layer = "点坐标"
Dim textObj As AcadText
Dim textString1 As String
Dim textString2 As String
Dim textString3 As String
Dim textString4 As String
Dim textpt1(0 To 2) As Double
Dim textpt2(0 To 2) As Double
Dim textpt3(0 To 2) As Double
Dim textpt4(0 To 2) As Double
Dim height As Double
Dim x1 As Variant '引线的起点x坐标
Dim y1 As Variant '引线的起点y坐标
Dim x2 As Variant '引线的起点x坐标
Dim y2 As Variant '引线的终点y坐标
Dim anglept As Variant '引线的角度
Dim pi As Variant
'Dim textent As AcadEntity
'Dim high As Variant
'For Each textent In ThisDrawing.ModelSpace '搜索全图中的文字高度
'If TypeOf textent Is AcadText Then
'high = textent.height
'End If
'Next
x1 = pt1(0)
y1 = pt1(1)
x2 = pt2(0)
y2 = pt2(1)
pi = 4 * Atn(1)
height = 3.5  '设定字高的参数
anglept = Atn(Abs((y2 - y1)) / (x2 - x1))
textpt1(0) = pt2(0)
textpt1(1) = pt2(1) + height * 2
textpt2(0) = pt2(0)
textpt2(1) = pt2(1) + height - height * 0.67
textString1 = FormatNumber(pt1(0), 2, vbTrue, , vbFalse)
textString2 = FormatNumber(pt1(1), 2, vbTrue, , vbFalse)
textString3 = "X=" + textString1
textString4 = "Y=" + textString2
Dim textobj1 As AcadText
Dim textobj2 As AcadText
Set textobj1 = ThisDrawing.ModelSpace.AddText(textString3, textpt1, height)
Set textobj2 = ThisDrawing.ModelSpace.AddText(textString4, textpt2, height)
textobj1.Layer = "点坐标"
textobj2.Layer = "点坐标"
Dim minpoint As Variant
Dim maxpoint As Variant
Dim minpoint1 As Variant
Dim minpoint2 As Variant
textobj1.GetBoundingBox minpoint, maxpoint
textobj2.GetBoundingBox minpoint1, maxpoint1
Dim x As Variant
Dim y As Variant
x = Abs(minpoint(0) - maxpoint(0))
y = Abs(minpoint1(0) - maxpoint1(0))
If x > y Then
pt3 = ThisDrawing.Utility.PolarPoint(pt2, pi, x)
End If
If x <= y Then
pt3 = ThisDrawing.Utility.PolarPoint(pt2, pi, y)
End If
If (-pi / 2) <= anglept And anglept <= 0 Then
Set line2 = ThisDrawing.ModelSpace.AddLine(pt3, pt2)
Dim textpt11(0 To 2) As Double
Dim textpt22(0 To 2) As Double
textpt11(0) = pt3(0)
textpt11(1) = pt3(1) + height * 2
textpt22(0) = pt3(0)
textpt22(1) = pt3(1) + height - height * 0.67
textobj1.Move textpt1, textpt11
textobj2.Move textpt2, textpt22
line2.Layer = "点坐标"
End If
If 0 < anglept And anglept < (pi / 2) Then
textpt3(0) = pt2(0)
textpt3(1) = pt2(1) + height * 2
textpt4(0) = pt2(0)
textpt4(1) = pt2(1) + height - height * 0.67
textString5 = FormatNumber(pt1(0), 2, vbTrue, , vbFalse)
textString6 = FormatNumber(pt1(1), 2, vbTrue, , vbFalse)
textString7 = "X=" + textString5
textString8 = "Y=" + textString6
Set textobj3 = ThisDrawing.ModelSpace.AddText(textString7, textpt3, height)
Set textobj4 = ThisDrawing.ModelSpace.AddText(textString8, textpt4, height)
textobj3.Layer = "点坐标"
textobj4.Layer = "点坐标"
textobj3.GetBoundingBox minpoint, maxpoint
textobj4.GetBoundingBox minpoint, maxpoint
x = Abs(minpoint(0) - maxpoint(0))
y = Abs(minpoint1(1) - maxpoint1(1))
If x > y Then
pt3 = ThisDrawing.Utility.PolarPoint(pt2, pi, x)
End If
If x <= y Then
pt3 = ThisDrawing.Utility.PolarPoint(pt2, pi, y)
End If
x = Abs(minpoint(0) - maxpoint(0))
y = Abs(minpoint1(0) - maxpoint1(0))
pt3 = ThisDrawing.Utility.PolarPoint(pt2, 0, x)
Set line2 = ThisDrawing.ModelSpace.AddLine(pt2, pt3)
line2.Layer = "点坐标"
Else
Exit Sub
End If
End Sub
写的比较乱，见笑了，但是基本达到了我想要的目的：）

june0448

支持这个论坛很好

xinjunsheng

怎么什么地方都要money

200142066

谢谢啦，我也来学习学习

fantasyhk

下载看看

zhuxuhong

不错

coloursheep

哪里可以搞到money

ghhone

一个坐标标注就这么复杂，看来我要打退堂鼓了

zhacer

下载学习学习