[Dima_kr]

Есть слой например с названием freza_1, потом freza_2, 3, 4 и т.д., как можно отсортировать слои по имени и потом по окончанию(цифры), чтоб можно было выбирать именно какой номер тебе надо

[Кулик Алексей aka kpblc]

Где отсортировать? В комбобокс, что ли?

[den001]

Код:

[Выделить все]

Function SortABC(ByRef StringArray() As String)
    Dim Flag As Boolean
    Do
        Flag = False
        For i = 0 To UBound(StringArray) - 1
            If StrComp(StringArray(i), StringArray(i + 1), vbTextCompare) = 1 Then
                Flag = True
                tmp = StringArray(i)
                StringArray(i) = StringArray(i + 1)
                StringArray(i + 1) = tmp
            End If
        Next
    Loop While Flag
End Function

Сортирует по алфавиту любой одномерный текстовый массив

[Dima_kr]

мне нужно отсортировать слои сначала найти все слои где есть начало "Freza_" например слои Freza_11, Freza_17, Freza_45
потом из етого названия (Freza_11, Freza_17, Freza_45) выделить 11, 17, 45 для дальнейшей работы с числами

[den001]

Код:

[Выделить все]

Sub Sort123(ByRef NumArray())
    Dim Flag As Boolean
    Do
        Flag = False
        For i = 0 To UBound(NumArray) - 1
            If NumArray(i) > NumArray(i + 1) Then
                Flag = True
                Tmp = NumArray(i)
                NumArray(i) = NumArray(i + 1)
                NumArray(i + 1) = Tmp
            End If
        Next
    Loop While Flag
End Sub

Sub asdf()
    Dim NumLay(), StringArray() As String
    KeyStr = "freza_"
    nl = 0
    For i = 0 To UBound(StringArray) - 1
        If InStr(1, StringArray(i), KeyStr, vbTextCompare) > 0 Then
            ReDim Preserve NumLay(nl)
            NumLay(nl) = Val(Replace(StringArray(i), KeyStr, "", , , vbTextCompare))
            nl = nl + 1
        End If
    Next
    Sort123 NumLay
End Sub

StringArray - это тот самый массив имен слоев
На выходе имеем NumLay - отсортированный по возрастанию числовой массив искомых окончаний.
Проверил - работает.

[den001]

Если уж доводить до конца, то будет примерно так:

Код:

[Выделить все]

Sub Sort123(ByRef NumArray())
    Dim Flag As Boolean
    Do
        Flag = False
        For i = 0 To UBound(NumArray) - 1
            If NumArray(i) > NumArray(i + 1) Then
                Flag = True
                Tmp = NumArray(i)
                NumArray(i) = NumArray(i + 1)
                NumArray(i + 1) = Tmp
            End If
        Next
    Loop While Flag
End Sub


Sub asdf()
    Dim NumLay(), LayName() As String, sset As AcadSelectionSet
    nlay = ThisDrawing.Layers.Count
    ReDim LayName(nlay - 1)
    For i = 0 To nlay - 1
        LayName(i) = ThisDrawing.Layers(i).Name
    Next
    KeyStr = "freza_"
    nl = 0
    For i = 0 To UBound(LayName) - 1
        If InStr(1, LayName(i), KeyStr, vbTextCompare) > 0 Then
            ReDim Preserve NumLay(nl)
            NumLay(nl) = Val(Replace(LayName(i), KeyStr, "", , , vbTextCompare))
            nl = nl + 1
        End If
    Next
    Sort123 NumLay
End Sub

Это не проверял, да, собственно, это почти то же самое.

[Dima_kr]

Большое спасибо за помощь.

[Dima_kr]

пишет ошибку "Replace"


NumLay(nl) = Val(Replace(LayName(i), KeyStr, "", , , vbTextCompare))
[ATTACH]1170920473.JPG[/ATTACH]

[den001]

Хм.. Странно...Replace - штатная функция, и у меня работает. Ну, тогда так

Код:

[Выделить все]

Sub Sort123(ByRef Numarray())
    Dim Flag As Boolean
    Do
        Flag = False
        For i = 0 To UBound(Numarray) - 1
            If Numarray(i) > Numarray(i + 1) Then
                Flag = True
                Tmp = Numarray(i)
                Numarray(i) = Numarray(i + 1)
                Numarray(i + 1) = Tmp
            End If
        Next
    Loop While Flag
End Sub

Function RmvStr(ByVal TextString, StringToRemove, Optional Sing As Boolean, Optional NoCaps As Boolean)
    RmvStr = TextString
    If StringToRemove = "" Then Exit Function
    nc = 0
    Do
        If NoCaps Then nc = InStr(LCase(TextString), LCase(StringToRemove)) Else nc = InStr(TextString, StringToRemove)
        If nc > 0 Then
            TextString = Left(TextString, nc - 1) + Right(TextString, Len(TextString) - nc - Len(StringToRemove) + 1)
        End If
    Loop Until nc = 0 Or Sing
    RmvStr = TextString
End Function

Sub asdf()
    Dim NumLay(), LayName() As String
    Dim ft(0) As Integer, fd(0) As Variant
    nlay = ThisDrawing.Layers.Count
    ReDim LayName(nlay - 1)
    For i = 0 To nlay - 1
        LayName(i) = ThisDrawing.Layers(i).Name
    Next
    KeyStr = "freza_"
    nl = 0
    For i = 0 To UBound(LayName) - 1
        If InStr(1, LayName(i), KeyStr, vbTextCompare) > 0 Then
            ReDim Preserve NumLay(nl)
'            NumLay(nl) = Val(Replace(LayName(i), KeyStr, "", , , vbTextCompare))
            NumLay(nl) = Val(RmvStr(LayName(i), KeyStr, , True))
            nl = nl + 1
        End If
    Next
    If nl > 0 Then Sort123 NumLay
End Sub

Проверено

[Dima_kr]

Спасибо, все отлично работает!!!