• На форуме с 10 августа 2007г.
  • Сообщений: 63
  • Спасибо: 0

Тема: Сортировка массива

Есть массив точек, их нужно отсортировать по координате Z.
В автолиспе можно отсортировать, работая со списками vl-sort, min, max. А есть ли аналоги в VBA для массивов  или просто для какого-нибудь набора элементов, типа AcadSelectionSet?

  • Fatty
  • Восстановленный участник
  • На форуме с 30 мая 2006г.
  • Сообщений: 989
  • Спасибо: 2

Re: Сортировка массива

> Skydog
Которое время назад написал что-то подобное,
только говорят медленно работает
(см. комментарии по ссылке)

Option Explicit
' see also:
'  http://forum.developing.ru/showthread.php?p=53799#post53799
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
' written by Fatty T.O.H. (c)2006 * all rights removed '
' SourceArr - two dimensional array '
' iPos - "column" number (starting from 1) '
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Public Function CoolSort(SourceArr As Variant, iPos As Integer) As Variant
Dim Check As Boolean
ReDim tmpArr(UBound(SourceArr, 2)) As Variant
Dim iCount As Integer
Dim jCount As Integer
Dim nCount As Integer
iPos = iPos - 1
Check = False
Do Until Check
Check = True
For iCount = LBound(SourceArr, 1) To UBound(SourceArr, 1) - 1
If SourceArr(iCount, iPos) > SourceArr(iCount + 1, iPos) Then
For jCount = LBound(SourceArr, 2) To UBound(SourceArr, 2)
tmpArr(jCount) = SourceArr(iCount, jCount)
SourceArr(iCount, jCount) = SourceArr(iCount + 1, jCount)
SourceArr(iCount + 1, jCount) = tmpArr(jCount)
Check = False
Next
End If
Next
Loop
CoolSort = SourceArr
End Function
'' Usage:
Sub Test()
Dim i As Long, j As Long
Dim newar As Variant
Dim arr(10, 3) As Integer
For i = 0 To 9
For j = 0 To 3
arr(i, j) = (-1 * i) ^ j
Next
Next
newar = CoolSort(arr, 2)
End Sub
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'

~'J'~

  • LeonidSN
  • Активный участник
  • На форуме с 30 мая 2005г.
  • Сообщений: 1,480
  • Спасибо: 5

Re: Сортировка массива

> Насколько
мне известно встроенных функций сортировки в языке VB(VBA) нет. Но есть, например, книга "VB Готовые алгоритмы" Рода Стивенса где очень подробно и широко освещена эта тема. Есть, наверняка, специализированные библиотеки.
Ну и есть, наконец, постоянно опережающий меня Fatty.

  • Boxa
  • Восстановленный участник
  • На форуме с 16 августа 2005г.
  • Сообщений: 60
  • Спасибо: 0

Re: Сортировка массива

Сильно ногами не принайте, похожую задачу для массива точек (блоков) в плоскости решил вот так.
Адаптировать скрипт под 3 координаты легко.

Sub Example_SelectOnScreen()
    ' This example adds objects to a selection set by prompting the user
    ' to select ones to add.
    ' Create the selection set
    Dim ssetObj As AcadSelectionSet
    Dim items As Object
    Dim point As Variant
    Dim point1 As Variant
    Dim point2 As Variant
    Dim point3 As Variant
    Dim textObj As AcadText
    Dim db As DAO.Database
    Dim rst As Recordset
    Dim rst1 As Recordset
'Создаю БД
Set db = DAO.CreateDatabase("C:\test11.mdb", dbLangCyrillic)
db.Execute "CREATE TABLE Tabl1 " & "(x REAL, y REAL, z REAL);"
On Error GoTo fuck
'Выбор точек
    Set ssetObj = ThisDrawing.SelectionSets.Add("TEST_SSET1")
    ssetObj.SelectOnScreen
    qw = ssetObj.Count
ReDim point1(0 To qw, 0 To 2) As Double
'Загоняю координаты точек в БД
For Each items In ssetObj
    point = items.InsertionPoint
    point1 = CLng(point(0))
    point2 = CLng(point(1))
    point3 = CLng(point(2))
    db.Execute "INSERT INTO Tabl1 (x,y,z) VALUES (" & point1 & ", " & point2 & ", " & point3 & ");"
Next
'Собственно запрос сортировки.
Set rst = db.OpenRecordset("SELECT * FROM Tabl1 ORDER BY x, y;")
'Простановка номеров точек
rst.MoveFirst
a_0001 = 1
Do While Not rst.EOF = True
    point(0) = CDbl(rst.Fields(0) + 200)
    point(1) = CDbl(rst.Fields(1) + 200)
    point(2) = CDbl(rst.Fields(2))
    rst.MoveNext
    Set textObj = ThisDrawing.ModelSpace.AddText(a_0001, point, 350)
    textObj.Update
a_0001 = a_0001 + 1
Loop
'Отладка
l = l + 1
fuck:
MsgBox a_0001
    'rst.Close
    db.Close
    'Set rst = Nothing
    Set db = Nothing
Kill ("C:\test11.mdb")
    ssetObj.Clear
    ssetObj.Delete
End Sub