|
|
发表于 2008-3-18 23:25:00
|
显示全部楼层
以下红色为错误,已更改，再试试，呵呵，粗心了点
Option Explicit
Private Sub CommandButton1_Click()
On Error Resume Next
UserForm1.Hide
'选择等高线
Dim EntObj(0 To 0) As AcadEntity
Dim PPt As Variant
ThisDrawing.Utility.GetEntity EntObj(0), PPt, "选择等高线: "
If EntObj(0) Is Nothing Then Exit Sub
'求直线的外框
Dim Pt1 As Variant
Dim Pt2 As Variant
EntObj(0).GetBoundingBox Pt1, Pt2
'创建选择集
Dim ssetObj As AcadSelectionSet
Set ssetObj = ThisDrawing.SelectionSets("SSET")
If Err Then Set ssetObj = ThisDrawing.SelectionSets.Add("SSET")
ssetObj.Clear
'只选取图层为DGX的图层
'选择与该直线相交或者包含在外框中的所有实体
Dim fType(0) As Integer
Dim fData(0) As Variant
fType(0) = 8: fData(0) = "dgx"
ssetObj.Select acSelectionSetCrossing, Pt1, Pt2, fType, fData
'由于其中包含了自身实体，故应从选择集中移走
'由于移去函数的参数是对象集合，所以在上面定义的是单个对象的对象集合
ssetObj.RemoveItems EntObj
Dim entTempElev As Double
entTempElev = EntObj(0).Elevation
EntObj(0).Elevation = 0
'将等高线高程暂时化为0，原高程存储到数组elevTemp（）中
Dim I As Integer
Dim elevTemp() As Double
ReDim elevTemp(0 To ssetObj.Count - 1)'这里错误，范围应为0~count-1
For I = 0 To ssetObj.Count - 1'这里错误，范围应为0~count-1
elevTemp(I) = ssetObj.Item(I).Elevation
ssetObj.Item(I).Elevation = 0
ssetObj.Item(I).Update
Next
'枚举交点，判断是否相交
Dim pts As Variant
Dim circle1() As AcadCircle
ReDim circle1(ssetObj.Count - 1)
Dim a As Integer
For I = 0 To ssetObj.Count - 1
pts = ssetObj(I).IntersectWith(EntObj(0), acExtendNone)
If Not IsEmpty(pts) Then
Dim circleT(2) As Double
circleT(0) = pts(0): circleT(1) = pts(1): circleT(2) = 0
circle1(I) = ThisDrawing.ModelSpace.AddCircle(circleT, 0.5)
End If
Next
EntObj(0).Elevation = entTempElev
For I = 0 To ssetObj.Count - 1)'这里错误，范围应为0~count-1
ssetObj.Item(I).Elevation = elevTemp(I)
ssetObj.Item(I).Update
Next
UserForm1.Show
End Sub
|
|
置顶卡
