线的交点问题

dchlmz

思路：选一条多段线，程序自动创建5条线，求交点

问题：所求交点重合为一个点？？？请高手指点。谢谢。

     Dim ent As AcadEntity

   On Error Resume Next
    N = -1
    Do
        ThisDrawing.Utility.GetEntity ent, Pnt, "选择区域范围线（多段线）："
        If Err Then Exit Sub
        If TypeName(ent) Like "IAcad*Polyline" Then Exit Do

    Loop
    Dim StartPt(0 To 2) As Double, EndPt(0 To 2) As Double

    For u = 1 To 5
   
        StartPt(0) = 100 + (u - 1) * 5
        StartPt(1) = 100
        StartPt(2) = 0
       
        EndPt(0) =120 + (u - 1) * 5
        EndPt(1) = 120

        EndPt(2) = 0
       
    Dim LineObj As AcadLine
   
    Set LineObj = ThisDrawing.ModelSpace.AddLine(StartPt, EndPt)
    LineObj.Update
    
   
    intPoints = LineObj.IntersectWith(ent, acExtendThisEntity)
    
      Dim str As String
    Dim pointObj As AcadPoint         '声明点的对象变量
    Dim Location(0 To 2) As Double    '声明点的位置数组变量
    
    
    If VarType(intPoints) <> vbEmpty Then
        For i = LBound(intPoints) To UBound(intPoints)
            str = "Intersection Point[" & k & "] is: " & Format(intPoints(j), "0.000") & "," & Format(intPoints(j + 1), "0.000") & "," & intPoints(j + 2)
            'MsgBox str, , "IntersectWith Example"
           
            Location(0) = Format(intPoints(j), "0.000")
            Location(1) = Format(intPoints(j + 1), "0.000")
            Location(2) = 0
           
            Set pointObj = ThisDrawing.ModelSpace.AddPoint(Location)
            str = ""
            i = i + 2
            j = j + 3
            k = k + 1
        Next i
    End If
   
    Next u

dchlmz

没有人回答呀

雪山飞狐_lzh

1. If VarType(intPoints) <> vbEmpty Then
2.         For i = LBound(intPoints) To UBound(intPoints)
3.             str = "Intersection Point[" & k & "] is: " & Format(intPoints(j), "0.000") & "," & Format(intPoints(j + 1), "0.000") & "," & intPoints(j + 2)
4.             'MsgBox str, , "IntersectWith Example"
5.             
6.             Location(0) = Format(intPoints(j), "0.000")
7.             Location(1) = Format(intPoints(j + 1), "0.000")
8.             Location(2) = 0
9.             
10.             Set pointObj = ThisDrawing.ModelSpace.AddPoint(Location)
11.             str = ""
12.             i = i + 2
13.             j = j + 3
14.             k = k + 1
15.         Next i
16.     End If

复制代码

for each 语句的种子是i，为什么在循环体还要改变它的值？

2. Sub test2()
3. Dim ent As AcadEntity
4.    On Error Resume Next
5.     n = -1
6.     Do
7.         ThisDrawing.Utility.GetEntity ent, pnt, "选择区域范围线（多段线）："
8.         If Err Then Exit Sub
9.         If TypeName(ent) Like "IAcad*Polyline" Then Exit Do
10.     Loop
11.     Dim StartPt(0 To 2) As Double, EndPt(0 To 2) As Double
12.     For u = 1 To 5
13.    
14.         StartPt(0) = 100 + (u - 1) * 5
15.         StartPt(1) = 100
16.         StartPt(2) = 0
17.         
18.         EndPt(0) = 120 + (u - 1) * 5
19.         EndPt(1) = 120
20.         EndPt(2) = 0
21.         
22.     Dim LineObj As AcadLine
23.    
24.     Set LineObj = ThisDrawing.ModelSpace.AddLine(StartPt, EndPt)
25.     LineObj.Update
26.    
27.    
28.     intPoints = LineObj.IntersectWith(ent, acExtendThisEntity)
29.    
30.       Dim str As String
31.     Dim pointObj As AcadPoint         '声明点的对象变量
32.     Dim Location(0 To 2) As Double    '声明点的位置数组变量
33.    
34.    
35.     If UBound(intPoints) > 0 Then
36.         For i = 0 To UBound(intPoints) Step 3
37.             j = i / 2
38.             str = "Intersection Point[" & j & "] is: " & Format(intPoints(i), "0.000") & "," & Format(intPoints(i + 1), "0.000") & "," & intPoints(i + 2)
39.             MsgBox str, , "IntersectWith Example"
40.             
41.             Location(0) = Format(intPoints(i), "0.000")
42.             Location(1) = Format(intPoints(i + 1), "0.000")
43.             Location(2) = Format(intPoints(i + 2), "0.000")
44.             
45.             Set pointObj = ThisDrawing.ModelSpace.AddPoint(Location)
46.             str = ""
47.         Next i
48.     End If
49.    
50.     Next u
51. End Sub

Sub test2() Dim ent As AcadEntity    On Error Resume Next     n = -1     Do         ThisDrawing.Utility.GetEntity ent, pnt, "选择区域范围线（多段线）："         If Err Then Exit Sub         If TypeName(ent) Like "IAcad*Polyline" Then Exit Do     Loop     Dim StartPt(0 To 2) As Double, EndPt(0 To 2) As Double     For u = 1 To 5             StartPt(0) = 100 + (u - 1) * 5         StartPt(1) = 100         StartPt(2) = 0                  EndPt(0) = 120 + (u - 1) * 5         EndPt(1) = 120         EndPt(2) = 0              Dim LineObj As AcadLine         Set LineObj = ThisDrawing.ModelSpace.AddLine(StartPt, EndPt)     LineObj.Update             intPoints = LineObj.IntersectWith(ent, acExtendThisEntity)           Dim str As String     Dim pointObj As AcadPoint         '声明点的对象变量     Dim Location(0 To 2) As Double    '声明点的位置数组变量             If UBound(intPoints) > 0 Then         For i = 0 To UBound(intPoints) Step 3             j = i / 2             str = "Intersection Point[" & j & "] is: " & Format(intPoints(i), "0.000") & "," & Format(intPoints(i + 1), "0.000") & "," & intPoints(i + 2)             MsgBox str, , "IntersectWith Example"                          Location(0) = Format(intPoints(i), "0.000")             Location(1) = Format(intPoints(i + 1), "0.000")             Location(2) = Format(intPoints(i + 2), "0.000")                          Set pointObj = ThisDrawing.ModelSpace.AddPoint(Location)             str = ""         Next i     End If         Next u End Sub

dchlmz

i重给定值是因为没有加步长，默认为1，为得到正确坐标，需重赋值。

现在解决了，谢谢版主。