VBS/WSH/JS - [решено] [VBS] Сортировка текстовых строк с учётом директорий

megaloman · Отправлено: **14:54, 05-01-2020** | #2

shadowbat, в списке только один символ (f или F) и он одинаковый во всех строках , или вместо него может быть смесь символов перед цифрами и они могут в разных строках свои?

shadowbat · Отправлено: **15:08, 05-01-2020** | #3

Цитата:

вместо него может быть смесь символов перед цифрами и они могут в разных строках свои?

всё как в реальной жизни, может быть и f и F и русские и английские и юникод.
это парсинг реальных путей файлов, но в виде строк, соответственно имена могут быть такие же как у реальных директорий и файлов - самые различные
сам пока пишу на split() и ubound(split())

очень предварительный и полуправильный вариант

Код:

Sub Sort()
Dim a(): ReDim a(1 To 12)
a(1) = "\F1\1.txt"
a(2) = "\F111\2.txt"
a(3) = "\f11.txt"
a(4) = "\f33.txt"
a(5) = "\f22.txt"
a(6) = "\F0\3.txt"
a(7) = "\F0\1.txt"
a(8) = "\F0\2\2.txt"
a(9) = "\F1\"
a(10) = "\F0\"
a(11) = "\F0\2\"
a(12) = "\F111\"
'сортировка
a(1) = "\F0\"
a(2) = "\F0\1.txt"
a(3) = "\F0\2\"
a(4) = "\F0\2\2.txt"
a(5) = "\F0\3.txt"
a(6) = "\f11.txt"
a(7) = "\F111\"
a(8) = "\F111\2.txt"
a(9) = "\F1\"
a(10) = "\F1\1.txt"
a(11) = "\f22.txt"
a(12) = "\f33.txt"
For Each aa In a
kol = UBound(Split(aa, "\")): If kol > max Then max = kol
Next aa
Call Sort1(a, 0, max)
Stop
End Sub
Sub Sort1(a, l, max)
For Each aa In a
kol = UBound(Split(aa, "\"))
If kol = l Then Debug.Print aa
Next aa
If l <= max Then Call Sort1(a, l + 1, max)
End Sub

megaloman · Отправлено: **21:12, 05-01-2020** | #4

не по алфавиту, а по директориям

Код:

FileIn = "Z:\Box_In\filein.txt"
FileOut = "Z:\Box_Out\fileout.txt"

Set FSO = CreateObject("Scripting.FileSystemObject")

On Error Resume Next

With FSO.OpenTextFile(FileIn, 1, False)
    If Err.Number <> 0 Then
        MsgBox "File   " + FileIn + vbCrLf + Err.Description + "(" + CStr(Err.Number) + ")"
        WScript.Quit 2
    End If
    On Error GoTo 0

    Alls = Split(.ReadAll, vbCrLf)
    .Close
End With

N = -1
ND = -1
NF = -1
For Each s In Alls
    N = N + 1
    s = Trim(s)
    Alls(N) = s
    If Len(s) <> 0 Then
        If Right(s, 1) = "\" Then ND = ND + 1 Else NF = NF + 1
    End If
Next

ReDim MasD(ND), MasF(NF)
jD = -1
jF = -1
For i = 0 To N
    s = Alls(i)
    If Len(s) <> 0 Then
        If Right(s, 1) = "\" Then
            jD = jD + 1
            MasD(jD) = Replace(LCase(Alls(i)), "\", Chr(0))
        Else
            jF = jF + 1
            MasF(jF) = Replace(LCase(Alls(i)), "\", Chr(0))
        End If
    End If
Next
Set Alls = Nothing

For i = 0 To ND
    For j = i To ND
        If MasD(i) < MasD(j) Then
            s = MasD(i)
            MasD(i) = MasD(j)
            MasD(j) = s
        End If
    Next
Next

For i = 0 To NF
    For j = i To NF
        If MasF(i) < MasF(j) Then
            s = MasF(i)
            MasF(i) = MasF(j)
            MasF(j) = s
        End If
    Next
Next

out = ""
For i = 0 To ND
    D = MasD(i)
    For j = 0 To NF
        If InStr(1, MasF(j), D) <> 0 Then
            out = MasF(j) + vbCrLf + out
            MasF(j) = ""
        End If
    Next
    out = D + vbCrLf + out
Next

For j = 0 To NF
    If MasF(j) <> "" Then out = MasF(j) + vbCrLf + out
Next
out = Replace(out, Chr(0), "\")
'MsgBox out  '''''''''''''''''''''''

With FSO.CreateTextFile(FileOut, True)
    .Write out
    .Close
End With
MsgBox "Done"

Пути пропишИте свои

shadowbat · Отправлено: **22:31, 05-01-2020** | #5

megaloman, работает
замена "\" на Chr(0) изящная, действительно AscW("\") мешает сравнивать строки, т.к. у него номер ниже/выше чем у алфавита
а также выдаёт все строки в LCase регистре, что всё-таки является изменением, а не только сортировкой (понимаю, что без LCase сортировка в текущем виде не сработает, но факт остается фактом - после этой функции нужно производить дальнейшие действия со строками только в нижнем регистре, либо дополнительно восстанавливать изначальный регистр после функции)

Iska · Отправлено: **01:43, 06-01-2020** | #6

shadowbat, а можете рассказать, для чего Вам потребен список именно в таком виде?

shadowbat · Отправлено: **02:48, 06-01-2020** | #7

Цитата Iska:

для чего Вам потребен список именно в таком виде? »

в сортированном? для сравнения директорий, которым частично принадлежат те или иные строки

Iska · Отправлено: **03:12, 06-01-2020** | #8

shadowbat, спасибо, ясно.

shadowbat · Отправлено: **03:52, 06-01-2020** | #9

Цитата megaloman:

не по алфавиту, а по директориям »

добавил восстановление регистра, только нужно закоментить 'Set Alls = Nothing
подразумевается, что изначально в строках не было разнорегистровых дублей, иначе оба дубля получат одинаковый регистр (либо нижний либо изначальный)
исправил лишнее добавление пустой строки в конце нового файла
добавить после MsgBox out: и сохранение в файл соответственно заменить на out3

Код:

out2 = Split(out, vbCrLf)
For i = LBound(out2) To UBound(out2)
For j = LBound(Alls) To UBound(Alls)
If out2(i) = LCase(Alls(j)) Then out2(i) = Alls(j)
Next j
Next i
For i = LBound(out2) To UBound(out2) - 1
If out3 = "" Then out3 = out2(i) Else out3 = out3 + vbCrLf + out2(i)
Next
'MsgBox out3

megaloman · Отправлено: **09:45, 06-01-2020** | #10

Цитата shadowbat:

добавил восстановление регистра ... исправил лишнее добавление пустой строки »

Вариант, где этого делать не надо. Не думал, что регистр в путях имеет какое-то значение

Код:

FileIn = "Z:\Box_In\filein.txt"
FileOut = "Z:\Box_Out\fileout.txt"

Set FSO = CreateObject("Scripting.FileSystemObject")

On Error Resume Next

With FSO.OpenTextFile(FileIn, 1, False)
    If Err.Number <> 0 Then
        MsgBox "File   " + FileIn + vbCrLf + Err.Description + "(" + CStr(Err.Number) + ")"
        WScript.Quit 2
    End If
    On Error GoTo 0

    Alls = Split(.ReadAll, vbCrLf)
    .Close
End With

N = -1
ND = -1
NF = -1
For Each s In Alls
    N = N + 1
    s = Trim(s)
    Alls(N) = s
    If Len(s) <> 0 Then
        If Right(s, 1) = "\" Then ND = ND + 1 Else NF = NF + 1
    End If
Next

ReDim MasD(ND), MasF(NF)
jD = -1
jF = -1
For i = 0 To N
    s = Alls(i)
    If Len(s) <> 0 Then
        If Right(s, 1) = "\" Then
            jD = jD + 1
            MasD(jD) = Replace(Alls(i), "\", Chr(0))
        Else
            jF = jF + 1
            MasF(jF) = Replace(Alls(i), "\", Chr(0))
        End If
    End If
Next
Set Alls = Nothing

Call SortMas(MasD, ND)
Call SortMas(MasF, NF)

out = ""
For i = 0 To ND
    D = LCase(MasD(i))
    For j = 0 To NF
        If InStr(1, LCase(MasF(j)), D) <> 0 Then
            If out = "" Then out = MasF(j) Else out = MasF(j) + vbCrLf + out
            MasF(j) = ""
        End If
    Next
    If out = "" Then out = MasD(i) Else out = MasD(i) + vbCrLf + out
Next

For j = 0 To NF
    If MasF(j) <> "" Then out = MasF(j) + vbCrLf + out
Next
out = Replace(out, Chr(0), "\")
'MsgBox out  '''''''''''''''''''''''

With FSO.CreateTextFile(FileOut, True)
    .Write out
    .Close
End With
MsgBox "Done"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''End

Sub SortMas(Mas, NMas)
    For i = 0 To NMas
        s = LCase(Mas(i))
        For j = i To NMas
            ss = LCase(Mas(j))
            If s < ss Then
                s = Mas(i)
                Mas(i) = Mas(j)
                Mas(j) = s
                s = LCase(Mas(i))
            End If
        Next
    Next
End Sub