|
|
发表于 2004-11-26 08:50:00
|
显示全部楼层
下面的程序在AutoCAD MAP 2000上通过
Sub tt()
On Error GoTo Err_Control
Dim pnt
Dim picked As Boolean
Dim px() As Double
Dim py() As Double
Dim i, k, j As Integer
Dim pcenter() As Double
Dim insertdistance() As Double
Do While 1
pnt = ThisDrawing.Utility.GetPoint(, "在闭合圈内点击")
ThisDrawing.SendCommand "-boundary" & vbCr & "a" & vbCr & "b" & vbCr & "e" & vbCr & vbCr & pnt(0) & "," & pnt(1) & vbCr & vbCr
Set pr = ThisDrawing.ModelSpace(ThisDrawing.ModelSpace.Count - 1)
Dim retCoord As Variant
retCoord = pr.Coordinates
k = (UBound(retCoord) + 1) / 2
ReDim px(UBound(retCoord)) As Double
ReDim py(UBound(retCoord)) As Double
For i = 0 To UBound(retCoord) Step 2
px(i / 2) = retCoord(i)
py(i / 2) = retCoord(i + 1)
Next i
ReDim pcenter(0 To 2) As Double
ReDim insertdistance(k - 2) As Double
For i = 0 To k - 2
pcenter(0) = (px(i) + px(i + 1)) / 2
pcenter(1) = (py(i) + py(i + 1)) / 2
pcenter(2) = 0
insertdistance(i) = Sqr((px(i) - px(i + 1)) * (px(i) - px(i + 1)) + (py(i) - py(i + 1)) * (py(i) - py(i + 1)))
insertdistance(i) = Format(insertdistance(i), "#,##0.00;;;Nil")
ThisDrawing.ModelSpace.AddText insertdistance(i), pcenter, 0.65
Next i
picked = True
Loop
Exit_Here:
Exit Sub
Err_Control:
Select Case Err.Number
Case -2147467259
'右键单击或回车或空格
Err.Clear
Resume Exit_Here
End Select
End Sub
|
|
置顶卡
