[VBA][VBA]请斑竹帮助调试

狐狸老兄 发表于 2004-3-18 08:45:00

' 坐标点排序函数 ' 语法：SortPoints(Points, SortMode) ' Points为坐标点数组 ' SortMode为排序方式：0=X向，1=Y向，2=Z向 ' 返回值为排序后的坐标点数组 Public function SortPoints(Points As Variant, SortMode As String) As Variant Dim NewPoints() As Variant ReDim NewPoints(UBound(Points)) Dim k As Long For k = 0 To UBound(NewPoints) NewPoints(k) = Points(k) Next k Dim BestPoint As Variant Dim Pnt1 As Double Dim Pnt2 As Double Dim i As Long Dim j As Long Dim Best_Value As Double Dim Best_j As Long For i = 0 To UBound(NewPoints) - 1 Best_Value = NewPoints(i)(SortMode) BestPoint = NewPoints(i) Best_j = i For j = i + 1 To UBound(NewPoints) If NewPoints(j)(SortMode) < Best_Value Then Best_Value = NewPoints(j)(SortMode) BestPoint = NewPoints(j) Best_j = j End If Next j NewPoints(Best_j) = NewPoints(i) NewPoints(i) = BestPoint Next i SortPoints = NewPoints End Function ' 示例<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /><o:p></o:p>

 <o:p></o:p>

Sub FindLineStartPoint()

Dim Sel As AcadSelectionSet

On Error Resume Next Set Sel = ThisDrawing.SelectionSets.Add("ssel") If Err Then Err.Clear ThisDrawing.SelectionSets("ssel").Delete Set Sel = ThisDrawing.SelectionSets.Add("ssel") End If On Error GoTo 0

 

'选线 Sel.SelectOnScreen

'获取坐标点 Dim obj As AcadObject Dim i As Integer Dim pa(300) As Variant Dim str As String i = 0 str = "未排序坐标" For Each obj In Sel If obj.ObjectName = "AcDbLine" Then pa(i) = obj.StartPoint str = str & Chr(13) & " 第" & i + 1 & "点坐标为: ""( " & pa(i)(0) & "," & pa(i)(1) & _

 "," & pa(i)(2) & ")" & Chr(13) i = i + 1 End If Next MsgBox str

'排序 Dim pb As Variant pb = SortPoints(pa, 0)

newtxt = 按X坐标点排序" For i = 0 To UBound(pa) newtxt = newtxt & vbCr & 第" & i + 1 & "点坐标为:" & pb(i)(0) & _ " " & pb(i)(1) & " " & pb(i)(2) Next MsgBox oldtxt & vbCr & vbCr & newtxt, , "明经通道VBA示例" Sel.Delete End Sub

请斑竹帮助调试，屏幕选取直线获得起始点坐标数组，数组排序， If NewPoints(j)(SortMode) < Best_Value Then这一句有问题

subtlation 发表于 2004-3-18 08:54:00

我把代码贴到vba编辑器中，红色的出错行很多啊。

楼主不是直接复制代码上来的？

subtlation 发表于 2004-3-18 09:13:00

SortPoints函数没有问题，问题出在传递给函数的变量pa上，pa应该是一个点的数组，但你直接声明了pa(300)，但你选择的对象一般少于300，假定是N，那么pa的下标在N+1~300之间都没有定义，这样就不存在pa(j)(sortmode)。在主过程中把Dim pa(300)       As Variant改为Dim pa()       As Variant
k = Sel.Count
ReDim pa(k - 1)下面是我修改后的主过程，测试没有问题。 Sub FindLineStartPoint()Dim Sel As AcadSelectionSetOn Error Resume Next
Set Sel = ThisDrawing.SelectionSets.Add("ssel")
If Err Then
Err.Clear
ThisDrawing.SelectionSets("ssel").Delete
Set Sel = ThisDrawing.SelectionSets.Add("ssel")
End If
On Error GoTo 0'选线
Sel.SelectOnScreen'获取坐标点
Dim obj                   As AcadObject
Dim i                            As Integer
Dim pa()       As Variant
k = Sel.Count
ReDim pa(k - 1)
Dim str                      As String
Dim k As Integer
i = 0
str = "未排序坐标"
For Each obj In Sel
If obj.ObjectName = "AcDbLine" Then
      pa(i) = obj.StartPoint
      str = str & Chr(13) & " 第" & i + 1 & "点坐标为: ""( " & pa(i)(0) & "," & pa(i)(1) & _
      "," & pa(i)(2) & ")" & Chr(13)
      i = i + 1
      End If
Next
MsgBox str'排序
Dim pb As Variant
pb = SortPoints(pa, 0)newtxt = "按X坐标点排序"
   For i = 0 To UBound(pa)
            newtxt = newtxt & vbCr & "第" & i + 1 & "点坐标为:" & pb(i)(0) & _
                           " " & pb(i)(1) & " " & pb(i)(2)
   Next
   MsgBox oldtxt & vbCr & vbCr & newtxt, , "明经通道VBA示例"
Sel.Delete
End Sub

狐狸老兄 发表于 2004-3-18 10:24:00

谢谢 <A name=5229>subtlation</A>

我编程没几天，又很多基本问题还没没搞清楚。

－－－－－－－－－－－－

学习、学习、再学习！

页: [1]

明经CAD社区's Archiver

[VBA][VBA]请斑竹帮助调试