Скрипт синхронизации файлов (зеркалирования)

@testuser2 · Регистрация: 08.02.2017

Студворк — интернет-сервис помощи студентам

Продолжая тему данного повествования, решил перенести топег в более общий раздел, дабы не засорять профильный своим "белым шумом". Промежуточный итог - скрипт ищущий папки-клоны в заданной дирректории (MainPt) и выводящий их в текстовй файл CloneFold.txt в локации скрипта.
Что в нем не доработано это обход ошибок fso, еще некоторые мелочи, ну и качество выводимого результата конечно под вопросом. Проверить, в принципе, можно сделав подобный скрипт, но с использованием md5-хэширования..

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
dim MainPt, CollFolHashes, CollEmpFol, CollFolClones1, CollFolClones2, fldcount, flcount, WritetxtPt
 
MainPt="E:\Programms"
'WritetxtPt="C:\Users\User\Desktop\VBS\CloneFold.txt"
 
Set FSO = CreateObject("Scripting.FileSystemObject")
WritetxtPt=Fso.GetParentFolderName(WScript.ScriptFullName)&"\CloneFold.txt"
 
Set CollEmpFol=CreateObject("Scripting.Dictionary") 'коллекция пустых папок
Set CollFolHashes=CreateObject("Scripting.Dictionary") 'коллекция контрольных сумм для каждой папки
Set CollFolClones1=CreateObject("Scripting.Dictionary") 'коллекция папок-клонов (с учетом вложенности)
Set CollFolClones2=CreateObject("Scripting.Dictionary") 'коллекция папок-клонов (без учета вложенности)
 
Old_Time = Timer
'Основная функция
ScanFl FSO.GetFolder(MainPt), CollFolClones1, 0
'Реверс значения->ключи, ключи->значения коллекции контр. сумм
For each elem in CollFolHashes
    b=CollFolHashes.item(elem)
    CollFolHashes.key(elem)=b
    CollFolHashes.item(b)=elem
next
'Вторая функция - повторный рекурсивный проход подпапок с исключением вложенных клонов
FndCloneFol FSO.GetFolder(MainPt), 0
Time_Elapsed = Timer - Old_Time 'Подсчет времени выполнения скрипта
'Вывод итогов на экран
MsgBox fldcount&" папок, "&flcount&" файлов"&vbcrlf&"Затрачено времени "&Time_Elapsed&vbcrlf&"Колличество папок-клонов (с учетом вложенности) "&CollFolClones1.count&vbcrlf&"Без учета вложенности "&CollFolClones2.count&vbcrlf&"Пустых папок (без учета вложенности) "&CollEmpFol.count
 
'Вывод в текстовые файлы
Dim Arr(), n, str
n=0
For Each elem in CollFolClones2
    Redim preserve Arr(n)
    Arr(n)=join(CollFolClones2(elem).keys,vbCrlf)&vbCrlf
    n=n+1
next
str="Папки-клоны ("&CollFolClones2.count&" шт.)"&vbcrlf&join(Arr,vbcrlf)
'msgbox str
str2="Пустые папки ("&CollEmpFol.count&" шт.)"&vbcrlf&join(CollEmpFol.keys,vbcrlf)
'msgbox str2
str=str&vbcrlf&vbcrlf&str2
set OFile2 = FSO.OpenTextFile(WritetxtPt, 2, True)
OFile2.Write(str)
OFile2.Close
 
function ScanFl(Folder, CollFolClones, sel)
    'On Error Resume Next
    Dim datestr, dateArr(), loccnt
    datestr="\_"
    fldcount=fldcount+1
    if Folder.size=0 or Err Then
        if err then MsgBox Folder.path&vbcrlf&"!!!ОШИБКА "&Err.Description & vbCrlf & Err.HelpContext & vbCrlf & Err.HelpFile & vbCrlf&"Err number "& Err.Number & vbCrlf & Err.Source end if
        Err.Clear
        CollEmpFol.add Folder.path, ""
        if CollEmpFol.exists(MainPt) then 
            msgbox "CollEmpFol(MainPt) "&CollEmpFol.item(MainPt)&" "&CollEmpFol.exists(MainPt)&vbcrlf&fldcount 
        end if
    else    
        if not Folder.files.count=0 and sel=1 Then
            For Each file in Folder.Files
                redim preserve dateArr(loccnt)
                dateArr(loccnt)=file.dateLastModified
                loccnt=loccnt+1
                flcount=flcount+1
            next
        end if
        For Each Subfolder in Folder.SubFolders 
            redim preserve dateArr(loccnt)
            'Рекурсивно вызываем функцию для перебора подпапок     
            dateArr(loccnt)=ScanFl(Subfolder, CollFolClones, 1)
            loccnt=loccnt+1
        Next    
        if sel=1 then
            datestr=datestr&replace(replace(replace(join(dateArr,""),".",""),":","")," ","")&Folder.size
            if CollFolClones.exists(datestr) Then
                CollFolClones.item(datestr).add Folder.path, ""
            elseif CollFolHashes.exists(datestr) Then
                CollFolClones.add datestr, CreateObject("Scripting.Dictionary")
                CollFolClones.item(datestr).add CollFolHashes.item(datestr), ""
                CollFolClones.item(datestr).add Folder.path, ""
            else
                CollFolHashes.add datestr, Folder.path
            end if
            ScanFl=datestr
        end if                  
    end if
End function
 
Sub FndCloneFol (Folder, sel)
    Dim flhash
    if not CollEmpFol.exists(Folder.path) then
        if sel=1 then
            flhash=CollFolHashes.item(Folder.path)
            if CollFolClones1.exists(flhash) then               
                CollFolClones2.add flhash, CollFolClones1.item(flhash)
            else
                For Each Subfolder in Folder.SubFolders 
                    FndCloneFol Subfolder, 1
                Next
            end if
        else
            For Each Subfolder in Folder.SubFolders 
                FndCloneFol Subfolder, 1
            Next
        end if
        
    end if
End sub

@testuser2 · 24.01.2020, 15:09 **[ТС]**

Переработал этот скрипт на парсин потоковой выдачи (stdOut) команды dir. Работает более быстро, и главное более безотказно. Одна ошибка, не связанная с моей оплошностью, все-таки проскакивала, но связана была с особенностью выдачи командой инфы о скрытых папках, - показывает подпапку, обходя ее родителя. Но проблемма успешно решилась добавлением ключа /a в команду. Думаю еще добавить подсчет размера "клонов".

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
Dim fldpt, flname, a, cnt, flcnt, sel
Set FSO = CreateObject("Scripting.FileSystemObject")
WritetxtPt=Fso.GetParentFolderName(WScript.ScriptFullName)&"\folderreport.txt"
Crdict CollFol 'основная коллекция попок
Crdict CollEmpFol 'коллекция всех папок с нулевым размером
Crdict EmptyFinal 'коллекция нулевых папок без вложенных в них
Crdict Junctions 'точки монтирования
Crdict FoldHashes 'контрольные суммы
Crdict FoldClones 'папки-клоны с учетом в них вложенных
Crdict ClonesFinal '-\- без учета вложенности
sub Crdict(name)
    set name=CreateObject("Scripting.Dictionary")
end sub
Dialog Path1'окно выбора папки
'msgbox Path1
'Path1="C:\Users\User\Documents"
Old_Time = Timer 'запуск таймера
'Получение списка папок и файлов из выдачи (stdout) консольной комманды dir
Stext=CreateObject("WScript.Shell").exec("cmd /c >nul chcp 1251 &&dir/s/o/a """&Path1&""" |findstr/p . |findstr/v ""<DIR>""").stdout.readall
ArrTxt=split(Stext,vbcrlf)
cnt = 2
'Парсинг и наполнение основных коллекций
do until cnt=UBound(ArrTxt)-3
    str=ArrTxt(cnt) 
    if mid(str,2,6)="Содерж" then 
        foldpt=Mid(str,19)
        flcnt=0     
        Set CollFol(foldpt)=new FoldCl
        CollFol(foldpt).crdict 'создание коллекции "subfolders" в классе "FoldCl"
        if sel then 
            'Добавление папки в коллекцию (создание ссылки) "subfolders" родительской папки.
            set CollFol(left(foldpt,instrRev(foldpt,"\")-1)).subfolders(foldpt)=CollFol(foldpt)
        end if      
        foldptold=foldpt
        sel=true 
    elseif mid(str,18,6)="файлов" then 
        CollFol(foldpt).size1=mid(str,24,15)
    else if mid(str,22,10)="<JUNCTION>" then
            a=Instr(38,str,"[")+1
            flpt=foldpt&"\"&mid(str,37,Instr(38,str,"[")-38)
            Junctions(flpt)=mid(str,a,Len(str)-a)
        end if
        flcnt=flcnt+1
        CollFol(foldpt).res(flcnt) 'функция увеличения размера массива "flhash" класса "FoldCl"
        CollFol(foldpt).flhash(flcnt)=left(str,17)
    end if
    i=i+1
    cnt=cnt+1
Loop
Recurs1 CollFol(Path1),Path1,"",0
Recurs2 CollFol(Path1),Path1
Time_Elapsed=Timer-Old_Time '
 
'Вывод итогов в диалоговое окно
fullsize=Mid(ArrTxt(UBound(ArrTxt)-2),24,16)
msgbox left(ArrTxt(UBound(ArrTxt)-1),16)*1&" папок, "&left(ArrTxt(UBound(ArrTxt)-2),16)*1&" файлов, размер "&fullsize*1&" байт"&vbcrlf&vbcrlf&"Папок-клонов (групп) без учета вложенности "&ClonesFinal.count&vbcrlf&"Пустых папок без учета вложенности "&EmptyFinal.count&vbcrlf&vbcrlf&"Папок-клонов (групп) всего "&FoldClones.count&vbCrlf&"Папок с нулевым размером всего "&CollEmpFol.count&vbcrlf&vbcrlf&"Точек монтирования "&Junctions.count&vbcrlf&vbcrlf&"Затрачено времени " &Time_Elapsed
 
'Вывод в текстовые файлы
Dim Arr(), n, str1, str2, str3, StrFinal, OFile
n=0
For Each elem in ClonesFinal
    Redim preserve Arr(n)
    Arr(n)=join(ClonesFinal(elem).keys,vbCrlf)&vbCrlf
    n=n+1
next
 
str0=Path1&": "&left(ArrTxt(UBound(ArrTxt)-1),16)*1&" папок, "&left(ArrTxt(UBound(ArrTxt)-2),16)*1&" файлов, размер "&fullsize*1&" байт ("&round(fullsize/1073741824,2)&" гб.)"
str1="Папки-клоны ("&ClonesFinal.count&" групп)"&vbcrlf&join(Arr,vbcrlf)
'msgbox str
n=0
Redim Arr(0)
For Each elem in Junctions
    Redim preserve Arr(n)
    Arr(n)=elem&vbcrlf&"["&Junctions(elem)&"]"
    n=n+1
next
ln="============================================================="
str2=ln&vbcrlf&"Точки монтирования ("&Junctions.count&" шт.)"&vbcrlf&join(Arr,vbcrlf)
'msgbox str2
n=0
Redim Arr(0)
For Each elem in EmptyFinal
    Redim preserve Arr(n)
    Arr(n)=elem&vbcrlf&replace(EmptyFinal(elem),"\0","\_")
    n=n+1
next
str3=ln&vbcrlf&"Пустые папки и их структура (колличество) вложенности ("&EmptyFinal.count&" шт.)"&vbcrlf&join(Arr,vbcrlf)
StrFinal=str0&vbcrlf&ln&vbcrlf&str1&vbcrlf&str2&vbcrlf&str3
 
set OFile = FSO.OpenTextFile(WritetxtPt, 2, True)
OFile.Write(StrFinal) 'Запись отчета в текстовый файл
OFile.Close
 
Set oShell = CreateObject("WScript.Shell")
oShell.Run WritetxtPt 'Запуск текстового файла с отчетом
 
'КОНЕЦ!!!
 
'--------------------Классы---------------------------
Class FoldCl
    dim size, size1, files, subfolders, flhash(), hash
    sub crdict
        Redim preserve flhash(0)
        flhash(0)="\"  '!!!!!!
        set files=CreateObject("Scripting.Dictionary")
        set subfolders=CreateObject("Scripting.Dictionary")
    End sub
    sub res(x)
        Redim preserve flhash(x)
    End sub
End Class
 
Class FlCl
    dim size, dat
End Class
 
Class Junc
    dim dat, link
End Class
 
'--------------------Функции---------------------------
Sub Recurs1(FoldObj,folpt,hash,size)
    dim subhash, n, chksums(), str, sumsize, subsize
    n=0
    sumsize=0
    For each elem in FoldObj.subfolders     
        Redim preserve chksums(n)
        Recurs1 FoldObj.subfolders(elem),elem,subhash,subsize   
        FoldObj.subfolders(elem).hash=subhash
        CollFol(elem).size=subsize 'эквивалентно FoldObj.subfolders(elem).hash=subsize
        chksums(n)=subhash
        if subsize=0 then 
            CollEmpFol(elem)=subhash 
        elseif FoldHashes.exists(subhash) Then
            if not FoldClones.exists(subhash) then 
                set FoldClones(subhash)=CreateObject("Scripting.Dictionary")
                FoldClones(subhash)(FoldHashes(subhash))=""
            end if
            FoldClones(subhash)(elem)=""
        else
            FoldHashes(subhash)=elem
        end if
        sumsize=sumsize+subsize 
        n=n+1
    next
    str=replace(replace(replace(join(FoldObj.flhash,""),".",""),":","")&FoldObj.size1," ","")
    hash=str&join(chksums,"")
    size=FoldObj.size1+sumsize  
end sub
 
Sub Recurs2(FoldObj, folpt) 
    For Each elem in FoldObj.subfolders
        if CollEmpFol.exists(elem) then 
            EmptyFinal(elem)=CollEmpFol(elem)
        elseif FoldClones.exists(CollFol(elem).hash) then           
            set ClonesFinal(CollFol(elem).hash)=FoldClones(CollFol(elem).hash)
        elseif Junctions.exists(elem) then
        else Recurs2 FoldObj.subfolders(elem),elem
        end if
    next    
End sub
 
Sub Dialog(objPath)
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "Выбор папки", 0)
    If objFolder Is Nothing Then Wscript.Quit
    objPath = objFolder.Self.Path
End sub

@testuser2 · 25.01.2020, 11:00 **[ТС]**

Добавил размеры суммарные размеры папок-клонов и их сортировку их групп по этим размерам. Еще надо бы откинуть папки с нулевыми файлами из списка пустых папок.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
Dim fldpt, flname, a, cnt, flcnt, sel
Set FSO = CreateObject("Scripting.FileSystemObject")
WritetxtPt=Fso.GetParentFolderName(WScript.ScriptFullName)&"\folderreport.txt"
Crdict CollFol 'основная коллекция попок
Crdict CollEmpFol 'коллекция всех папок с нулевым размером
Crdict EmptyFinal 'коллекция нулевых папок без вложенных в них
Crdict Junctions 'точки монтирования
Crdict FoldHashes 'контрольные суммы
Crdict FoldClones 'папки-клоны с учетом в них вложенных
Crdict ClonesFinal '-\- без учета вложенности
sub Crdict(name)
    set name=CreateObject("Scripting.Dictionary")
end sub
Dialog Path1'окно выбора папки
'msgbox Path1
'Path1="C:\Users\User\Documents"
Old_Time = Timer 'запуск таймера
'Получение списка папок и файлов из выдачи (stdout) консольной комманды dir
Stext=CreateObject("WScript.Shell").exec("cmd /c >nul chcp 1251 &&dir/s/o/a """&Path1&""" |findstr/p . |findstr/v ""<DIR>""").stdout.readall
ArrTxt=split(Stext,vbcrlf)
cnt = 2
'Парсинг и наполнение основных коллекций
do until cnt=UBound(ArrTxt)-3
    str=ArrTxt(cnt) 
    if mid(str,2,6)="Содерж" then 
        foldpt=Mid(str,19)
        flcnt=0     
        Set CollFol(foldpt)=new FoldCl
        CollFol(foldpt).crdict 'создание коллекции "subfolders" в классе "FoldCl"
        if sel then 
            'Добавление папки в коллекцию (создание ссылки) "subfolders" родительской папки.
            set CollFol(left(foldpt,instrRev(foldpt,"\")-1)).subfolders(foldpt)=CollFol(foldpt)
        end if      
        foldptold=foldpt
        sel=true 
    elseif mid(str,18,6)="файлов" then 
        CollFol(foldpt).size1=mid(str,24,15)
    else if mid(str,22,10)="<JUNCTION>" then
            a=Instr(38,str,"[")+1
            flpt=foldpt&"\"&mid(str,37,Instr(38,str,"[")-38)
            Junctions(flpt)=mid(str,a,Len(str)-a)
        end if
        flcnt=flcnt+1
        CollFol(foldpt).res(flcnt) 'функция увеличения размера массива "flhash" класса "FoldCl"
        CollFol(foldpt).flhash(flcnt)=left(str,17)
    end if
    i=i+1
    cnt=cnt+1
Loop
Recurs1 CollFol(Path1),Path1,"",0
Recurs2 CollFol(Path1),Path1
Time_Elapsed=Timer-Old_Time '
 
'Вывод итогов в диалоговое окно
fullsize=Mid(ArrTxt(UBound(ArrTxt)-2),25,15)
msgbox left(ArrTxt(UBound(ArrTxt)-1),16)*1&" папок, "&left(ArrTxt(UBound(ArrTxt)-2),16)*1&" файлов, размер "&fullsize&" байт ("&round(fullsize/1073741824,2)&" гб.)"&vbcrlf&vbcrlf&"Папок-клонов (групп) без учета вложенности "&ClonesFinal.count&vbcrlf&"Пустых папок без учета вложенности "&EmptyFinal.count&vbcrlf&vbcrlf&"Папок-клонов (групп) всего "&FoldClones.count&vbCrlf&"Папок с нулевым размером всего "&CollEmpFol.count&vbcrlf&vbcrlf&"Точек монтирования "&Junctions.count&vbcrlf&vbcrlf&"Затрачено времени " &Time_Elapsed
 
'Подготовка и вывод списков в текстовые файлы
Dim Arr(), ArrSz, n, str0, str1, str2, str3, StrFinal, OFile, SumSz
SumSz=0
if ClonesFinal.count then
    n=0 
    For Each elem in ClonesFinal
        Redim preserve Arr(n)   
        ArrSz=ClonesFinal(elem).items
        j=ArrSz(0)
        k=ClonesFinal(elem).count-1
        sz=j*k
        SumSz=SumSz+sz
        Arr(n)=sz&" "&j&" * "&k&" = "&sz&" байт ("&round(sz/1048576,2)&" мб)"&vbCrlf&join(ClonesFinal(elem).keys,vbCrlf)&vbCrlf
        n=n+1
    next
    'Cортировка массива
    for a = UBound(Arr) - 1 To 0 Step -1
        for j= 0 to a
            'if Arr(j)(0)<Arr(j+1)(0) then
            if left(Arr(j),instr(Arr(j)," ")-1)*1<left(Arr(j+1),instr(Arr(j+1)," ")-1)*1 then
                temp=Arr(j+1)
                Arr(j+1)=Arr(j)
                Arr(j)=temp
            end if
        next
    next
    For i=0 to UBound(Arr)  
        Arr(i)=Mid(Arr(i),instr(Arr(i)," ")+1)
    next
end if
str0=Path1&": "&left(ArrTxt(UBound(ArrTxt)-1),16)*1&" папок, "&left(ArrTxt(UBound(ArrTxt)-2),16)*1&" файлов, размер "&fullsize*1&" байт ("&round(fullsize/1073741824,2)&" гб.)"
str1="Папки-клоны ("&ClonesFinal.count&" групп, общий занимаемый дублями размер "&SumSz&" байт ("&round(SumSz/1073741824,2)&" гб.)"&vbcrlf&join(Arr,vbcrlf)
'msgbox str
n=0
Redim Arr(0)
For Each elem in Junctions
    Redim preserve Arr(n)
    Arr(n)=elem&vbcrlf&"["&Junctions(elem)&"]"
    n=n+1
next
ln="============================================================="
str2=ln&vbcrlf&"Точки монтирования ("&Junctions.count&" шт.)"&vbcrlf&join(Arr,vbcrlf)
'msgbox str2
n=0
Redim Arr(0)
For Each elem in EmptyFinal
    Redim preserve Arr(n)
    Arr(n)=elem&vbcrlf&replace(EmptyFinal(elem),"\0","\_")
    n=n+1
next
str3=ln&vbcrlf&"Пустые папки и их структура (колличество) вложенности ("&EmptyFinal.count&" шт.)"&vbcrlf&join(Arr,vbcrlf)
StrFinal=str0&vbcrlf&vbcrlf&ln&vbcrlf&str1&vbcrlf&str2&vbcrlf&vbcrlf&str3
 
set OFile = FSO.OpenTextFile(WritetxtPt, 2, True)
OFile.Write(StrFinal) 'Запись отчета в текстовый файл
OFile.Close
 
Set oShell = CreateObject("WScript.Shell")
oShell.Run WritetxtPt 'Запуск текстового файла с отчетом
 
'КОНЕЦ!!!
 
'--------------------Классы---------------------------
Class FoldCl
    dim size, size1, files, subfolders, flhash(), hash
    sub crdict
        Redim preserve flhash(0)
        flhash(0)="\"  '!!!!!!
        set files=CreateObject("Scripting.Dictionary")
        set subfolders=CreateObject("Scripting.Dictionary")
    End sub
    sub res(x)
        Redim preserve flhash(x)
    End sub
End Class
 
Class FlCl
    dim size, dat
End Class
 
Class Junc
    dim dat, link
End Class
 
'--------------------Функции---------------------------
Sub Recurs1(FoldObj,folpt,hash,size)
    dim subhash, n, chksums(), str, sumsize, subsize
    n=0
    sumsize=0
    For each elem in FoldObj.subfolders     
        Redim preserve chksums(n)
        Recurs1 FoldObj.subfolders(elem),elem,subhash,subsize   
        FoldObj.subfolders(elem).hash=subhash
        CollFol(elem).size=subsize 'эквивалентно FoldObj.subfolders(elem).hash=subsize      
        chksums(n)=subhash
        if subsize=0 then 
            CollEmpFol(elem)=subhash 
        elseif FoldHashes.exists(subhash) Then
            if not FoldClones.exists(subhash) then 
                set FoldClones(subhash)=CreateObject("Scripting.Dictionary")
                FoldClones(subhash)(FoldHashes(subhash))=subsize
            end if
            'FoldClones(subhash)(elem)=""
            FoldClones(subhash)(elem)=subsize
        else
            FoldHashes(subhash)=elem
        end if
        sumsize=sumsize+subsize 
        n=n+1
    next    
    str=replace(replace(replace(join(FoldObj.flhash,""),".",""),":","")&FoldObj.size1," ","")
    hash=str&join(chksums,"")
    size=FoldObj.size1+sumsize  
end sub
 
Sub Recurs2(FoldObj, folpt) 
    For Each elem in FoldObj.subfolders     
        if CollEmpFol.exists(elem) then 
            EmptyFinal(elem)=CollEmpFol(elem)
        elseif FoldClones.exists(CollFol(elem).hash) then           
            set ClonesFinal(CollFol(elem).hash)=FoldClones(CollFol(elem).hash)
        elseif Junctions.exists(elem) then
        else Recurs2 FoldObj.subfolders(elem),elem
        end if
    next    
End sub
 
Sub Dialog(objPath)
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "Выбор папки", 0)
    If objFolder Is Nothing Then Wscript.Quit
    objPath = objFolder.Self.Path
End sub

Code
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
E:\Программы: 39386 папок, 11205 файлов, размер 9120275131 байт (8,49 гб.)
 
=============================================================
Папки-клоны (951 групп, общий занимаемый дублями размер 3221765834 байт (3 гб.)
1067219072 * 2 = 2134438144 байт (2035,56 мб)
E:\Программы\FirefoxPortable63.0x64\cache2
E:\Программы\FirefoxPortable63.0x64 — копия - копия\cache2
E:\Программы\FirefoxPortable63.0x64copy\cache2
 
341210053 * 1 = 341210053 байт (325,4 мб)
E:\Программы\FirefoxPortable63.0x64 — копия - копия\App
E:\Программы\FirefoxPortable63.0x64copy\App
 
134209770 * 2 = 268419540 байт (255,98 мб)
E:\Программы\FirefoxPortable63.0x64\App\Firefox
E:\Программы\FirefoxPortable63.0x64 — копия - копия\App\Firefox
E:\Программы\FirefoxPortable63.0x64copy\App\Firefox
***

Добавлено через 24 минуты
Впервые рискнул сканернуть целый диск, но скрипт ругнулся на 32 строку, в принципе, подобное уже было из-за скрытых папок, наверное опять что-то скрытое/системное и т.п. Но, думаю, знаю как исправить..

@testuser2 · 25.01.2020, 12:27 **[ТС]**

Да, кстати, надо исключить все эти ресеклы

@testuser2 · 25.01.2020, 14:45 **[ТС]**

Сообщение от testuser2

Еще надо бы откинуть папки с нулевыми файлами

Сделал

Сообщение от testuser2

скрипт ругнулся на 32 строку

Устранил.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
Dim fldpt, flname, a, cnt, flcnt, sel
Set FSO = CreateObject("Scripting.FileSystemObject")
WritetxtPt=Fso.GetParentFolderName(WScript.ScriptFullName)&"\folderreport.txt"
Crdict CollFol 'основная коллекция попок
Crdict CollEmpFol 'коллекция всех папок с нулевым размером
Crdict EmptyFinal 'коллекция нулевых папок без вложенных в них
Crdict Junctions 'точки монтирования
Crdict FoldHashes 'контрольные суммы
Crdict FoldClones 'папки-клоны с учетом в них вложенных
Crdict ClonesFinal '-\- без учета вложенности
sub Crdict(name)
    set name=CreateObject("Scripting.Dictionary")
end sub
Dialog Path1'окно выбора папки
'Path1="C:\Users\User\Documents"
Old_Time = Timer 'запуск таймера
'Получение списка папок и файлов из выдачи (stdout) консольной комманды dir
Stext=CreateObject("WScript.Shell").exec("cmd /c >nul chcp 1251 &&dir/s/o/a """&Path1&""" |findstr/p . |findstr/v ""<DIR>""").stdout.readall
ArrTxt=split(Stext,vbcrlf)
cnt = 2
if mid(Path1,len(path1))="\" then Path1=left(Path1,len(Path1)-1) end if
Set CollFol(Path1)=new FoldCl
CollFol(Path1).crdict
'Парсинг и наполнение основных коллекций
do until cnt=UBound(ArrTxt)-3
    str=ArrTxt(cnt) 
    if mid(str,2,6)="Содерж" then 
        foldpt=Mid(str,19)
        flcnt=0     
        Set CollFol(foldpt)=new FoldCl
        CollFol(foldpt).crdict 'создание коллекции "subfolders" в классе "FoldCl"
        if sel then 
            'Добавление папки в коллекцию (создание ссылки) "subfolders" родительской папки.            
            set CollFol(left(foldpt,instrRev(foldpt,"\")-1)).subfolders(foldpt)=CollFol(foldpt)                     
        end if      
        foldptold=foldpt
        sel=true 
    elseif mid(str,18,6)="файлов" then 
        CollFol(foldpt).size1=mid(str,24,15)
    else if mid(str,22,10)="<JUNCTION>" then
            a=Instr(38,str,"[")+1
            flpt=foldpt&"\"&mid(str,37,Instr(38,str,"[")-38)
            Junctions(flpt)=mid(str,a,Len(str)-a)
        end if
        flcnt=flcnt+1
        CollFol(foldpt).res(flcnt) 'функция увеличения размера массива "flhash" класса "FoldCl"
        CollFol(foldpt).flhash(flcnt)=left(str,17)
    end if
    i=i+1
    cnt=cnt+1
Loop
Recurs1 CollFol(Path1),Path1,"",0
Recurs2 CollFol(Path1),Path1
Time_Elapsed=Timer-Old_Time '
 
'Вывод итогов в диалоговое окно
fullsize=Mid(ArrTxt(UBound(ArrTxt)-2),25,15)
msgbox left(ArrTxt(UBound(ArrTxt)-1),16)*1&" папок, "&left(ArrTxt(UBound(ArrTxt)-2),16)*1&" файлов, размер "&fullsize&" байт ("&round(fullsize/1073741824,2)&" гб.)"&vbcrlf&vbcrlf&"Папок-клонов (групп) без учета вложенности "&ClonesFinal.count&vbcrlf&"Пустых папок без учета вложенности "&EmptyFinal.count&vbcrlf&vbcrlf&"Папок-клонов (групп) всего "&FoldClones.count&vbCrlf&"Пустых папок всего "&CollEmpFol.count&vbcrlf&vbcrlf&"Точек монтирования "&Junctions.count&vbcrlf&vbcrlf&"Затрачено времени " &Time_Elapsed
 
'Подготовка и вывод списков в текстовые файлы
Dim Arr(), ArrSz, n, str0, str1, str2, str3, StrFinal, OFile, SumSz
SumSz=0
if ClonesFinal.count then
    n=0 
    For Each elem in ClonesFinal
        Redim preserve Arr(n)   
        ArrSz=ClonesFinal(elem).items
        j=ArrSz(0)
        k=ClonesFinal(elem).count-1
        sz=j*k
        SumSz=SumSz+sz
        Arr(n)=sz&" "&j&" * "&k&" = "&sz&" байт ("&round(sz/1048576,2)&" мб)"&vbCrlf&join(ClonesFinal(elem).keys,vbCrlf)&vbCrlf
        n=n+1
    next
    'Cортировка массива
    for a = UBound(Arr) - 1 To 0 Step -1
        for j= 0 to a
            'if Arr(j)(0)<Arr(j+1)(0) then
            if left(Arr(j),instr(Arr(j)," ")-1)*1<left(Arr(j+1),instr(Arr(j+1)," ")-1)*1 then
                temp=Arr(j+1)
                Arr(j+1)=Arr(j)
                Arr(j)=temp
            end if
        next
    next
    For i=0 to UBound(Arr)  
        Arr(i)=Mid(Arr(i),instr(Arr(i)," ")+1)
    next
end if
str0=Path1&": "&left(ArrTxt(UBound(ArrTxt)-1),16)*1&" папок, "&left(ArrTxt(UBound(ArrTxt)-2),16)*1&" файлов, размер "&fullsize*1&" байт ("&round(fullsize/1073741824,2)&" гб.)"
str1="Папки-клоны ("&ClonesFinal.count&" групп, общий занимаемый папками-дублями размер "&SumSz&" байт ("&round(SumSz/1073741824,2)&" гб.)"&vbcrlf&join(Arr,vbcrlf)
'msgbox str
n=0
Redim Arr(0)
For Each elem in Junctions
    Redim preserve Arr(n)
    Arr(n)=elem&vbcrlf&"["&Junctions(elem)&"]"
    n=n+1
next
ln="============================================================="
str2=ln&vbcrlf&"Точки монтирования ("&Junctions.count&" шт.)"&vbcrlf&join(Arr,vbcrlf)
'msgbox str2
n=0
Redim Arr(0)
For Each elem in EmptyFinal
    Redim preserve Arr(n)
    Arr(n)=elem&vbcrlf&replace(EmptyFinal(elem),"\0","\_")
    n=n+1
next
str3=ln&vbcrlf&"Пустые папки и их структура (колличество) вложенности ("&EmptyFinal.count&" шт.)"&vbcrlf&join(Arr,vbcrlf)
StrFinal=str0&vbcrlf&vbcrlf&ln&vbcrlf&str1&vbcrlf&str2&vbcrlf&vbcrlf&str3
 
set OFile = FSO.OpenTextFile(WritetxtPt, 2, True)
OFile.Write(StrFinal) 'Запись отчета в текстовый файл
OFile.Close
 
Set oShell = CreateObject("WScript.Shell")
oShell.Run WritetxtPt 'Запуск текстового файла с отчетом
 
'КОНЕЦ!!!
 
'--------------------Классы---------------------------
Class FoldCl
    dim size, size1, files, subfolders, flhash(), hash
    sub crdict
        Redim preserve flhash(0)
        flhash(0)="\"  '!!!!!!
        set files=CreateObject("Scripting.Dictionary")
        set subfolders=CreateObject("Scripting.Dictionary")
    End sub
    sub res(x)
        Redim preserve flhash(x)
    End sub
End Class
 
Class FlCl
    dim size, dat
End Class
 
Class Junc
    dim dat, link
End Class
 
'--------------------Функции---------------------------
Sub Recurs1(FoldObj,folpt,hash,size)
    dim subhash, n, chksums(), str, sumsize, subsize
    n=0
    sumsize=0
    For each elem in FoldObj.subfolders     
        Redim preserve chksums(n)
        Recurs1 FoldObj.subfolders(elem),elem,subhash,subsize   
        FoldObj.subfolders(elem).hash=subhash
        CollFol(elem).size=subsize 'эквивалентно FoldObj.subfolders(elem).size=subsize      
        chksums(n)=subhash
        if subsize=0 then           
            CollEmpFol(elem)=subhash
        elseif FoldHashes.exists(subhash) Then
            if not FoldClones.exists(subhash) then 
                set FoldClones(subhash)=CreateObject("Scripting.Dictionary")
                FoldClones(subhash)(FoldHashes(subhash))=subsize
            end if
            'FoldClones(subhash)(elem)=""
            FoldClones(subhash)(elem)=subsize
        else
            FoldHashes(subhash)=elem
        end if
        sumsize=sumsize+subsize 
        n=n+1
    next    
    str=replace(replace(replace(join(FoldObj.flhash,""),".",""),":","")&FoldObj.size1," ","")
    hash=str&join(chksums,"")
    size=FoldObj.size1+sumsize  
end sub
 
Sub Recurs2(FoldObj, folpt) 
    For Each elem in FoldObj.subfolders     
        if CollEmpFol.exists(elem) then 
            if replace(CollEmpFol(elem),"\0","")="" then EmptyFinal(elem)=CollEmpFol(elem) end if           
        elseif FoldClones.exists(CollFol(elem).hash) then           
            set ClonesFinal(CollFol(elem).hash)=FoldClones(CollFol(elem).hash)
        elseif Junctions.exists(elem) then
        else Recurs2 FoldObj.subfolders(elem),elem
        end if
    next    
End sub
 
Sub Dialog(objPath)
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "Выбор папки", 0)
    If objFolder Is Nothing Then Wscript.Quit
    objPath = objFolder.Self.Path
End sub

@testuser2 · 26.01.2020, 05:51 **[ТС]**

Добавил ms5 хэширование строк стандартной библиотекой «capicom.dll», но по итогу, это только замедляет выполнение (148с против 10-30с) и нагружает процессор.

@testuser2 · 26.01.2020, 19:08 **[ТС]**

Добавил в сравнение имена файлов, упростил парсинг, работает быстрее и, главное, выше достоверность. Думаю уже ликвидный результат, с поиском клонов можно закончить, и что-нибудь думать по синхронизации.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
Dim fldpt, flname, a, cnt, flcnt, sel
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objHashedData = WScript.CreateObject("CAPICOM.HashedData")
objHashedData.Algorithm=CAPICOM_HASH_ALGORITHM_MD5
WritetxtPt=Fso.GetParentFolderName(WScript.ScriptFullName)&"\folderreportNew.txt"
Crdict CollFol 'основная коллекция папок
Crdict CollEmpFol 'коллекция всех папок с нулевым размером
Crdict EmptyFinal 'коллекция нулевых папок без вложенных в них
Crdict Junctions 'точки монтирования
Crdict FoldHashes 'контрольные суммы
Crdict FoldClones 'папки-клоны с учетом в вложенных
Crdict ClonesFinal '-\- без учета вложенности
sub Crdict(name)
    set name=CreateObject("Scripting.Dictionary")
end sub
 
Dialog Path1 'окно выбора папки
'Path1="C:\Users\User\Documents"
Old_Time = Timer 'запуск таймера
'Получение списка папок и файлов из выдачи (stdout) консольной комманды dir
'Stext=CreateObject("WScript.Shell").exec("cmd /c >nul chcp 1251 &&dir/s/o/a """&Path1&""" |findstr/p . |findstr/v ""<DIR>""").stdout.readall
Stext=CreateObject("WScript.Shell").exec("cmd /c >nul chcp 1251 &&dir/s/o/a """&Path1&""" |findstr/p . |findstr/v /e ""<DIR>........... <DIR>............""").stdout.readall
ArrTxt=split(Stext,vbcrlf)
'msgbox Stext
cnt = 2
if mid(Path1,len(path1))="\" then Path1=left(Path1,len(Path1)-1) end if
Set CollFol(Path1)=new FoldCl
CollFol(Path1).crdict
CollFol(Path1).flhash=""
'Парсинг
do until cnt=UBound(ArrTxt)-3
    str=ArrTxt(cnt) 
    if mid(str,2,6)="Содерж" then 
        foldpt=Mid(str,19)
        Set CollFol(foldpt)=new FoldCl 'создание элемента папки
        CollFol(foldpt).crdict
        if sel then 
            'Добавление папки в коллекцию (создание ссылки) "subfolders" родительской папки.
            set CollFol(left(foldpt,instrRev(foldpt,"\")-1)).subfolders(foldpt)=CollFol(foldpt)
        end if
        sel=true
    elseif mid(str,18,6)="файлов" then
        if CollFol(foldpt).flhash.count=0 then 
            CollFol(foldpt).flhash="\_"
            CollFol(foldpt).size1=0
        else            
            'CollFol(foldpt).flhash="\_"&GetMD5(replace(join(CollFol(foldpt).flhash.keys,"")," ",""))
            CollFol(foldpt).flhash="\_"&replace(join(CollFol(foldpt).flhash.items,"")," ","")
            CollFol(foldpt).size1=mid(str,24,15)*1
        end if
    elseif mid(str,22,5)="<DIR>" then 
        CollFol(foldpt).flhash(cnt)="*"
    else if mid(str,22,10)="<JUNCTION>" then
            flpt=foldpt&"\"&mid(str,37,Instr(38,str,"[")-38)
            Junctions(flpt)=mid(str,Instr(38,str,"["))
        end if
        CollFol(foldpt).flhash(cnt)=str
    end if
    cnt=cnt+1
Loop
 
'Устранение глюка с распознаванием "All Users" и "Все пользователи" отдельными папками
Disk=left(Path1,2)
if CollFol.exists(Disk&"\Users\All Users") then Junctions(Disk&"\Users\All Users")=Disk&"\ProgramData"
if CollFol.exists(Disk&"\Users\Все пользователи") then Junctions(Disk&"\Users\Все пользователи")=Disk&"\ProgramData"
 
Recurs1 CollFol(Path1),Path1,"",0
Recurs2 CollFol(Path1),Path1
 
'Подготовка и вывод итогов в диалоговое окно и в отчет
fullsize=Mid(ArrTxt(UBound(ArrTxt)-2),25,15)
Dim ArrClnSz, n, str0, str1, str2, str3, StrFinal, OFile, SumSz, var
SumSz=0
if ClonesFinal.count then   
    ArrClnSz=ClonesFinal.keys
    'Cортировка массива размеров групп клонов
    for a = UBound(ArrClnSz) - 1 To 0 Step -1
        for j= 0 to a
            if ArrClnSz(j)<ArrClnSz(j+1) then
                temp=ArrClnSz(j+1)
                ArrClnSz(j+1)=ArrClnSz(j)
                ArrClnSz(j)=temp
            end if
        next
    next
    n=0 
    For Each elem in ArrClnSz
        Redim preserve Arr(n)
        var=""
        For Each item in ClonesFinal(elem).items
            var=var&item&vbcrlf         
        next
        Arr(n)=var
        SumSz=SumSz+elem*ClonesFinal(elem).count        
        n=n+1
    next
    'msgbox join(Arr,vbcrlf)    
end if
Time_Elapsed=Timer-Old_Time
msgbox left(ArrTxt(UBound(ArrTxt)-1),16)*1&" папок, "&left(ArrTxt(UBound(ArrTxt)-2),16)*1&" файлов, размер "&fullsize&" байт ("&round(fullsize/1073741824,2)&" гб.)"&vbcrlf&vbcrlf&"Папок-клонов (групп) без учета вложенности "&ClonesFinal.count&vbcrlf&"Общий размер, занимаемый папками-дублями "&SumSz&" байт ("&round(SumSz/1073741824,2)&" гб.)"&vbcrlf&"Пустых папок без учета вложенности "&EmptyFinal.count&vbcrlf&vbcrlf&"Папок-клонов (групп) всего "&FoldClones.count&vbCrlf&"Пустых папок всего "&CollEmpFol.count&vbcrlf&vbcrlf&"Точек монтирования "&Junctions.count&vbcrlf&vbcrlf&"Затрачено времени " &Time_Elapsed
 
str0=Path1&": "&left(ArrTxt(UBound(ArrTxt)-1),16)*1&" папок, "&left(ArrTxt(UBound(ArrTxt)-2),16)*1&" файлов, размер "&fullsize*1&" байт ("&round(fullsize/1073741824,2)&" гб.)"
str1="Папки-клоны ("&ClonesFinal.count&" групп), общий занимаемый папками-дублями размер "&SumSz&" байт ("&round(SumSz/1073741824,2)&" гб.)"&vbcrlf&join(Arr,vbcrlf)
 
n=0
Redim Arr(0)
For Each elem in Junctions
    Redim preserve Arr(n)
    Arr(n)=elem&vbcrlf&Junctions(elem)
    n=n+1
next
ln="============================================================="
str2=ln&vbcrlf&"Точки монтирования ("&Junctions.count&" шт.)"&vbcrlf&join(Arr,vbcrlf)
'msgbox str2
n=0
Redim Arr(0)
For Each elem in EmptyFinal
    Redim preserve Arr(n)
    Arr(n)=elem&vbcrlf&EmptyFinal(elem)
    n=n+1
next
str3=ln&vbcrlf&"Пустые папки и их структура вложенности ("&EmptyFinal.count&" шт.)"&vbcrlf&join(Arr,vbcrlf)
StrFinal=str0&vbcrlf&vbcrlf&ln&vbcrlf&str1&vbcrlf&str2&vbcrlf&vbcrlf&str3
 
set OFile = FSO.OpenTextFile(WritetxtPt, 2, True)
OFile.Write(StrFinal) 'Запись отчета в текстовый файл
OFile.Close
 
Set oShell = CreateObject("WScript.Shell")
oShell.Run WritetxtPt 'Запуск текстового файла с отчетом
 
'КОНЕЦ!!!
 
 
'--------------------Классы---------------------------
Class FoldCl
    dim size, size1, files, subfolders, flhash, hash
    sub crdict
        set flhash=CreateObject("Scripting.Dictionary")
        set files=CreateObject("Scripting.Dictionary")
        set subfolders=CreateObject("Scripting.Dictionary")
    End sub
    sub res(x)
        Redim preserve flhash(x)
    End sub
End Class
 
'--------------------Функции---------------------------      
Sub Recurs1(FoldObj,folpt,hash,size)
    dim subhash, n, chksums(),sumsize,subsize
    n=0
    sumsize=0
    For each elem in FoldObj.subfolders     
        if not Junctions.exists(elem) then
            Redim preserve chksums(n)
            Recurs1 CollFol(elem),elem,subhash,subsize
            CollFol(elem).flhash=subhash 'эквивалентно FoldObj.subfolders(elem).hash=subsize
            CollFol(elem).size=subsize
            chksums(n)=subhash
            if replace(replace(subhash,"\_",""),"*","")="" then     
                CollEmpFol(elem)=subhash
            elseif FoldHashes.exists(subhash) Then
                if not FoldClones.exists(subhash) then 
                    set FoldClones(subhash)=CreateObject("Scripting.Dictionary")
                    FoldClones(subhash)(FoldHashes(subhash))=subsize
                    'msgbox FoldHashes(subhash)&vbcrlf&elem
                end if
                FoldClones(subhash)(elem)=subsize
            else FoldHashes(subhash)=elem
            end if
            sumsize=sumsize+subsize 
            n=n+1
        end if  
    next
    'On error resume next
    hash=FoldObj.flhash&join(chksums,"")    
    size=FoldObj.size1+sumsize
    'msgbox hash&vbcrlf&size
end sub
 
Sub Recurs2(FoldObj, folpt)
    Dim arrscl,ccnt,elsz,sz
    For Each elem in FoldObj.subfolders         
        if CollEmpFol.exists(elem) then 
            EmptyFinal(elem)=CollEmpFol(elem)           
        elseif FoldClones.exists(CollFol(elem).flhash) then     
            elhsh=CollFol(elem).flhash
            elsz=CollFol(elem).size
            ccnt=FoldClones(elhsh).count-1
            sz=ccnt*elsz
            if not ClonesFinal.exists(sz) then              
                set ClonesFinal(sz)=CreateObject("Scripting.Dictionary")
            end if
            ClonesFinal(sz)(elhsh)=elsz&" * "&ccnt&" = "&sz&" байт ("&round(sz/1048576,2)&" мб)"&vbcrlf&join(FoldClones(elhsh).keys,vbcrlf)
            'msgbox ClonesFinal(sz)(elhsh)
        elseif Junctions.exists(elem) then
        else 
            Recurs2 CollFol(elem),elem 'эквивал. Recurs2 FoldObj.subfolders(elem),elem
        end if
    next    
End sub
 
Sub Dialog(objPath)
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "Выбор папки", 0)
    If objFolder Is Nothing Then Wscript.Quit
    objPath = objFolder.Self.Path
End sub
 
Function GetMD5(strText)
    Dim i, strResult
    strResult=""
    For i=1 To Len(strText)
        strResult = strResult & ChrB(Asc(Mid(strText, i, 1)))
    Next
    objHashedData.Hash strResult    
    GetMD5 = objHashedData.Value
End Function

@testuser2 · 27.01.2020, 11:10 **[ТС]**

Сообщение от testuser2

Думаю уже ликвидный результат

нифига, надо в парсинге делать "обход" junctions, как минимум для устранени дублей переменных и лишнего пожирания ОЗУ (доходит до 2гб при сканировании диска)

@testuser2 · 29.01.2020, 05:21 **[ТС]**

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
Dim fldpt, flname, a, cnt, flcnt, sel, ClonSumSz
'On error resume next
Set FSO = CreateObject("Scripting.FileSystemObject")
'Set objHashedData = WScript.CreateObject("CAPICOM.HashedData")
'objHashedData.Algorithm=CAPICOM_HASH_ALGORITHM_MD5
Set File = FSO.OpenTextFile(Fso.GetParentFolderName(WScript.ScriptFullName)&"\fileC.txt", 1)
WritetxtPt=Fso.GetParentFolderName(WScript.ScriptFullName)&"\folderreportNew.txt"
set CollFol=Crdict 'основная коллекция папок
set CollEmpFol=Crdict 'коллекция всех папок с нулевым размером
set EmptyFinal=Crdict 'коллекция нулевых папок без вложенных в них
set Junctions=Crdict 'точки монтирования
set FoldHashes=Crdict 'контрольные суммы
set FoldClones=Crdict 'папки-клоны с учетом в вложенных
set ClonesFinal=Crdict '-\- без учета вложенности
Function Crdict
    set Crdict=CreateObject("Scripting.Dictionary")
end function
 
Path1=Browse4Folder
'Path1="C:\"
'Path1="C:\Users\User"
'Dialog Path1 'окно выбора папки
'Path1="E:\Programms\FirefoxPortable63.0x64copy"
'Path1="E:\Programms"
Old_Time = Timer 'запуск таймера
'Получение списка папок и файлов из выдачи (stdout) консольной комманды dir
'Stext=CreateObject("WScript.Shell").exec("cmd /c >nul chcp 1251 &&dir/s/o/a """&Path1&""" |findstr/p . |findstr/v ""<DIR>""").stdout.readall
Stext=CreateObject("WScript.Shell").exec("cmd /c >nul chcp 1251 &&dir/s/o/a """&Path1&""" |findstr/p . |findstr/v /e ""<DIR>........... <DIR>............""").stdout.readall
ArrTxt=split(Stext,vbcrlf)
'ArrTxt=split(File.readall,vbcrlf)
strend=ArrTxt(UBound(ArrTxt)-1)
strend2=ArrTxt(UBound(ArrTxt)-2)
folders=left(strend,instr(strend,"п")-1)*1 'всего папок
files=left(strend2,instr(strend2,"ф")-1)*1 'всего файлов
st1=instr(strend2,"в")+2
st2=instr(strend2,"б")-1
st3=st2-st1
fullsize=Mid(strend2,st1,st3) 'полный размер
 
cnt = 2
if mid(Path1,len(path1))="\" then Path1=left(Path1,len(Path1)-1) end if
Set CollFol(Path1)=new FoldCl
CollFol(Path1).crd
CollFol(Path1).flhash=""
CurJunc=""
'Парсинг
do until cnt=UBound(ArrTxt)-3
    str=ArrTxt(cnt) 
    if mid(str,2,6)="Содерж" then
        foldpt=Mid(str,19)
        'i=replace(CurJunc,foldpt,"")
        'if CurJunc=foldpt then msgbox "i="&i&vbcrlf&CurJunc
        'if len(i)<len(CurJunc) then msgbox foldpt end if           
        Set CollFol(foldpt)=new FoldCl 'создание объекта папки      
        CollFol(foldpt).crd
        'set Hashes(foldpt)=CollFol(foldpt)
        'if foldpt="C:\Windows\WinSxS\Temp\PendingRenames" then msgbox "PendingRenames "&Typename(CollFol(foldpt).flhash)
        if sel then 
            'Добавление папки в коллекцию (создание ссылки) "subfolders" родительской папки.
            set CollFol(left(foldpt,instrRev(foldpt,"\")-1)).subfolders(foldpt)=CollFol(foldpt)
        end if
        sel=true
        CollFol(foldpt).flcnt=0
    elseif Trim(mid(str,18,7))="файлов" then
    'elseif instr(17,str,"файлов") then
        'if foldpt="C:\Windows\WinSxS\Temp\PendingRenames" then msgbox "PendingRenames 2"&Typename(CollFol(foldpt).flhash)
        'if CollFol(foldpt).flhash.count=0 then 
        if CollFol(foldpt).flcnt=0 then
            CollFol(foldpt).flhash="\_"
            CollFol(foldpt).size1=0
            'CollFol(foldpt).flcnt=0
        else            
            'CollFol(foldpt).flhash="\_"&GetMD5(replace(join(CollFol(foldpt).flhash.keys,"")," ",""))
            'Arrrr=CollFol(foldpt).flhash.items         
            'Strr=join(Arrrr,"")
            'if foldpt="C:\Windows\WinSxS\Temp\PendingRenames" then msgbox "PendingRenames промежуток "&Typename(CollFol(foldpt).flhash)
            'CollFol(foldpt).flhash="\_"&replace(Strr," ","")
            'CollFol(foldpt).flcnt=CollFol(foldpt).flhash.count
            CollFol(foldpt).flhash=join(CollFol(foldpt).flhash.items,"")
            'CollFol(foldpt).flhash=replace(join(CollFol(foldpt).flhash.items,"")," ","")
            'if foldpt="C:\Windows\WinSxS\Temp\PendingRenames" then msgbox "PendingRenames промежуток 2"&Typename(CollFol(foldpt).flhash)
            CollFol(foldpt).size1=mid(str,25,15)*1
            'if foldpt="C:\Windows\WinSxS\Temp\PendingRenames" then msgbox "PendingRenames 3"&Typename(CollFol(foldpt).flhash)          
        end if
    elseif mid(str,22,5)="<DIR>" then 
        CollFol(foldpt).flhash(cnt)="*"
    else 'if foldpt=CurJunc or len(replace(CurJunc,foldpt,""))<len(CurJunc)
            if mid(str,22,10)="<JUNCTION>" then
                flpt=foldpt&"\"&mid(str,37,Instr(38,str,"[")-38)
                Junctions(flpt)=mid(str,Instr(38,str,"["))
                CurJunc=flpt
            end if
            CollFol(foldpt).flhash(cnt)=str 
            CollFol(foldpt).flcnt=CollFol(foldpt).flcnt+1
            'flcnt=flcnt+1 'Подсчет общего колличества файлов
    end if  
    cnt=cnt+1   
Loop
set ArrTxt=nothing
'Устранение глюка с распознаванием "All Users" и "Все пользователи" отдельными папками
Disk=left(Path1,2)
if CollFol.exists(Disk&"\Users\All Users") then Junctions(Disk&"\Users\All Users")=Disk&"\ProgramData"
if CollFol.exists(Disk&"\Users\Все пользователи") then Junctions(Disk&"\Users\Все пользователи")=Disk&"\ProgramData"
 
Recurs1 CollFol(Path1),Path1,"",0,0
set FoldHashes=Nothing
ClnCnt=FoldClones.count
EmpCnt=CollEmpFol.count
FoldCnt=CollFol.count
 
Recurs2 CollFol(Path1),Path1
set CollFol=Nothing
'CollFol.removeall
FoldClones.removeall
 
'Подготовка и вывод итогов в диалоговое окно и в отчет
Dim ArrClnSz, n, str0, str1, str2, str3, StrFinal, OFile, SumSz, var
SumSz=0
if ClonesFinal.count then   
    ArrClnSz=ClonesFinal.keys
    'Cортировка массива размеров групп клонов
    for a = UBound(ArrClnSz) - 1 To 0 Step -1
        for j= 0 to a
            if ArrClnSz(j)<ArrClnSz(j+1) then
                temp=ArrClnSz(j+1)
                ArrClnSz(j+1)=ArrClnSz(j)
                ArrClnSz(j)=temp
            end if
        next
    next
    n=0 
    For Each elem in ArrClnSz
            Redim preserve Arr(n)
            var=""
            For Each item in ClonesFinal(elem).items
                var=var&item&vbcrlf         
            next
            Arr(n)=var          
            n=n+1
    next
end if
Time_Elapsed=Timer-Old_Time
prcnt=round(ClonSumSz*100/fullsize,2)
'fullsize=BytesToStr(fullsize,2)
msgbox Path1&vbcrlf&FoldCnt&" папок, "&files&" файлов, размер "&BytesToStr(fullsize,2)&vbcrlf&vbcrlf&"Папок-клонов (групп) без учета вложенности "&ClonesFinal.count&vbcrlf&"Общий размер, занимаемый папками-дублями "&BytesToStr(ClonSumSz,2)&" ("&prcnt&"%)"&vbcrlf&"Пустых папок без учета вложенности "&EmptyFinal.count&vbcrlf&vbcrlf&"Папок-клонов (групп) всего "&ClnCnt&vbCrlf&"Пустых папок всего "&EmpCnt&vbcrlf&vbcrlf&"Точек монтирования "&Junctions.count&vbcrlf&vbcrlf&"Затрачено времени " &round(Time_Elapsed,3)&" c"
str0=Path1&": "&FoldCnt&" папок "&files&" файлов, размер "&BytesToStr(fullsize,2)
str1="Папки-клоны ("&ClonesFinal.count&" групп), общий занимаемый папками-дублями размер "&BytesToStr(ClonSumSz,2)&" ("&prcnt&"%)"&vbcrlf&join(Arr,vbcrlf)
 
n=0
Redim Arr(0)
For Each elem in Junctions
    Redim preserve Arr(n)
    Arr(n)=elem&vbcrlf&Junctions(elem)
    n=n+1
next
ln="============================================================="
str2=ln&vbcrlf&"Точки монтирования ("&Junctions.count&" шт.)"&vbcrlf&join(Arr,vbcrlf)
'msgbox str2
n=0
Redim Arr(0)
For Each elem in EmptyFinal
    Redim preserve Arr(n)
    Arr(n)=elem&vbcrlf&EmptyFinal(elem)
    n=n+1
next
str3=ln&vbcrlf&"Пустые папки и их структура вложенности ("&EmptyFinal.count&" шт.)"&vbcrlf&join(Arr,vbcrlf)
StrFinal=str0&vbcrlf&vbcrlf&ln&vbcrlf&str1&vbcrlf&str2&vbcrlf&vbcrlf&str3
 
set OFile = FSO.OpenTextFile(WritetxtPt, 2, True)
OFile.Write(StrFinal) 'Запись отчета в текстовый файл
OFile.Close
 
Set oShell = CreateObject("WScript.Shell")
oShell.Run WritetxtPt 'Запуск текстового файла с отчетом
 
'КОНЕЦ!!!
 
 
'--------------------Классы---------------------------
Class FoldCl
    dim size, size1, subfolders, flhash, hash, flcnt, files
    sub crd
        set flhash=Crdict '=CreateObject("Scripting.Dictionary")
        set files=Crdict
        set subfolders=Crdict
    End sub
    sub res(x)
        Redim preserve flhash(x)
    End sub
End Class
 
Class Obj
    dim var
End Class
 
'--------------------Функции---------------------------      
Sub Recurs1(FoldObj,folpt,hash,size,contfl)
    dim subhash, n, chksums(),sumsize,subsize,subcontfl, sumcontfl
    n=0
    sumsize=0
    sumcontfl=0
    For each elem in FoldObj.subfolders     
        if not Junctions.exists(elem) then
            Redim preserve chksums(n)
            Recurs1 CollFol(elem),elem,subhash,subsize,subcontfl
            CollFol(elem).flhash=CollFol(elem).flhash&subhash 'эквивалентно FoldObj.subfolders(elem).hash=subsize 
            chksums(n)=CollFol(elem).flhash         
            CollFol(elem).size=CollFol(elem).size1+subsize
            CollFol(elem).flcnt=CollFol(elem).flcnt+subcontfl
            'if replace(replace(chksums(n),"\_",""),"*","")="" then
            if CollFol(elem).flcnt=0 then
                CollEmpFol(elem)=chksums(n)
            elseif FoldHashes.exists(chksums(n)) Then
                if not FoldClones.exists(chksums(n)) then 
                    set FoldClones(chksums(n))=Crdict
                    FoldClones(chksums(n))(FoldHashes(chksums(n)))=CollFol(elem).size
                end if
                FoldClones(chksums(n))(elem)=CollFol(elem).size
            else 
                FoldHashes(chksums(n))=elem
            end if
            sumcontfl=sumcontfl+CollFol(elem).flcnt
            sumsize=sumsize+CollFol(elem).size          
            n=n+1
        end if  
    next    
    'On error resume next
    'hash=FoldObj.flhash&join(chksums,"")
    hash=join(chksums,"")
    'if Err then 
        'MsgBox Err.Description & vbCrlf & Err.HelpContext & vbCrlf & Err.HelpFile & vbCrlf & Err.Number & vbCrlf & Err.Source 
        'MsgBox Path1&vbcrlf&CollFol.exists(left(foldpt,instrRev(foldpt,"\")-1))&" "&CollFol.exists(Path1)
        'MsgBox folpt
        'MsgBox Typename(FoldObj.flhash)
        'MsgBox FoldObj.flhash.count
    'end if
    'size=FoldObj.size1+sumsize
    contfl=sumcontfl
    size=sumsize
end sub
 
Sub Recurs2(FoldObj, folpt)
    Dim arrscl,ccnt,elsz,sz,sz2
    For Each elem in FoldObj.subfolders         
        if CollEmpFol.exists(elem) then 
            EmptyFinal(elem)=CollEmpFol(elem)
            CollEmpFol.remove(elem)
        elseif FoldClones.exists(CollFol(elem).flhash) then     
            elhsh=CollFol(elem).flhash
            elsz=CollFol(elem).size
            ccnt=FoldClones(elhsh).count-1
            sz=ccnt*elsz
            if not ClonesFinal.exists(sz) then              
                set ClonesFinal(sz)=Crdict
            end if
            ClonesFinal(sz)(elhsh)=BytesTostr(elsz,2)&" * "&ccnt&" = "&BytesTostr(sz,2)&vbcrlf&join(FoldClones(elhsh).keys,vbcrlf)
            ClonSumSz=ClonSumSz+sz
            FoldClones.remove(elhsh)
        elseif Junctions.exists(elem) then
        else
            Recurs2 CollFol(elem),elem 'эквивал. Recurs2 FoldObj.subfolders(elem),elem
        end if
    next    
End sub
 
Function Browse4Folder
    Dim objFolder, objFolderItem, objShell, strPrompt, intOptions
    strPrompt = "Выберите каталог для анализа"
    strRoot=""
    intOptions = BIF_RETURNONLYFSDIRS + BIF_EDITBOX + BIF_NONEWFOLDER
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, strPrompt, intOptions, strRoot) 
    If (objFolder Is Nothing) Then
        Browse4Folder = ""
    Else
        Set objFolderItem = objFolder.Self
        Browse4Folder = objFolderItem.Path      
        Set objFolderItem = Nothing
        Set objFolder = Nothing
    End If  
    Set objShell = Nothing
End Function
 
Function BytesToStr(ByVal size2, precision)
    Dim sizes, total, rSize
    sizes=Array(" YB", " Zb", " Eb", " Pb", " Тб", " Гб", " Мб", " Кб", " бит")
    total=Ubound(sizes)
    while size2>1024
      total=total-1  
      size2=size2/1024
    wend
    rSize=round(size2,precision)
    BytesToStr=rSize&sizes(total) 
End Function
 
Function GetMD5(strText)
    Dim i, strResult
    strResult=""
    For i=1 To Len(strText)
        strResult = strResult & ChrB(Asc(Mid(strText, i, 1)))
    Next
    objHashedData.Hash strResult    
    GetMD5=objHashedData.Value
End Function

@testuser2 · 30.01.2020, 15:28 **[ТС]**

Сделал отсеивание джунков и симлинков на этапе парсинга, с тем правилом, что ссылки идущие на внешний источник обрабатываются как папки (в единственном экземпляре). Т.е., допустим, обрабатывая папку профилей C:\Users\ скрипт обработает симлинк "C:\Users\All Users" ведущий на внешнее расположение (C:\ProgramData), и пропустит "C:\Users\Все пользователи", ведущий на то же расположение, также пропустит джунк C:\Users\User\Documents\мои рисунки, поскольку он ведет на внутреннее расположение и т.д. Но, кстати, dir сам "обходит" стандартные джунки ("Мои рисунки", "Моя музыка"..) будь то внутренние или внешние. Т.е. при листинге C:\Users\User\Documents дир не выдаст инфу по "C:\Users\User\Documents\мои рисунки" (C:\Users\User\Pictures), хотя было бы не плохо. При этом пользовательские джунки листит в любом случае, также любые. Симлинки листит любые в любом случае, таковы нюансы самого дира, которые впрочем не так уж и сложны. В любом случае можно добрать инфу можно добрать доп. коммандой по отдельному линку, если будет, допустим, такая необходимость..

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
Dim fldpt, flname, a, cnt, flcnt, sel, ClonSumSz
'On error resume next
Set FSO = CreateObject("Scripting.FileSystemObject")
'Set objHashedData = WScript.CreateObject("CAPICOM.HashedData")
'objHashedData.Algorithm=CAPICOM_HASH_ALGORITHM_MD5
Set File = FSO.OpenTextFile(Fso.GetParentFolderName(WScript.ScriptFullName)&"\fileC.txt", 1)
CurDir=Fso.GetParentFolderName(WScript.ScriptFullName)
WritetxtPt=CurDir&"\folderreportNew.txt"
FoldList=CurDir&"\folders.txt"
DirCmdList=CurDir&"\dircmdlist.txt"
EmpFoldList=CurDir&"\empfoldlist.txt"
set CollFol=Crdict 'основная коллекция папок
set CollEmpFol=Crdict 'коллекция всех папок с нулевым размером
set EmptyFinal=Crdict 'коллекция нулевых папок без вложенных в них
set Junctions=Crdict 'точки монтирования
set FoldHashes=Crdict 'контрольные суммы
set MisJunc=Crdict 'вспомогательная коллекция по работе с симлинками и джункциями
set FoldClones=Crdict 'папки-клоны с учетом в вложенных
set ClonesFinal=Crdict '-\- без учета вложенности
Function Crdict
    set Crdict=CreateObject("Scripting.Dictionary")
end function
 
Path1=Browse4Folder
'Path1="C:\"
'Path1="C:\Users\User"
'Dialog Path1 'окно выбора папки
'Path1="E:\Programms\FirefoxPortable63.0x64copy"
'Path1="E:\Programms"
Old_Time = Timer 'запуск таймера
'Получение списка папок и файлов из выдачи (stdout) консольной комманды dir
'Stext=CreateObject("WScript.Shell").exec("cmd /c >nul chcp 1251 &&dir/s/o/a """&Path1&""" |findstr/p . |findstr/v ""<DIR>""").stdout.readall
Stext=CreateObject("WScript.Shell").exec("cmd /c >nul chcp 1251 &&dir/s/o/a """&Path1&""" |findstr/p . |findstr/v /e ""<DIR>........... <DIR>............""").stdout.readall
'set OFile = FSO.OpenTextFile(DirCmdList, 2, True)
'OFile.Write(Stext) 'Запись stdout комманды в текстовый файл dircmdlist.txt
'OFile.Close
'msgbox " "
 
ArrTxt=split(Stext,vbcrlf)
'ArrTxt=split(File.readall,vbcrlf)
strend=ArrTxt(UBound(ArrTxt)-1)
strend2=ArrTxt(UBound(ArrTxt)-2)
folders=left(strend,instr(strend,"п")-1)*1 'всего папок
files=left(strend2,instr(strend2,"ф")-1)*1 'всего файлов
st1=instr(strend2,"в")+2
st2=instr(strend2,"б")-1
st3=st2-st1
fullsize=Mid(strend2,st1,st3) 'полный размер
 
cnt = 2
if mid(Path1,len(path1))="\" then Path1=left(Path1,len(Path1)-1) end if
Set CollFol(Path1)=new FoldCl
CollFol(Path1).crd
CollFol(Path1).flhash=""
CurJunc="?"
'Парсинг
do until cnt=UBound(ArrTxt)-3
    str=ArrTxt(cnt) 
    if mid(str,2,6)="Содерж" then
        foldpt=Mid(str,19)
        if Junctions.exists(foldpt) then 
            if instr(Junctions(foldpt),Path1)=1 or MisJunc.exists(Junctions(foldpt)) then 
                CurJunc=foldpt              
            else 
                MisJunc(Junctions(foldpt))=foldpt
                CurJunc="?"
            end if
        end if
        if instr(foldpt,CurJunc)=0 then         
            Set CollFol(foldpt)=new FoldCl 'создание объекта папки      
            CollFol(foldpt).crd
            'set Hashes(foldpt)=CollFol(foldpt)
            'if foldpt="C:\Windows\WinSxS\Temp\PendingRenames" then msgbox "PendingRenames "&Typename(CollFol(foldpt).flhash)
            if sel then 
                'Добавление папки в коллекцию (создание ссылки) "subfolders" родительской папки.
                set CollFol(left(foldpt,instrRev(foldpt,"\")-1)).subfolders(foldpt)=CollFol(foldpt)
            end if
            sel=true
            CollFol(foldpt).flcnt=0
        end if
    elseif instr(foldpt,CurJunc)=0 then
        if Trim(mid(str,18,7))="файлов" then
        'elseif instr(17,str,"файлов") then
            if CollFol(foldpt).flcnt=0 then
                CollFol(foldpt).flhash="\_"
                CollFol(foldpt).size1=0
            else            
                'CollFol(foldpt).flhash="\_"&GetMD5(replace(join(CollFol(foldpt).flhash.keys,"")," ",""))
                CollFol(foldpt).flhash=join(CollFol(foldpt).flhash.items,"")
                'CollFol(foldpt).flhash=replace(join(CollFol(foldpt).flhash.items,"")," ","")
                CollFol(foldpt).size1=mid(str,25,15)*1
            end if
        elseif mid(str,22,5)="<DIR>" then 
            'On error resume next
            CollFol(foldpt).flhash(cnt)="*"
            'if Err then 
                'MsgBox Err.Description & vbCrlf & Err.HelpContext & vbCrlf & Err.HelpFile & vbCrlf & Err.Number & vbCrlf & Err.Source 
                'MsgBox Path1&vbcrlf&CollFol.exists(left(foldpt,instrRev(foldpt,"\")-1))&" "&CollFol.exists(Path1)
                'MsgBox foldpt&vbcrlf&CurJunc
                'msgbox instr(foldpt,CurJunc)
                'MsgBox CollFol.exists(foldpt)
                'MsgBox Typename(CollFol(foldpt).flhash)
                'MsgBox FoldObj.flhash.count
            'end if
        else if mid(str,22,10)="<JUNCTION>" or mid(str,22,10)="<SYMLINKD>" then
                    flpt=foldpt&"\"&mid(str,37,Instr(38,str,"[")-38)
                    'Junctions(flpt)=mid(str,Instr(38,str,"["))
                    a=Instr(38,str,"[")+1
                    Junctions(flpt)=mid(str,a,len(str)-a)
                end if
                CollFol(foldpt).flhash(cnt)=str 
                CollFol(foldpt).flcnt=CollFol(foldpt).flcnt+1
                'flcnt=flcnt+1 'Подсчет общего колличества файлов
        end if
    end if
    ArrTxt(cnt)=""
    cnt=cnt+1   
Loop
 
'msgbox CollFol.count
'Str=Join(CollFol.keys,vbcrlf)
'set OFile = FSO.OpenTextFile(FoldList, 2, True)
'OFile.Write(Str) 'Запись списка папок в текстовый файл folders.txt
'OFile.Close
'msgbox " "
 
set ArrTxt=Nothing
'Disk=left(Path1,2)
 
Recurs1 CollFol(Path1),Path1,"",0,0
set FoldHashes=Nothing
set MisJunc=Nothing
ClnCnt=FoldClones.count
EmpCnt=CollEmpFol.count
'str=join(CollEmpFol.keys,vbcrlf)
'set OFile = FSO.OpenTextFile(EmpFoldList, 2, True)
'OFile.Write(Str) 'Запись списка пустых папок в текстовый файл emfoldlist.txt
'OFile.Close
'FoldCnt=CollFol.count
 
Recurs2 CollFol(Path1),Path1
set CollFol=Nothing
'CollFol.removeall
FoldClones.removeall
 
'Подготовка и вывод итогов в диалоговое окно и в отчет
Dim ArrClnSz, n, str0, str1, str2, str3, StrFinal, OFile, SumSz, var
SumSz=0
if ClonesFinal.count then   
    ArrClnSz=ClonesFinal.keys
    'Cортировка массива размеров групп клонов
    for a = UBound(ArrClnSz) - 1 To 0 Step -1
        for j= 0 to a
            if ArrClnSz(j)<ArrClnSz(j+1) then
                temp=ArrClnSz(j+1)
                ArrClnSz(j+1)=ArrClnSz(j)
                ArrClnSz(j)=temp
            end if
        next
    next
    n=0 
    For Each elem in ArrClnSz
        Redim preserve Arr(n)
        var=""
        For Each item in ClonesFinal(elem).items
            var=var&item&vbcrlf         
        next
        Arr(n)=var          
        n=n+1
    next
end if
Time_Elapsed=Timer-Old_Time
prcnt=round(ClonSumSz*100/fullsize,2)
msgbox Path1&vbcrlf&FoldCnt&" папок, "&files&" файлов, размер "&BytesToStr(fullsize,2)&vbcrlf&vbcrlf&"Папок-клонов (групп) без учета вложенности "&ClonesFinal.count&vbcrlf&"Общий размер, занимаемый папками-дублями "&BytesToStr(ClonSumSz,2)&" ("&prcnt&"%)"&vbcrlf&"Пустых папок без учета вложенности "&EmptyFinal.count&vbcrlf&vbcrlf&"Папок-клонов (групп) всего "&ClnCnt&vbCrlf&"Пустых папок всего "&EmpCnt&vbcrlf&vbcrlf&"Точек монтирования и симлинков "&Junctions.count&vbcrlf&vbcrlf&"Затрачено времени " &round(Time_Elapsed,3)&" c"
str0=Path1&": "&FoldCnt&" папок "&files&" файлов, размер "&BytesToStr(fullsize,2)
str1="Папки-клоны ("&ClonesFinal.count&" групп), общий занимаемый папками-дублями размер "&BytesToStr(ClonSumSz,2)&" ("&prcnt&"%)"&vbcrlf&join(Arr,vbcrlf)
 
n=0
Redim Arr(0)
For Each elem in Junctions
    Redim preserve Arr(n)
    Arr(n)=elem&vbcrlf&"["&Junctions(elem)&"]"
    n=n+1
next
ln="============================================================="
str2=ln&vbcrlf&"Точки монтирования и симлинки ("&Junctions.count&" шт.)"&vbcrlf&join(Arr,vbcrlf)
n=0
Redim Arr(0)
For Each elem in EmptyFinal
    Redim preserve Arr(n)
    Arr(n)=elem&vbcrlf&EmptyFinal(elem)
    n=n+1
next
str3=ln&vbcrlf&"Пустые папки и их структура вложенности ("&EmptyFinal.count&" шт.)"&vbcrlf&join(Arr,vbcrlf)
StrFinal=str0&vbcrlf&vbcrlf&ln&vbcrlf&str1&vbcrlf&str2&vbcrlf&vbcrlf&str3
 
set OFile = FSO.OpenTextFile(WritetxtPt, 2, True)
OFile.Write(StrFinal) 'Запись отчета в текстовый файл
OFile.Close
 
Set oShell = CreateObject("WScript.Shell")
oShell.Run WritetxtPt 'Запуск текстового файла с отчетом
 
'КОНЕЦ!!!
 
'--------------------Классы---------------------------
Class FoldCl
    dim size, size1, subfolders, flhash, hash, flcnt, files
    sub crd
        set flhash=Crdict '=CreateObject("Scripting.Dictionary")
        set files=Crdict
        set subfolders=Crdict
    End sub
    sub res(x)
        Redim preserve flhash(x)
    End sub
End Class
 
'--------------------Функции---------------------------      
Sub Recurs1(FoldObj,folpt,hash,size,contfl)
    dim subhash, n, chksums(),sumsize,subsize,subcontfl, sumcontfl
    n=0
    sumsize=0
    sumcontfl=0
    For each elem in FoldObj.subfolders     
        'if not Junctions.exists(elem) then
            Redim preserve chksums(n)
            Recurs1 CollFol(elem),elem,subhash,subsize,subcontfl
            CollFol(elem).flhash=CollFol(elem).flhash&subhash 'эквивалентно FoldObj.subfolders(elem).hash=subsize 
            chksums(n)=CollFol(elem).flhash         
            CollFol(elem).size=CollFol(elem).size1+subsize
            CollFol(elem).flcnt=CollFol(elem).flcnt+subcontfl
            'if replace(replace(chksums(n),"\_",""),"*","")="" then
            if CollFol(elem).flcnt=0 then
                CollEmpFol(elem)=chksums(n)
            elseif FoldHashes.exists(chksums(n)) Then
                if not FoldClones.exists(chksums(n)) then 
                    set FoldClones(chksums(n))=Crdict
                    FoldClones(chksums(n))(FoldHashes(chksums(n)))=CollFol(elem).size
                end if
                'FoldClones(chksums(n))(elem)=CollFol(elem).size
                FoldClones(chksums(n))(elem)=""
            else 
                FoldHashes(chksums(n))=elem
            end if
            sumcontfl=sumcontfl+CollFol(elem).flcnt
            sumsize=sumsize+CollFol(elem).size          
            n=n+1
        'end if 
    next    
    'On error resume next
    'hash=FoldObj.flhash&join(chksums,"")
    hash=join(chksums,"")
    'if Err then 
        'MsgBox Err.Description & vbCrlf & Err.HelpContext & vbCrlf & Err.HelpFile & vbCrlf & Err.Number & vbCrlf & Err.Source 
        'MsgBox Path1&vbcrlf&CollFol.exists(left(foldpt,instrRev(foldpt,"\")-1))&" "&CollFol.exists(Path1)
        'MsgBox folpt
        'MsgBox Typename(FoldObj.flhash)
        'MsgBox FoldObj.flhash.count
    'end if
    'size=FoldObj.size1+sumsize
    contfl=sumcontfl
    size=sumsize
end sub
 
Sub Recurs2(FoldObj, folpt)
    Dim arrscl,ccnt,elsz,sz,sz2
    For Each elem in FoldObj.subfolders         
        if CollEmpFol.exists(elem) then 
            EmptyFinal(elem)=CollEmpFol(elem)
            CollEmpFol.remove(elem)
        elseif FoldClones.exists(CollFol(elem).flhash) then     
            elhsh=CollFol(elem).flhash
            elsz=CollFol(elem).size
            ccnt=FoldClones(elhsh).count-1
            sz=ccnt*elsz
            if not ClonesFinal.exists(sz) then          
                set ClonesFinal(sz)=Crdict
            end if
            ClonesFinal(sz)(elhsh)=BytesTostr(elsz,2)&" * "&ccnt&" = "&BytesTostr(sz,2)&vbcrlf&join(FoldClones(elhsh).keys,vbcrlf)
            ClonSumSz=ClonSumSz+sz
            FoldClones.remove(elhsh)
        'elseif Junctions.exists(elem) then 'msgbox "junc "&elem&vbcrlf&Junctions(elem)
        else
            Recurs2 CollFol(elem),elem 'эквивал. Recurs2 FoldObj.subfolders(elem),elem
        end if
    next    
End sub
 
Function Browse4Folder
    Dim objFolder, objFolderItem, objShell, strPrompt, intOptions
    strPrompt = "Выберите каталог для анализа"
    strRoot=""
    intOptions = BIF_RETURNONLYFSDIRS + BIF_EDITBOX + BIF_NONEWFOLDER
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, strPrompt, intOptions, strRoot) 
    If (objFolder Is Nothing) Then
        Browse4Folder = ""
    Else
        Set objFolderItem = objFolder.Self
        Browse4Folder = objFolderItem.Path      
        Set objFolderItem = Nothing
        Set objFolder = Nothing
    End If  
    Set objShell = Nothing
End Function
 
Function BytesToStr(ByVal size2, precision)
    Dim sizes, total, rSize
    sizes=Array(" YB", " Zb", " Eb", " Pb", " Тб", " Гб", " Мб", " Кб", " бит")
    total=Ubound(sizes)
    while size2>1024
      total=total-1  
      size2=size2/1024
    wend
    rSize=round(size2,precision)
    BytesToStr=rSize&sizes(total) 
End Function
 
Function GetMD5(strText)
    Dim i, strResult
    strResult=""
    For i=1 To Len(strText)
        strResult = strResult & ChrB(Asc(Mid(strText, i, 1)))
    Next
    objHashedData.Hash strResult    
    GetMD5=objHashedData.Value
End Function

@testuser2 · 30.01.2020, 15:54 **[ТС]**

Время первого прохода (по некэшированному диску) немного дольше (100 с чем-то сек.). Пик потребления памяти в пике нещадное, с этим ни чего не поделать.., и это самый главный контраргумент против таки методов работы с ф.с.

@testuser2 · 30.01.2020, 16:11 **[ТС]**

Прикольдос

Code
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
C::  папок 711038 файлов, размер 99,6 Гб
 
=============================================================
Папки-клоны (2703 групп), общий занимаемый папками-дублями размер 2,07 Гб (2,08%)
6,23 Мб * 39 = 242,96 Мб
C:\Users\User\AppData\Local\Temp\0BF6A80D-A89F-4542-9AD8-AA618029A1D0
C:\Users\User\AppData\Local\Temp\148F3AE8-B3F6-4091-877D-B8C7B5DDB621
C:\Users\User\AppData\Local\Temp\1A5C99A6-FC3F-4330-A389-CAED410D8B4D
C:\Users\User\AppData\Local\Temp\1C36D19E-5BCC-4DCD-BD59-8D4579615B8C
C:\Users\User\AppData\Local\Temp\1FC689C0-6A07-4D81-9F23-461181399380
C:\Users\User\AppData\Local\Temp\2160EDB9-81E8-4A1E-9C64-D10C2A92E406
C:\Users\User\AppData\Local\Temp\34195EE6-08D5-4BFF-8CDD-62D3CCCB96D9
C:\Users\User\AppData\Local\Temp\384B5C32-C43B-4995-B4AE-4E9ED102138D
C:\Users\User\AppData\Local\Temp\4B69D931-9FA6-4A90-A24B-34C3A1E9AF76
C:\Users\User\AppData\Local\Temp\4D64ED78-C06C-463E-907F-81DE4F55E2C7
C:\Users\User\AppData\Local\Temp\51FBDABC-149F-42EB-839E-E07665405B3B
C:\Users\User\AppData\Local\Temp\5371A2F1-DB33-4081-BA9E-AD64C8C0DFA1
C:\Users\User\AppData\Local\Temp\55D2853B-E14A-43E9-8643-6E65609F4974
C:\Users\User\AppData\Local\Temp\6710FBD7-B17A-4D02-A822-C5E984B401F0
C:\Users\User\AppData\Local\Temp\688403FE-C817-49DB-AA4C-77DCBF7DF707
C:\Users\User\AppData\Local\Temp\6D13113A-C97F-4E67-A145-AEA37CB78F8F
C:\Users\User\AppData\Local\Temp\7AF7321A-7660-4F67-BE21-EA38BF201763
C:\Users\User\AppData\Local\Temp\7F35E701-64B7-48A5-9609-FBD168534848
C:\Users\User\AppData\Local\Temp\854B506E-F931-496A-BA65-3E8EA8CFC81A
C:\Users\User\AppData\Local\Temp\858C7566-1F80-4B3E-B40F-6B14C4EE5E56
C:\Users\User\AppData\Local\Temp\8E8915B5-D676-4986-8268-9453A7366CA3
C:\Users\User\AppData\Local\Temp\9105F7E6-B502-41FD-B65D-F9D9E2198E53
C:\Users\User\AppData\Local\Temp\943D756F-5D00-419A-8DE2-56B4FC9B21BF
C:\Users\User\AppData\Local\Temp\96C04D5F-E11D-41A0-A793-6DCEC98F55F1
C:\Users\User\AppData\Local\Temp\9AA7D3EB-6A93-4E02-8161-5B151E1D9C13
C:\Users\User\AppData\Local\Temp\A382CCCA-6039-4E39-88F3-3DCD0BEF2E80
C:\Users\User\AppData\Local\Temp\A4033945-4B32-427E-9FDF-FB2534BA281F
C:\Users\User\AppData\Local\Temp\A50C7ACF-AA59-4277-8286-8467B0131B5E
C:\Users\User\AppData\Local\Temp\A531FEA3-A7C8-43F9-821D-610A3CD641D5
C:\Users\User\AppData\Local\Temp\A870FC92-9B11-4A66-9E04-8EB335E7CF64
C:\Users\User\AppData\Local\Temp\A9C03D15-9F8C-4D56-965B-010A853441D2
C:\Users\User\AppData\Local\Temp\B064390C-1510-449B-8631-8F3516E64441
C:\Users\User\AppData\Local\Temp\B115CABD-7207-40F9-893C-BA5A654BA813
C:\Users\User\AppData\Local\Temp\B6171684-A586-47F2-B3AD-389EC691ADC3
C:\Users\User\AppData\Local\Temp\B7BBB1E3-874D-4ECC-BCC9-33A0514CCDA6
C:\Users\User\AppData\Local\Temp\DA1E6245-3293-4A6F-8141-AA0057F01A7A
C:\Users\User\AppData\Local\Temp\E70A6D38-7BE2-4E09-83FF-845467B4169A
C:\Users\User\AppData\Local\Temp\E9870510-C238-4196-9942-F9E728DC4DAD
C:\Users\User\AppData\Local\Temp\F3BFEFC8-8E16-4190-8869-D4757030CA6B
C:\Windows\System32\Dism
***

@testuser2 · 01.02.2020, 07:24 **[ТС]**

Сообщение от testuser2

потребления памяти в пике нещадное,

Все быне так печально, но статистику портят некоторые папки. Если исключить папки с колличеством файлов более 10000 ситуация уже немного другая. На поверку это папки
C:\Windows\servicing\Packages
C:\Windows\WinSxS\Manifests
C:\Windows\WinSxS\Temp\PendingRenames

@testuser2 · 01.02.2020, 13:23 **[ТС]**

Новый день, новая портянка

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
Dim fldpt, flname, a, cnt, flcnt, sel, ClonSumSz
'On error resume next
Set FSO = CreateObject("Scripting.FileSystemObject")
'Set objHashedData = WScript.CreateObject("CAPICOM.HashedData")
'objHashedData.Algorithm=CAPICOM_HASH_ALGORITHM_MD5
Set File = FSO.OpenTextFile(Fso.GetParentFolderName(WScript.ScriptFullName)&"\fileC.txt", 1)
CurDir=Fso.GetParentFolderName(WScript.ScriptFullName)
WritetxtPt=CurDir&"\folderreportNew.txt"
FoldList=CurDir&"\folders.txt"
BigFoldList=CurDir&"\bigfolders.txt"
DirCmdList=CurDir&"\dircmdlist.txt"
EmpFoldList=CurDir&"\empfoldlist.txt"
set CollFol=Crdict 'основная коллекция папок
set CollEmpFol=Crdict 'коллекция всех папок с нулевым размером
set BigFold=Crdict 'коллекция папок с избыточным колличеством файлов
set EmptyFinal=Crdict 'коллекция нулевых папок без вложенных в них
set Junctions=Crdict 'точки монтирования
set FoldHashes=Crdict 'контрольные суммы
set MisJunc=Crdict 'вспомогательная коллекция по работе с симлинками и джункциями
set FoldClones=Crdict 'папки-клоны с учетом в вложенных
set ClonesFinal=Crdict '-\- без учета вложенности
Function Crdict
    set Crdict=CreateObject("Scripting.Dictionary")
end function
 
Path1=Browse4Folder
 
'Path1="C:\"
'Path1="C:\Users\User"
'Dialog Path1 'окно выбора папки
'Path1="E:\Programms\FirefoxPortable63.0x64copy"
'Path1="E:\Programms"
Old_Time = Timer 'запуск таймера
'Получение списка папок и файлов из выдачи (stdout) консольной комманды dir
'Stext=CreateObject("WScript.Shell").exec("cmd /c >nul chcp 1251 &&dir/s/o/a """&Path1&""" |findstr/p . |findstr/v ""<DIR>""").stdout.readall
Stext=CreateObject("WScript.Shell").exec("cmd /c >nul chcp 1251 &&dir/s/o/a """&Path1&""" |findstr/p . |findstr/v /e ""<DIR>........... <DIR>............""").stdout.readall
 
'set OFile = FSO.OpenTextFile(DirCmdList, 2, True)
'OFile.Write(Stext) 'Запись stdout комманды в текстовый файл dircmdlist.txt
'OFile.Close
'msgbox " "
 
ArrTxt=split(Stext,vbcrlf)
 
'ArrTxt=split(File.readall,vbcrlf)
 
strend=ArrTxt(UBound(ArrTxt)-1)
strend2=ArrTxt(UBound(ArrTxt)-2)
folders=left(strend,instr(strend,"п")-1)*1 'всего папок
files=left(strend2,instr(strend2,"ф")-1)*1 'всего файлов
st1=instr(strend2,"в")+2
st2=instr(strend2,"б")-1
st3=st2-st1
fullsize=Mid(strend2,st1,st3) 'полный размер
 
cnt = 2
if mid(Path1,len(path1))="\" then Path1=left(Path1,len(Path1)-1) end if
Set CollFol(Path1)=new FoldCl
CollFol(Path1).crd
CollFol(Path1).flhash=""
CurJunc="?"
'Парсинг
do until cnt=UBound(ArrTxt)-3
    str=ArrTxt(cnt) 
    if mid(str,2,6)="Содерж" then
        foldpt=Mid(str,19)      
        if Junctions.exists(foldpt) then 
            if instr(Junctions(foldpt),Path1)=1 or MisJunc.exists(Junctions(foldpt)) then 
                CurJunc=foldpt
                Skipfl=true
            else 
                MisJunc(Junctions(foldpt))=foldpt
                CurJunc="?"
            end if
        end if
        if instr(foldpt,CurJunc)=0 then
            Set CollFol(foldpt)=new FoldCl 'создание объекта папки      
            CollFol(foldpt).crd
            'set Hashes(foldpt)=CollFol(foldpt)
            'if foldpt="C:\Windows\WinSxS\Temp\PendingRenames" then msgbox "PendingRenames "&Typename(CollFol(foldpt).flhash)
            if sel then 
                'Добавление папки в коллекцию (создание ссылки) "subfolders" родительской папки.
                set CollFol(left(foldpt,instrRev(foldpt,"\")-1)).subfolders(foldpt)=CollFol(foldpt)
            end if
            sel=true
            Skipfl=false
            CollFol(foldpt).flcnt=0
        end if
    'elseif instr(foldpt,CurJunc)=0 and Skipfl=false then
    elseif Skipfl=false then
        if Trim(mid(str,18,7))="файлов" then
        'if instr(16,str,"файлов") then
        'if instr(str,"файлов")=1 then
            'if foldpt="C:\Windows\WinSxS\Temp\PendingRenames" then msgbox "C:\Windows\WinSxS\Temp\PendingRenames "&vbcrlf&CollFol(foldpt).flcnt
            if CollFol(foldpt).flcnt=0 then
                CollFol(foldpt).flhash="\_"
                CollFol(foldpt).size1=0
            else            
                'CollFol(foldpt).flhash="\_"&GetMD5(replace(join(CollFol(foldpt).flhash.keys,"")," ",""))
                CollFol(foldpt).flhash="\"&join(CollFol(foldpt).flhash.items,"")
                'CollFol(foldpt).flhash=replace(join(CollFol(foldpt).flhash.items,"")," ","")
                CollFol(foldpt).size1=mid(str,25,15)*1
                'if foldpt="C:\Windows\WinSxS\Temp\PendingRenames" then msgbox "C:\Windows\WinSxS\Temp\PendingRenames"&vbcrlf&CollFol(foldpt).flcnt
            end if
        elseif mid(str,22,5)="<DIR>" then 
            'On error resume next
            CollFol(foldpt).flhash(cnt)="*"
            'if Err then 
                'MsgBox Err.Description & vbCrlf & Err.HelpContext & vbCrlf & Err.HelpFile & vbCrlf & Err.Number & vbCrlf & Err.Source 
                'MsgBox Path1&vbcrlf&CollFol.exists(left(foldpt,instrRev(foldpt,"\")-1))&" "&CollFol.exists(Path1)
                'MsgBox foldpt&vbcrlf&CurJunc
                'msgbox instr(foldpt,CurJunc)
                'MsgBox CollFol.exists(foldpt)
                'MsgBox Typename(CollFol(foldpt).flhash)
                'MsgBox FoldObj.flhash.count
            'end if
        else if mid(str,22,10)="<JUNCTION>" or mid(str,22,10)="<SYMLINKD>" then
                    flpt=foldpt&"\"&mid(str,37,Instr(38,str,"[")-38)
                    'Junctions(flpt)=mid(str,Instr(38,str,"["))
                    a=Instr(38,str,"[")+1
                    Junctions(flpt)=mid(str,a,len(str)-a)
                end if                  
                CollFol(foldpt).flcnt=CollFol(foldpt).flcnt+1
                if CollFol(foldpt).flcnt<10000 Then 'если колличество файлов больше 10000 исключаем из обработки
                    CollFol(foldpt).flhash(cnt)=str
                else
                    'CollFol(foldpt).flhash.removeall
                    CollFol(foldpt).flhash="\###"
                    BigFold(foldpt)=""
                    Skipfl=true
                    'msgbox "Большая папка "&vbcrlf&foldpt
                end if
                'flcnt=flcnt+1 'Подсчет общего колличества файлов
        end if
    end if
    ArrTxt(cnt)=""
    cnt=cnt+1   
Loop
 
'msgbox CollFol.count
'Str=Join(CollFol.keys,vbcrlf)
'set OFile = FSO.OpenTextFile(FoldList, 2, True)
'OFile.Write(Str) 'Запись списка папок в текстовый файл folders.txt
'OFile.Close
'Str=Join(BigFold.keys,vbcrlf)
'set OFile = FSO.OpenTextFile(BigFoldList, 2, True)
'OFile.Write(Str) 'Запись списка папок в текстовый файл folders.txt
'OFile.Close
'msgbox "Запись файлов выполнена"
FoldCnt=CollFol.count+BigFold.count
set BigFold=Nothing
set BigFold=Nothing
set ArrTxt=Nothing
'Disk=left(Path1,2)
 
Recurs1 CollFol(Path1),Path1,"",0,0
set FoldHashes=Nothing
set MisJunc=Nothing
ClnCnt=FoldClones.count
EmpCnt=CollEmpFol.count
'str=join(CollEmpFol.keys,vbcrlf)
'set OFile = FSO.OpenTextFile(EmpFoldList, 2, True)
'OFile.Write(Str) 'Запись списка пустых папок в текстовый файл emfoldlist.txt
'OFile.Close
 
Recurs2 CollFol(Path1),Path1
set CollFol=Nothing
'CollFol.removeall
FoldClones.removeall
 
'Подготовка и вывод итогов в диалоговое окно и в отчет
Dim ArrClnSz, n, str0, str1, str2, str3, StrFinal, OFile, SumSz, var
SumSz=0
if ClonesFinal.count then   
    ArrClnSz=ClonesFinal.keys
    'Cортировка массива размеров групп клонов
    for a = UBound(ArrClnSz) - 1 To 0 Step -1
        for j= 0 to a
            if ArrClnSz(j)<ArrClnSz(j+1) then
                temp=ArrClnSz(j+1)
                ArrClnSz(j+1)=ArrClnSz(j)
                ArrClnSz(j)=temp
            end if
        next
    next
    n=0 
    For Each elem in ArrClnSz
        Redim preserve Arr(n)
        var=""
        For Each item in ClonesFinal(elem).items
            var=var&item&vbcrlf         
        next
        Arr(n)=var          
        n=n+1
    next
end if
Time_Elapsed=Timer-Old_Time
prcnt=round(ClonSumSz*100/fullsize,2)
msgbox Path1&vbcrlf&FoldCnt&" папок, "&files&" файлов, размер "&BytesToStr(fullsize,2)&vbcrlf&vbcrlf&"Папок-клонов (групп) без учета вложенности "&ClonesFinal.count&vbcrlf&"Общий размер, занимаемый папками-дублями "&BytesToStr(ClonSumSz,2)&" ("&prcnt&"%)"&vbcrlf&"Пустых папок без учета вложенности "&EmptyFinal.count&vbcrlf&vbcrlf&"Папок-клонов (групп) всего "&ClnCnt&vbCrlf&"Пустых папок всего "&EmpCnt&vbcrlf&vbcrlf&"Точек монтирования и симлинков "&Junctions.count&vbcrlf&vbcrlf&"Затрачено времени " &round(Time_Elapsed,3)&" c"
str0=Path1&": "&FoldCnt&" папок "&files&" файлов, размер "&BytesToStr(fullsize,2)
str1="Папки-клоны ("&ClonesFinal.count&" групп), общий занимаемый папками-дублями размер "&BytesToStr(ClonSumSz,2)&" ("&prcnt&"%)"&vbcrlf&join(Arr,vbcrlf)
 
n=0
Redim Arr(0)
For Each elem in Junctions
    Redim preserve Arr(n)
    Arr(n)=elem&vbcrlf&"["&Junctions(elem)&"]"
    n=n+1
next
ln="============================================================="
str2=ln&vbcrlf&"Точки монтирования и симлинки ("&Junctions.count&" шт.)"&vbcrlf&join(Arr,vbcrlf)
n=0
Redim Arr(0)
For Each elem in EmptyFinal
    Redim preserve Arr(n)
    Arr(n)=elem&vbcrlf&EmptyFinal(elem)
    n=n+1
next
str3=ln&vbcrlf&"Пустые папки и их структура вложенности ("&EmptyFinal.count&" шт.)"&vbcrlf&join(Arr,vbcrlf)
StrFinal=str0&vbcrlf&vbcrlf&ln&vbcrlf&str1&vbcrlf&str2&vbcrlf&vbcrlf&str3
 
set OFile = FSO.OpenTextFile(WritetxtPt, 2, True)
OFile.Write(StrFinal) 'Запись отчета в текстовый файл
OFile.Close
 
Set oShell = CreateObject("WScript.Shell")
oShell.Run WritetxtPt 'Запуск текстового файла с отчетом
 
'КОНЕЦ!!!
 
'--------------------Классы---------------------------
Class FoldCl
    dim size, size1, subfolders, flhash, hash, flcnt, files
    sub crd
        set flhash=Crdict '=CreateObject("Scripting.Dictionary")
        set files=Crdict
        set subfolders=Crdict
    End sub
    sub res(x)
        Redim preserve flhash(x)
    End sub
End Class
 
'--------------------Функции---------------------------      
Sub Recurs1(FoldObj,folpt,hash,size,contfl)
    dim subhash, n, chksums(),sumsize,subsize,subcontfl, sumcontfl
    n=0
    sumsize=0
    sumcontfl=0
    For each elem in FoldObj.subfolders     
        'if not Junctions.exists(elem) then
            Redim preserve chksums(n)
            Recurs1 CollFol(elem),elem,subhash,subsize,subcontfl
            'On error resume next
            CollFol(elem).flhash=CollFol(elem).flhash&subhash 'эквивалентно FoldObj.subfolders(elem).hash=subsize 
            if Err then 
                Str=Join(CollFol(elem).flhash.items)
                msgbox "elem "&elem&vbcrlf&"Тип flhash "&Typename(CollFol(elem).flhash)&vbcrlf&"Колличество файлов "&CollFol(elem).flcnt&vbcrlf&Str
                Err.Clear
            end if
            chksums(n)=CollFol(elem).flhash         
            CollFol(elem).size=CollFol(elem).size1+subsize
            CollFol(elem).flcnt=CollFol(elem).flcnt+subcontfl
            'if replace(replace(chksums(n),"\_",""),"*","")="" then
            if CollFol(elem).flcnt=0 then
                CollEmpFol(elem)=chksums(n)
            elseif FoldHashes.exists(chksums(n)) Then
                if not FoldClones.exists(chksums(n)) then 
                    set FoldClones(chksums(n))=Crdict
                    FoldClones(chksums(n))(FoldHashes(chksums(n)))=CollFol(elem).size
                end if
                'FoldClones(chksums(n))(elem)=CollFol(elem).size
                FoldClones(chksums(n))(elem)=""
            else 
                FoldHashes(chksums(n))=elem
            end if
            sumcontfl=sumcontfl+CollFol(elem).flcnt
            sumsize=sumsize+CollFol(elem).size          
            n=n+1
        'end if 
    next    
    'On error resume next
    'hash=FoldObj.flhash&join(chksums,"")
    hash=join(chksums,"")
    'if Err then 
        'MsgBox Err.Description & vbCrlf & Err.HelpContext & vbCrlf & Err.HelpFile & vbCrlf & Err.Number & vbCrlf & Err.Source 
        'MsgBox Path1&vbcrlf&CollFol.exists(left(foldpt,instrRev(foldpt,"\")-1))&" "&CollFol.exists(Path1)
        'MsgBox folpt
        'MsgBox Typename(FoldObj.flhash)
        'MsgBox FoldObj.flhash.count
    'end if
    'size=FoldObj.size1+sumsize
    contfl=sumcontfl
    size=sumsize
end sub
 
Sub Recurs2(FoldObj, folpt)
    Dim arrscl,ccnt,elsz,sz,sz2
    For Each elem in FoldObj.subfolders         
        if CollEmpFol.exists(elem) then 
            EmptyFinal(elem)=CollEmpFol(elem)
            CollEmpFol.remove(elem)
        elseif FoldClones.exists(CollFol(elem).flhash) then     
            elhsh=CollFol(elem).flhash
            elsz=CollFol(elem).size
            ccnt=FoldClones(elhsh).count-1
            sz=ccnt*elsz
            if not ClonesFinal.exists(sz) then          
                set ClonesFinal(sz)=Crdict
            end if
            ClonesFinal(sz)(elhsh)=BytesTostr(elsz,2)&" * "&ccnt&" = "&BytesTostr(sz,2)&vbcrlf&join(FoldClones(elhsh).keys,vbcrlf)
            ClonSumSz=ClonSumSz+sz
            FoldClones.remove(elhsh)
        'elseif Junctions.exists(elem) then 'msgbox "junc "&elem&vbcrlf&Junctions(elem)
        else
            Recurs2 CollFol(elem),elem 'эквивал. Recurs2 FoldObj.subfolders(elem),elem
        end if
    next    
End sub
 
Function Browse4Folder
    Dim objFolder, objFolderItem, objShell, strPrompt, intOptions
    strPrompt = "Выберите каталог для анализа"
    strRoot=""
    intOptions = BIF_RETURNONLYFSDIRS + BIF_EDITBOX + BIF_NONEWFOLDER
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, strPrompt, intOptions, strRoot) 
    If (objFolder Is Nothing) Then
        Browse4Folder = ""
    Else
        Set objFolderItem = objFolder.Self
        Browse4Folder = objFolderItem.Path      
        Set objFolderItem = Nothing
        Set objFolder = Nothing
    End If  
    Set objShell = Nothing
End Function
 
Function BytesToStr(ByVal size2, precision)
    Dim sizes, total, rSize
    sizes=Array(" YB", " Zb", " Eb", " Pb", " Тб", " Гб", " Мб", " Кб", " бит")
    total=Ubound(sizes)
    while size2>1024
      total=total-1  
      size2=size2/1024
    wend
    rSize=round(size2,precision)
    BytesToStr=rSize&sizes(total) 
End Function

@testuser2 · 02.02.2020, 09:49 **[ТС]**

Проценты групп клонов.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
Dim fldpt, flname, a, cnt, flcnt, sel, ClonSumSz
'On error resume next
Set FSO = CreateObject("Scripting.FileSystemObject")
'Set objHashedData = WScript.CreateObject("CAPICOM.HashedData")
'objHashedData.Algorithm=CAPICOM_HASH_ALGORITHM_MD5
Set File = FSO.OpenTextFile(Fso.GetParentFolderName(WScript.ScriptFullName)&"\fileC.txt", 1)
CurDir=Fso.GetParentFolderName(WScript.ScriptFullName)
WritetxtPt=CurDir&"\folderreportNew.txt"
FoldList=CurDir&"\folders.txt"
BigFoldList=CurDir&"\bigfolders.txt"
DirCmdList=CurDir&"\dircmdlist.txt"
EmpFoldList=CurDir&"\empfoldlist.txt"
set CollFol=Crdict 'основная коллекция папок
set CollEmpFol=Crdict 'коллекция всех папок с нулевым размером
set BigFold=Crdict 'коллекция папок с избыточным колличеством файлов
set EmptyFinal=Crdict 'коллекция нулевых папок без вложенных в них
set Junctions=Crdict 'точки монтирования
set FoldHashes=Crdict 'контрольные суммы
set MisJunc=Crdict 'вспомогательная коллекция по работе с симлинками и джункциями
set FoldClones=Crdict 'папки-клоны с учетом в вложенных
set ClonesFinal=Crdict '-\- без учета вложенности
Function Crdict
    set Crdict=CreateObject("Scripting.Dictionary")
end function
 
Path1=Browse4Folder
 
'Path1="C:\"
'Path1="C:\Users\User"
'Dialog Path1 'окно выбора папки
'Path1="E:\Programms\FirefoxPortable63.0x64copy"
'Path1="E:\Programms"
Old_Time = Timer 'запуск таймера
'Получение списка папок и файлов из выдачи (stdout) консольной комманды dir
'Stext=CreateObject("WScript.Shell").exec("cmd /c >nul chcp 1251 &&dir/s/o/a """&Path1&""" |findstr/p . |findstr/v ""<DIR>""").stdout.readall
Stext=CreateObject("WScript.Shell").exec("cmd /c >nul chcp 1251 &&dir/s/o/a """&Path1&""" |findstr/p . |findstr/v /e ""<DIR>..........\. <DIR>..........\.\.""").stdout.readall
 
'set OFile = FSO.OpenTextFile(DirCmdList, 2, True)
'OFile.Write(Stext) 'Запись stdout комманды в текстовый файл dircmdlist.txt
'OFile.Close
'msgbox " "
 
ArrTxt=split(Stext,vbcrlf)
 
'ArrTxt=split(File.readall,vbcrlf)
 
strend=ArrTxt(UBound(ArrTxt)-1)
strend2=ArrTxt(UBound(ArrTxt)-2)
folders=left(strend,instr(strend,"п")-1)*1 'всего папок
files=left(strend2,instr(strend2,"ф")-1)*1 'всего файлов
st1=instr(strend2,"в")+2
st2=instr(strend2,"б")-1
st3=st2-st1
fullsize=Mid(strend2,st1,st3) 'полный размер
 
cnt = 2
if mid(Path1,len(path1))="\" then Path1=left(Path1,len(Path1)-1)
Set CollFol(Path1)=new FoldCl
CollFol(Path1).crd
CollFol(Path1).flhash=""
CurJunc="?"
'Парсинг
do until cnt=UBound(ArrTxt)-3
    str=ArrTxt(cnt) 
    if mid(str,2,6)="Содерж" then
        foldpt=Mid(str,19)      
        if Junctions.exists(foldpt) then 
            if instr(Junctions(foldpt),Path1)=1 or MisJunc.exists(Junctions(foldpt)) then 
                CurJunc=foldpt
                Skipfl=true
            else 
                MisJunc(Junctions(foldpt))=foldpt
                CurJunc="?"
            end if
        end if
        if instr(foldpt,CurJunc)=0 then
            Set CollFol(foldpt)=new FoldCl 'создание объекта папки      
            CollFol(foldpt).crd
            'set Hashes(foldpt)=CollFol(foldpt)
            'if foldpt="C:\Windows\WinSxS\Temp\PendingRenames" then msgbox "PendingRenames "&Typename(CollFol(foldpt).flhash)
            if sel then 
                'Добавление папки в коллекцию (создание ссылки) "subfolders" родительской папки.
                set CollFol(left(foldpt,instrRev(foldpt,"\")-1)).subfolders(foldpt)=CollFol(foldpt)
            end if
            sel=true
            Skipfl=false
            CollFol(foldpt).flcnt=0
        end if
    elseif Skipfl=false then
        if Trim(mid(str,18,7))="файлов" then
        'if instr(16,str,"файлов") then
            'if foldpt="C:\Windows\WinSxS\Temp\PendingRenames" then msgbox "C:\Windows\WinSxS\Temp\PendingRenames "&vbcrlf&CollFol(foldpt).flcnt
            if CollFol(foldpt).flcnt=0 then
                if CollFol(foldpt).flhash.count then 
                    CollFol(foldpt).flhash="\"&join(CollFol(foldpt).flhash.items,"")
                else
                    CollFol(foldpt).flhash="\_"
                end if
                CollFol(foldpt).size1=0
            else            
                'CollFol(foldpt).flhash="\_"&GetMD5(replace(join(CollFol(foldpt).flhash.keys,"")," ",""))
                CollFol(foldpt).flhash="\"&join(CollFol(foldpt).flhash.items,"")
                'CollFol(foldpt).flhash=replace(join(CollFol(foldpt).flhash.items,"")," ","")
                CollFol(foldpt).size1=mid(str,25,15)*1
                'if foldpt="C:\Windows\WinSxS\Temp\PendingRenames" then msgbox "C:\Windows\WinSxS\Temp\PendingRenames"&vbcrlf&CollFol(foldpt).flcnt
            end if
        elseif mid(str,22,5)="<DIR>" then 
            'On error resume next
            CollFol(foldpt).flhash(cnt)="*"
            'if Err then 
                'MsgBox Err.Description & vbCrlf & Err.HelpContext & vbCrlf & Err.HelpFile & vbCrlf & Err.Number & vbCrlf & Err.Source 
                'MsgBox Path1&vbcrlf&CollFol.exists(left(foldpt,instrRev(foldpt,"\")-1))&" "&CollFol.exists(Path1)
                'MsgBox foldpt&vbcrlf&CurJunc
                'msgbox instr(foldpt,CurJunc)
                'MsgBox CollFol.exists(foldpt)
                'MsgBox Typename(CollFol(foldpt).flhash)
                'MsgBox FoldObj.flhash.count
            'end if
        else if mid(str,22,10)="<JUNCTION>" or mid(str,22,10)="<SYMLINKD>" then
                flpt=foldpt&"\"&mid(str,37,Instr(38,str,"[")-38)
                'Junctions(flpt)=mid(str,Instr(38,str,"["))
                a=Instr(38,str,"[")+1
                Junctions(flpt)=mid(str,a,len(str)-a)
            end if                  
            CollFol(foldpt).flcnt=CollFol(foldpt).flcnt+1
            if CollFol(foldpt).flcnt<10000 Then 'если колличество файлов больше 10000 исключаем из обработки
                CollFol(foldpt).flhash(cnt)=str
            else
                'CollFol(foldpt).flhash.removeall
                CollFol(foldpt).flhash="\#"&cnt&"#"
                BigFold(foldpt)=""              
                Skipfl=true
                'msgbox "Большая папка "&vbcrlf&foldpt
            end if
            'flcnt=flcnt+1 'Подсчет общего колличества файлов
        end if
    end if
    ArrTxt(cnt)=""
    cnt=cnt+1   
Loop
 
'msgbox CollFol.count
'Str=Join(CollFol.keys,vbcrlf)
'set OFile = FSO.OpenTextFile(FoldList, 2, True)
'OFile.Write(Str) 'Запись списка папок в текстовый файл folders.txt
'OFile.Close
'Str=Join(BigFold.keys,vbcrlf)
'set OFile = FSO.OpenTextFile(BigFoldList, 2, True)
'OFile.Write(Str) 'Запись списка папок в текстовый файл folders.txt
'OFile.Close
'msgbox "Запись файлов выполнена"
FoldCnt=CollFol.count+BigFold.count
set BigFold=Nothing
set ArrTxt=Nothing
'Disk=left(Path1,2)
 
Recurs1 CollFol(Path1),Path1,"",0,0
set FoldHashes=Nothing
set MisJunc=Nothing
ClnCnt=FoldClones.count
EmpCnt=CollEmpFol.count
'str=join(CollEmpFol.keys,vbcrlf)
'set OFile = FSO.OpenTextFile(EmpFoldList, 2, True)
'OFile.Write(Str) 'Запись списка пустых папок в текстовый файл emfoldlist.txt
'OFile.Close
 
Recurs2 CollFol(Path1),Path1
set CollFol=Nothing
'CollFol.removeall
FoldClones.removeall
 
'Подготовка и вывод итогов в диалоговое окно и в отчет
Dim ArrClnSz, n, str0, str1, str2, str3, StrFinal, OFile, SumSz, var
SumSz=0
if ClonesFinal.count then   
    ArrClnSz=ClonesFinal.keys
    'Cортировка массива размеров групп клонов
    for a = UBound(ArrClnSz) - 1 To 0 Step -1
        for j= 0 to a
            if ArrClnSz(j)<ArrClnSz(j+1) then
                temp=ArrClnSz(j+1)
                ArrClnSz(j+1)=ArrClnSz(j)
                ArrClnSz(j)=temp
            end if
        next
    next
    n=0 
    For Each elem in ArrClnSz
        Redim preserve Arr(n)
        var=""      
        For Each item in ClonesFinal(elem).items
            ccnt=item.count-1
            elsz=elem/ccnt
            prcnt=round(elem*100/ClonSumSz,2)
            var=var&BytesTostr(elsz,2)&" * "&ccnt&" = "&BytesTostr(elem,2)&" ("&prcnt&"%)"&vbcrlf&join(item.keys,vbcrlf)&vbcrlf
        next
        Arr(n)=var      
        n=n+1
    next
end if
Time_Elapsed=Timer-Old_Time
prcnt=round(ClonSumSz*100/fullsize,2)
msgbox Path1&vbcrlf&FoldCnt&" папок, "&files&" файлов, размер "&BytesToStr(fullsize,2)&vbcrlf&vbcrlf&"Папок-клонов (групп) без учета вложенности "&ClonesFinal.count&vbcrlf&"Общий размер, занимаемый папками-дублями "&BytesToStr(ClonSumSz,2)&" ("&prcnt&"%)"&vbcrlf&"Пустых папок без учета вложенности "&EmptyFinal.count&vbcrlf&vbcrlf&"Папок-клонов (групп) всего "&ClnCnt&vbCrlf&"Пустых папок всего "&EmpCnt&vbcrlf&vbcrlf&"Точек монтирования и симлинков "&Junctions.count&vbcrlf&vbcrlf&"Затрачено времени " &round(Time_Elapsed,3)&" c"
str0=Path1&": "&FoldCnt&" папок "&files&" файлов, размер "&BytesToStr(fullsize,2)
str1="Папки-клоны ("&ClonesFinal.count&" групп), общий занимаемый папками-дублями размер "&BytesToStr(ClonSumSz,2)&" ("&prcnt&"%)"&vbcrlf&vbcrlf&join(Arr,vbcrlf)
 
n=0
Redim Arr(0)
For Each elem in Junctions
    Redim preserve Arr(n)
    Arr(n)=elem&vbcrlf&"["&Junctions(elem)&"]"
    n=n+1
next
ln="============================================================="
str2=ln&vbcrlf&"Точки монтирования и симлинки ("&Junctions.count&" шт.)"&vbcrlf&vbcrlf&join(Arr,vbcrlf&vbcrlf)
n=0
Redim Arr(0)
For Each elem in EmptyFinal
    Redim preserve Arr(n)
    Arr(n)=elem&vbcrlf&EmptyFinal(elem)
    n=n+1
next
str3=ln&vbcrlf&"Пустые папки и их структура вложенности ("&EmptyFinal.count&" шт.)"&vbcrlf&vbcrlf&join(Arr,vbcrlf)
StrFinal=str0&vbcrlf&vbcrlf&ln&vbcrlf&str1&vbcrlf&str2&vbcrlf&vbcrlf&str3
 
set OFile = FSO.OpenTextFile(WritetxtPt, 2, True)
OFile.Write(StrFinal) 'Запись отчета в текстовый файл
OFile.Close
 
Set oShell = CreateObject("WScript.Shell")
oShell.Run WritetxtPt 'Запуск текстового файла с отчетом
 
'КОНЕЦ!!!
 
'--------------------Классы---------------------------
Class FoldCl
    dim size, size1, subfolders, flhash, hash, flcnt, files
    sub crd
        set flhash=Crdict '=CreateObject("Scripting.Dictionary")
        set files=Crdict
        set subfolders=Crdict
    End sub
    sub res(x)
        Redim preserve flhash(x)
    End sub
End Class
 
'--------------------Функции---------------------------      
Sub Recurs1(FoldObj,folpt,hash,size,contfl)
    dim subhash, n, chksums(),sumsize,subsize,subcontfl, sumcontfl
    n=0
    sumsize=0
    sumcontfl=0
    For each elem in FoldObj.subfolders     
        'if not Junctions.exists(elem) then
            Redim preserve chksums(n)
            Recurs1 CollFol(elem),elem,subhash,subsize,subcontfl
            'On error resume next
            CollFol(elem).flhash=CollFol(elem).flhash&subhash 'эквивалентно FoldObj.subfolders(elem).hash=subsize 
            if Err then 
                Str=Join(CollFol(elem).flhash.items)
                msgbox "elem "&elem&vbcrlf&"Тип flhash "&Typename(CollFol(elem).flhash)&vbcrlf&"Колличество файлов "&CollFol(elem).flcnt&vbcrlf&Str
                Err.Clear
            end if
            chksums(n)=CollFol(elem).flhash         
            CollFol(elem).size=CollFol(elem).size1+subsize
            CollFol(elem).flcnt=CollFol(elem).flcnt+subcontfl
            'if replace(replace(chksums(n),"\_",""),"*","")="" then
            if CollFol(elem).flcnt=0 then
                CollEmpFol(elem)=chksums(n)
            elseif FoldHashes.exists(chksums(n)) Then
                if not FoldClones.exists(chksums(n)) then 
                    set FoldClones(chksums(n))=Crdict
                    FoldClones(chksums(n))(FoldHashes(chksums(n)))=CollFol(elem).size
                end if
                'FoldClones(chksums(n))(elem)=CollFol(elem).size
                FoldClones(chksums(n))(elem)=""
            else 
                FoldHashes(chksums(n))=elem
            end if
            sumcontfl=sumcontfl+CollFol(elem).flcnt
            sumsize=sumsize+CollFol(elem).size          
            n=n+1
        'end if 
    next    
    'On error resume next
    'hash=FoldObj.flhash&join(chksums,"")
    hash=join(chksums,"")
    'if Err then 
        'MsgBox Err.Description & vbCrlf & Err.HelpContext & vbCrlf & Err.HelpFile & vbCrlf & Err.Number & vbCrlf & Err.Source 
        'MsgBox Path1&vbcrlf&CollFol.exists(left(foldpt,instrRev(foldpt,"\")-1))&" "&CollFol.exists(Path1)
        'MsgBox folpt
        'MsgBox Typename(FoldObj.flhash)
        'MsgBox FoldObj.flhash.count
    'end if
    'size=FoldObj.size1+sumsize
    contfl=sumcontfl
    size=sumsize
end sub
 
Sub Recurs2(FoldObj, folpt)
    Dim arrscl,ccnt,elsz,sz,sz2
    For Each elem in FoldObj.subfolders         
        if CollEmpFol.exists(elem) then 
            EmptyFinal(elem)=CollEmpFol(elem)
            CollEmpFol.remove(elem)
        elseif FoldClones.exists(CollFol(elem).flhash) then     
            elhsh=CollFol(elem).flhash
            elsz=CollFol(elem).size
            ccnt=FoldClones(elhsh).count-1
            sz=ccnt*elsz
            if not ClonesFinal.exists(sz) then          
                set ClonesFinal(sz)=Crdict
            end if
            'ClonesFinal(sz)(elhsh)=BytesTostr(elsz,2)&" * "&ccnt&" = "&BytesTostr(sz,2)&vbcrlf&join(FoldClones(elhsh).keys,vbcrlf)
            set ClonesFinal(sz)(elhsh)=FoldClones(elhsh)
            ClonSumSz=ClonSumSz+sz
            FoldClones.remove(elhsh)
        'elseif Junctions.exists(elem) then 'msgbox "junc "&elem&vbcrlf&Junctions(elem)
        else
            Recurs2 CollFol(elem),elem 'эквивал. Recurs2 FoldObj.subfolders(elem),elem
        end if
    next    
End sub
 
Function Browse4Folder
    Dim objFolder, objFolderItem, objShell, strPrompt, intOptions
    strPrompt = "Выберите каталог для анализа"
    strRoot=""
    intOptions = BIF_RETURNONLYFSDIRS + BIF_EDITBOX + BIF_NONEWFOLDER
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, strPrompt, intOptions, strRoot) 
    If (objFolder Is Nothing) Then
        Browse4Folder = ""
    Else
        Set objFolderItem = objFolder.Self
        Browse4Folder = objFolderItem.Path      
        Set objFolderItem = Nothing
        Set objFolder = Nothing
    End If  
    Set objShell = Nothing
End Function
 
Function BytesToStr(ByVal size2, precision)
    Dim sizes, total, rSize
    sizes=Array(" YB", " Zb", " Eb", " Pb", " Тб", " Гб", " Мб", " Кб", " бит")
    total=Ubound(sizes)
    while size2>1024
      total=total-1  
      size2=size2/1024
    wend
    rSize=round(size2,precision)
    BytesToStr=rSize&sizes(total) 
End Function
 
Function GetMD5(strText)
    Dim i, strResult
    strResult=""
    For i=1 To Len(strText)
        strResult = strResult & ChrB(Asc(Mid(strText, i, 1)))
    Next
    objHashedData.Hash strResult    
    GetMD5=objHashedData.Value
End Function

@testuser2 · 03.02.2020, 18:17 **[ТС]**

Немного о том, какие проблемы и задачи хотелось бы решить. В первую очередь - пожирание памяти, для этого надо добавить crc32 хеширование, самое лёгкое и быстрое. Но при всем, оно все же медленное, по этому следующий пункт - многопоточность, перенести это хеширование на паралельно запущенные процессы 3-4 копий отдельного (вспомогательного) скрипта. Задача не самая простая, но кое-что уже нашел..

@testuser2 · 05.02.2020, 16:49 **[ТС]**

Выявился еще один неучтенный прикол с симлинками - которые созданы в другой системе в текущей привязываются к текущим буквам дисков.. ...Многопоточность, или точнее параллельнопоточность, кое что реализовал, но вопрос, а нужно ли или, скажем так, целесообразно ли в моем случае.. Есть одна прикольная крутая штука, описанная на сером форуме, позволяющая разшаривать объекты из одного скрипта для других, и, главное открывает возможности или упрощает задачу по организации параллельно-поточности (или псевдо-параллельнопоточности, как угодно). У меня кое что получилось, надо сказать, не без труда. Пик воркинг-сет ~1700 Гб, в принципе не плохо, но другой момент - объекты перестают освобождать память при их уничтожении. К основному скрипту я добавил 2 доплнительных delegat.vbs - распределитель и execut.vbs - исполнитель. Пишут что можно все организовать на одном скрипте и запуске его копий с разными параметрами, но мне было проще расположить все на отдельных, хотябы чтоб не запутаться в общей логике.. Основной скрипт запускает скрипт-распределитель, и наполняет коллекцию с "заданиями". Скрипт-распределитель запускает несколько копий скрипта-исполнителя, и распределяет между ними задания по мере выполнения (как только скрипт освобождается, получает новое задание, либо ждет, либо завершается при опр. условии в общем все сложно..).. Что есть задания - коллекции строк которые должны пересчитать в crc32 чек-суммы и выдать "на базу" в основной скрипт. Фактически каждый "эксекут" обрабатывает какую-то отдельную, как бы папку, и если папка слишком большая (слишком ного файлов-строк), то один скрипт может зависнуть над обработкой значительно дольше других. Целесообразнее было бы обрабатывать такую папку несколькими скриптами, но это сложнее осуществить..
Основной скрипт.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
Dim fldpt, flname, a, cnt, flcnt, sel, ClonSumSz, CRCTable(255), CrcTableInit, cntcrc, gCon, endPars, contrCnt
cntcrc=0
'Const CAPICOM_HASH_ALGORITHM_MD2     = 1
'On error resume next
'Set objHashedData = WScript.CreateObject("CAPICOM.HashedData")
'objHashedData.Algorithm=CAPICOM_HASH_ALGORITHM_MD5
'objHashedData.Algorithm=CAPICOM_HASH_ALGORITHM_SHA_256
Set FSO = CreateObject("Scripting.FileSystemObject")
Set File = FSO.OpenTextFile(Fso.GetParentFolderName(WScript.ScriptFullName)&"\fileC.txt", 1)
CurDir=Fso.GetParentFolderName(WScript.ScriptFullName)
WritetxtPt=CurDir&"\folderreportNew.txt"
FoldList=CurDir&"\folders.txt"
BigFoldList=CurDir&"\bigfolders.txt"
DirCmdList=CurDir&"\dircmdlist.txt"
EmpFoldList=CurDir&"\empfoldlist.txt"
set CollFol=Crdict 'основная коллекция папок
set CollEmpFol=Crdict 'коллекция всех папок с нулевым размером
set BigFold=Crdict 'коллекция папок с избыточным колличеством файлов
set EmptyFinal=Crdict 'коллекция нулевых папок без вложенных в них
set Junctions=Crdict 'точки монтирования
set FoldHashes=Crdict 'контрольные суммы
set MisJunc=Crdict 'вспомогательная коллекция по работе с симлинками и джункциями
set FoldClones=Crdict 'папки-клоны с учетом в вложенных
set ClonesFinal=Crdict '-\- без учета вложенности
Function Crdict
    set Crdict=CreateObject("Scripting.Dictionary")
end function
set WshShell = WScript.CreateObject("WScript.Shell")
Set gCon = New GlobalContainer
gCon.Open "storage"
gCon.PutProperty "BigFold",BigFold
gCon.PutProperty "CollFol",CollFol
gCon.PutProperty "endPars",false
gCon.PutProperty "calcCRC32",getRef("calcCRC32") 'разшаривание функции подсчета CRC32
 
WScript.Sleep(1000)
 
Path1=Browse4Folder
 
'Path1="C:\"
'Path1="C:\Users\User\Documents"
'Dialog Path1 'окно выбора папки
'Path1="E:\Programms\FirefoxPortable63.0x64copy"
'Path1="E:\Programms"
Old_Time = Timer 'запуск таймера
'Получение списка папок и файлов из выдачи (stdout) консольной комманды dir
'Stext=CreateObject("WScript.Shell").exec("cmd /c >nul chcp 1251 &&dir/s/o/a """&Path1&""" |findstr/p . |findstr/v ""<DIR>""").stdout.readall
Stext=CreateObject("WScript.Shell").exec("cmd /c >nul chcp 1251 &&dir/s/o/a """&Path1&""" |findstr/p . |findstr/v /e ""<DIR>..........\. <DIR>..........\.\.""").stdout.readall
 
'set OFile = FSO.OpenTextFile(DirCmdList, 2, True)
'OFile.Write(Stext) 'Запись stdout комманды в текстовый файл dircmdlist.txt
'OFile.Close
'msgbox " "
 
ArrTxt=split(Stext,vbcrlf)
 
'ArrTxt=split(File.readall,vbcrlf)
 
strend=ArrTxt(UBound(ArrTxt)-1)
strend2=ArrTxt(UBound(ArrTxt)-2)
folders=left(strend,instr(strend,"п")-1)*1 'всего папок
files=left(strend2,instr(strend2,"ф")-1)*1 'всего файлов
st1=instr(strend2,"в")+2
st2=instr(strend2,"б")-1
st3=st2-st1
fullsize=Mid(strend2,st1,st3) 'полный размер
 
cnt = 2
if mid(Path1,len(path1))="\" then Path1=left(Path1,len(Path1)-1)
Set CollFol(Path1)=new FoldCl
CollFol(Path1).crd
CollFol(Path1).flhash=""
CurJunc="?"
'Парсинг
 
'WshShell.run(""""&CurDir&"\delegat.vbs "&"""")
set WshDeleg = WshShell.Exec(""""&FSO.GetSpecialFolder(1)&"\WScript.exe"" """&CurDir&"\delegat.vbs""") 'запуск процесса-делегата
 
do until cnt=UBound(ArrTxt)-3
    str=ArrTxt(cnt) 
    if mid(str,2,6)="Содерж" then
        foldpt=Mid(str,19)      
        if Junctions.exists(foldpt) then 
            if instr(Junctions(foldpt),Path1)=1 or MisJunc.exists(Junctions(foldpt)) then 
                CurJunc=foldpt
                Skipfl=true
            else 
                MisJunc(Junctions(foldpt))=foldpt
                CurJunc="?"
            end if
        end if
        if instr(foldpt,CurJunc)=0 then
            Set CollFol(foldpt)=new FoldCl 'создание объекта папки      
            CollFol(foldpt).crd
            'set Hashes(foldpt)=CollFol(foldpt)
            'if foldpt="C:\Windows\WinSxS\Temp\PendingRenames" then msgbox "PendingRenames "&Typename(CollFol(foldpt).flhash)
            if sel then 
                'Добавление папки в коллекцию (создание ссылки) "subfolders" родительской папки.
                set CollFol(left(foldpt,instrRev(foldpt,"\")-1)).subfolders(foldpt)=CollFol(foldpt)
            end if
            sel=true
            Skipfl=false
            CollFol(foldpt).flcnt=0
            contrCnt=0
        end if
    elseif Skipfl=false then
        if Trim(mid(str,18,7))="файлов" then
        'if instr(16,str,"файлов") then
            'if foldpt="C:\Windows\WinSxS\Temp\PendingRenames" then msgbox "C:\Windows\WinSxS\Temp\PendingRenames "&vbcrlf&CollFol(foldpt).flcnt
            if CollFol(foldpt).flcnt=0 then
                if CollFol(foldpt).flhash.count then 
                    CollFol(foldpt).flhash="\"&join(CollFol(foldpt).flhash.items,"")                    
                else
                    CollFol(foldpt).flhash="\_"
                end if
                CollFol(foldpt).size1=0
            else if CollFol(foldpt).flcnt>3000 Then
                    'CollFol(foldpt).flhash="\"&calcCRC32(join(CollFol(foldpt).flhash.items))
                    CollFol(foldpt).bghash(cnt)=join(CollFol(foldpt).flhash.items,"")
                    CollFol(foldpt).flhash.removeall
                    'msgbox join(CollFol(foldpt).bghash.items,vbcrlf)
                    BigFold(foldpt)=""                  
                    'msgbox join(CollFol(foldpt).flhash.items)
                    'Str1=foldpt&vbcrlf&Join(CollFol(foldpt).flhash.items,vbcrlf)
                    'set OFile = FSO.OpenTextFile(CurDir&"\Chcsums\"&cnt&".txt", 2, True)
                    'OFile.Write(Str1) 'Запись списка папок в текстовый файл folders.txt
                    'OFile.Close
                    'msgbox "запись"
                else
                    CollFol(foldpt).flhash="\"&join(CollFol(foldpt).bghash.items,"")&join(CollFol(foldpt).flhash.items,"")
                    'msgbox CollFol(foldpt).flhash
                end if
                'CollFol(foldpt).flhash="\_"&GetMD5(replace(join(CollFol(foldpt).flhash.keys,"")," ",""))
                'CollFol(foldpt).flhash=replace(join(CollFol(foldpt).flhash.items,"")," ","")
                CollFol(foldpt).size1=mid(str,25,15)*1
                'if foldpt="C:\Windows\WinSxS\Temp\PendingRenames" then msgbox "C:\Windows\WinSxS\Temp\PendingRenames"&vbcrlf&CollFol(foldpt).flcnt
            end if
        elseif mid(str,22,5)="<DIR>" then 
            'On error resume next
            CollFol(foldpt).flhash(cnt)="*"
            'if Err then 
                'MsgBox Err.Description & vbCrlf & Err.HelpContext & vbCrlf & Err.HelpFile & vbCrlf & Err.Number & vbCrlf & Err.Source 
                'MsgBox Path1&vbcrlf&CollFol.exists(left(foldpt,instrRev(foldpt,"\")-1))&" "&CollFol.exists(Path1)
                'MsgBox foldpt&vbcrlf&CurJunc
                'msgbox instr(foldpt,CurJunc)
                'MsgBox CollFol.exists(foldpt)
                'MsgBox Typename(CollFol(foldpt).flhash)
                'MsgBox FoldObj.flhash.count
            'end if
        else if mid(str,22,10)="<JUNCTION>" or mid(str,22,10)="<SYMLINKD>" then
                flpt=foldpt&"\"&mid(str,37,Instr(38,str,"[")-38)
                'Junctions(flpt)=mid(str,Instr(38,str,"["))
                a=Instr(38,str,"[")+1
                Junctions(flpt)=mid(str,a,len(str)-a)
            end if                  
            CollFol(foldpt).flcnt=CollFol(foldpt).flcnt+1
            contrCnt=contrCnt+1
            CollFol(foldpt).flhash(cnt)=str
            if contrCnt=2000 Then
                CollFol(foldpt).bghash(cnt)=join(CollFol(foldpt).flhash.items,"")
                CollFol(foldpt).flhash.removeall
                contrCnt=0
            end if
            'flcnt=flcnt+1 'Подсчет общего колличества файлов
        end if
    end if
    ArrTxt(cnt)=""
    cnt=cnt+1   
Loop
do While BigFold.count 'ждать завершения распределения BigFold (хэширования) перед оповещением.
Wscript.sleep (800)
loop
gCon.PutProperty "endPars",true 'оповещение об окончании парсинга
do until WshDeleg.status 'ожидание завершения процесса-распределителя (делегата)
    Wscript.sleep(800)
loop
Set gCon=Nothing
'msgbox "1й этап окончен "
'msgbox CollFol.count
'Str=Join(CollFol.keys,vbcrlf)
'set OFile = FSO.OpenTextFile(FoldList, 2, True)
'OFile.Write(Str) 'Запись списка папок в текстовый файл folders.txt
'OFile.Close
'Str=Join(BigFold.keys,vbcrlf)
'set OFile = FSO.OpenTextFile(BigFoldList, 2, True)
'OFile.Write(Str) 'Запись списка папок в текстовый файл folders.txt
'OFile.Close
'msgbox "Запись файлов выполнена"
FoldCnt=CollFol.count+BigFold.count
set BigFold=Nothing
set ArrTxt=Nothing
'Disk=left(Path1,2)
 
Recurs1 CollFol(Path1),Path1,"",0,0
set FoldHashes=Nothing
set MisJunc=Nothing
ClnCnt=FoldClones.count
EmpCnt=CollEmpFol.count
'str=join(CollEmpFol.keys,vbcrlf)
'set OFile = FSO.OpenTextFile(EmpFoldList, 2, True)
'OFile.Write(Str) 'Запись списка пустых папок в текстовый файл emfoldlist.txt
'OFile.Close
 
Recurs2 CollFol(Path1),Path1
set CollFol=Nothing
'CollFol.removeall
FoldClones.removeall
 
'Подготовка и вывод итогов в диалоговое окно и в отчет
Dim ArrClnSz, n, str0, str1, str2, str3, StrFinal, OFile, SumSz, var
SumSz=0
if ClonesFinal.count then   
    ArrClnSz=ClonesFinal.keys
    'Cортировка массива размеров групп клонов
    for a = UBound(ArrClnSz) - 1 To 0 Step -1
        for j= 0 to a
            if ArrClnSz(j)<ArrClnSz(j+1) then
                temp=ArrClnSz(j+1)
                ArrClnSz(j+1)=ArrClnSz(j)
                ArrClnSz(j)=temp
            end if
        next
    next
    n=0 
    For Each elem in ArrClnSz
        Redim preserve Arr(n)
        var=""      
        For Each item in ClonesFinal(elem).items
            ccnt=item.count-1
            elsz=elem/ccnt
            prcnt=round(elem*100/ClonSumSz,2)
            var=var&BytesTostr(elsz,2)&" * "&ccnt&" = "&BytesTostr(elem,2)&" ("&prcnt&"%)"&vbcrlf&join(item.keys,vbcrlf)&vbcrlf
        next
        Arr(n)=var      
        n=n+1
    next
end if
Time_Elapsed=Timer-Old_Time
prcnt=round(ClonSumSz*100/fullsize,2)
msgbox Path1&vbcrlf&FoldCnt&" папок, "&files&" файлов, размер "&BytesToStr(fullsize,2)&vbcrlf&vbcrlf&"Папок-клонов (групп) без учета вложенности "&ClonesFinal.count&vbcrlf&"Общий размер, занимаемый папками-дублями "&BytesToStr(ClonSumSz,2)&" ("&prcnt&"%)"&vbcrlf&"Пустых папок без учета вложенности "&EmptyFinal.count&vbcrlf&vbcrlf&"Папок-клонов (групп) всего "&ClnCnt&vbCrlf&"Пустых папок всего "&EmpCnt&vbcrlf&vbcrlf&"Точек монтирования и симлинков "&Junctions.count&vbcrlf&vbcrlf&"Затрачено времени " &round(Time_Elapsed,3)&" c"
str0=Path1&": "&FoldCnt&" папок "&files&" файлов, размер "&BytesToStr(fullsize,2)
str1="Папки-клоны ("&ClonesFinal.count&" групп), общий занимаемый папками-дублями размер "&BytesToStr(ClonSumSz,2)&" ("&prcnt&"%)"&vbcrlf&vbcrlf&join(Arr,vbcrlf)
 
n=0
Redim Arr(0)
For Each elem in Junctions
    Redim preserve Arr(n)
    Arr(n)=elem&vbcrlf&"["&Junctions(elem)&"]"
    n=n+1
next
ln="============================================================="
str2=ln&vbcrlf&"Точки монтирования и симлинки ("&Junctions.count&" шт.)"&vbcrlf&vbcrlf&join(Arr,vbcrlf&vbcrlf)
n=0
Redim Arr(0)
For Each elem in EmptyFinal
    Redim preserve Arr(n)
    Arr(n)=elem&vbcrlf&EmptyFinal(elem)
    n=n+1
next
str3=ln&vbcrlf&"Пустые папки и их структура вложенности ("&EmptyFinal.count&" шт.)"&vbcrlf&vbcrlf&join(Arr,vbcrlf)
StrFinal=str0&vbcrlf&vbcrlf&ln&vbcrlf&str1&vbcrlf&str2&vbcrlf&vbcrlf&str3
 
set OFile = FSO.OpenTextFile(WritetxtPt, 2, True)
OFile.Write(StrFinal) 'Запись отчета в текстовый файл
OFile.Close
 
Set oShell = CreateObject("WScript.Shell")
oShell.Run WritetxtPt 'Запуск текстового файла с отчетом
 
'КОНЕЦ!!!
 
'--------------------Классы---------------------------
Class FoldCl
    dim size, size1, subfolders, flhash, bghash, flcnt, files
    sub crd
        set flhash=Crdict '=CreateObject("Scripting.Dictionary")
        set bghash=Crdict
        'set files=Crdict
        set subfolders=Crdict
    End sub
    sub res(x)
        Redim preserve flhash(x)
    End sub
End Class
 
Class GlobalContainer
    Private wnd, owner
    Sub Open(name)
        For Each wnd in CreateObject("Shell.Application").Windows
            if Instr(1,wnd.GetProperty("container_name"),name) = 1 Then Exit Sub
        Next
        owner = True
        Set wnd = GetObject("new:{C08AFD90-F2A1-11D1-8455-00A0C91F3880}")
        wnd.PutProperty "container_name", name
    End Sub
    
    Sub PutProperty(name, value)    
        wnd.PutProperty name, value
    End Sub
    
    Function GetProperty(name)
        On Error Resume Next
        if IsObject(wnd.GetProperty(name)) Then
            Set GetProperty = wnd.GetProperty(name)
        Else
            GetProperty = wnd.GetProperty(name)
        End if
    End Function
 
    Private Sub Class_Terminate()
        On Error Resume Next
        if owner Then wnd.Quit()
    End Sub
End Class
'--------------------Функции---------------------------      
Sub Recurs1(FoldObj,folpt,hash,size,contfl)
    dim subhash, n, chksums(),sumsize,subsize,subcontfl, sumcontfl
    n=0
    sumsize=0
    sumcontfl=0
    For each elem in FoldObj.subfolders     
        'if not Junctions.exists(elem) then
            Redim preserve chksums(n)
            Recurs1 CollFol(elem),elem,subhash,subsize,subcontfl
            'On error resume next
            CollFol(elem).flhash=CollFol(elem).flhash&subhash 'эквивалентно FoldObj.subfolders(elem).hash=subsize 
            if Err then 
                Str=Join(CollFol(elem).flhash.items)
                msgbox "elem "&elem&vbcrlf&"Тип flhash "&Typename(CollFol(elem).flhash)&vbcrlf&"Колличество файлов "&CollFol(elem).flcnt&vbcrlf&Str
                Err.Clear
            end if
            chksums(n)=CollFol(elem).flhash         
            CollFol(elem).size=CollFol(elem).size1+subsize
            CollFol(elem).flcnt=CollFol(elem).flcnt+subcontfl
            'if replace(replace(chksums(n),"\_",""),"*","")="" then
            if CollFol(elem).flcnt=0 then
                CollEmpFol(elem)=chksums(n)
            elseif FoldHashes.exists(chksums(n)) Then
                if not FoldClones.exists(chksums(n)) then 
                    set FoldClones(chksums(n))=Crdict
                    FoldClones(chksums(n))(FoldHashes(chksums(n)))=CollFol(elem).size
                end if
                'FoldClones(chksums(n))(elem)=CollFol(elem).size
                FoldClones(chksums(n))(elem)=""
            else 
                FoldHashes(chksums(n))=elem
            end if
            sumcontfl=sumcontfl+CollFol(elem).flcnt
            sumsize=sumsize+CollFol(elem).size          
            n=n+1
        'end if 
    next    
    'On error resume next
    'hash=FoldObj.flhash&join(chksums,"")
    hash=join(chksums,"")
    'if Err then 
        'MsgBox Err.Description & vbCrlf & Err.HelpContext & vbCrlf & Err.HelpFile & vbCrlf & Err.Number & vbCrlf & Err.Source 
        'MsgBox Path1&vbcrlf&CollFol.exists(left(foldpt,instrRev(foldpt,"\")-1))&" "&CollFol.exists(Path1)
        'MsgBox folpt
        'MsgBox Typename(FoldObj.flhash)
        'MsgBox FoldObj.flhash.count
    'end if
    'size=FoldObj.size1+sumsize
    contfl=sumcontfl
    size=sumsize
end sub
 
Sub Recurs2(FoldObj, folpt)
    Dim arrscl,ccnt,elsz,sz,sz2
    For Each elem in FoldObj.subfolders         
        if CollEmpFol.exists(elem) then 
            EmptyFinal(elem)=CollEmpFol(elem)
            CollEmpFol.remove(elem)
        elseif FoldClones.exists(CollFol(elem).flhash) then     
            elhsh=CollFol(elem).flhash
            elsz=CollFol(elem).size
            ccnt=FoldClones(elhsh).count-1
            sz=ccnt*elsz
            if not ClonesFinal.exists(sz) then          
                set ClonesFinal(sz)=Crdict
            end if
            'ClonesFinal(sz)(elhsh)=BytesTostr(elsz,2)&" * "&ccnt&" = "&BytesTostr(sz,2)&vbcrlf&join(FoldClones(elhsh).keys,vbcrlf)
            set ClonesFinal(sz)(elhsh)=FoldClones(elhsh)
            ClonSumSz=ClonSumSz+sz
            FoldClones.remove(elhsh)
        'elseif Junctions.exists(elem) then 'msgbox "junc "&elem&vbcrlf&Junctions(elem)
        else
            Recurs2 CollFol(elem),elem 'эквивал. Recurs2 FoldObj.subfolders(elem),elem
        end if
    next    
End sub
 
Function Browse4Folder
    Dim objFolder, objFolderItem, objShell, strPrompt, intOptions
    strPrompt = "Выберите каталог для анализа"
    strRoot=""
    intOptions = BIF_RETURNONLYFSDIRS + BIF_EDITBOX + BIF_NONEWFOLDER
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, strPrompt, intOptions, strRoot) 
    If (objFolder Is Nothing) Then
        Browse4Folder = ""
    Else
        Set objFolderItem = objFolder.Self
        Browse4Folder = objFolderItem.Path      
        Set objFolderItem = Nothing
        Set objFolder = Nothing
    End If  
    Set objShell = Nothing
End Function
 
Function BytesToStr(ByVal size2, precision)
    Dim sizes, total, rSize
    sizes=Array(" YB", " Zb", " Eb", " Pb", " Тб", " Гб", " Мб", " Кб", " бит")
    total=Ubound(sizes)
    while size2>1024
      total=total-1  
      size2=size2/1024
    wend
    rSize=round(size2,precision)
    BytesToStr=rSize&sizes(total) 
End Function
 
Function GetMD5(strText)
    Dim i, strResult
    strResult=""
    For i=1 To Len(strText)
        strResult = strResult & ChrB(Asc(Mid(strText, i, 1)))
    Next
    objHashedData.Hash strResult    
    GetMD5=objHashedData.Value
End Function 
 
Function calcCRC32(TextStr)
    Dim i, crc
    If CrcTableInit = False Then Call Init_CRCTable
    crc = -1
    For i = 1 To Len(TextStr)
        crc = (((crc And &HFFFFFF00) \ &H100) And &HFFFFFF) Xor (CRCTable((crc And &HFF) Xor Asc(Mid(TextStr, i, 1))))
    Next
    crc = crc Xor &HFFFFFFFF
    calcCRC32 = crc
End Function
Sub Init_CRCTable()
    'msgbox "crc "&cntcrc
    cntcrc=cntcrc+1
    Dim i, j, Limit, crc
    Limit = &HEDB88320
    For i = 0 To 255
        crc = i
        For j = 0 To 7
            If crc And 1 Then
              crc = (((crc And &HFFFFFFFE) \ 2) And &H7FFFFFFF) Xor Limit
            Else
              crc = ((crc And &HFFFFFFFE) \ 2) And &H7FFFFFFF
            End If
        Next
        CRCTable(i) = crc
    Next
    CrcTableInit = True
End Sub

delegat.vbs

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
Dim gCon, BigFold
Set gCon = New GlobalContainer
gCon.Open "storage"
Set FSO = CreateObject("Scripting.FileSystemObject")
CurDir=Fso.GetParentFolderName(WScript.ScriptFullName)
Function Crdict
    set Crdict=CreateObject("Scripting.Dictionary")
end function
set WshShell = WScript.CreateObject("WScript.Shell")
Set Processes=Crdict
set BigFold=gCon.GetProperty("BigFold") 'подключение к коллекции заданий
gCon.PutProperty "Processes",Processes '"разшаривание" коллекции распределения заданий
gCon.PutProperty "endDeleg",false
'endPars=false '!!!!!
'set BigFold=Crdict
'BigFold("C:\")=""
'BigFold("C:\windows")=""
 
i=0
do until i=4    
    Processes(i)="?"
    'msgbox Processes.exists(i)&vbcrlf&Processes(i)
    WshShell.run(""""&CurDir&"\execut.vbs "&""""&i) 'запуск процессов-обработчиков с передачей им (в качестве параметра) индекса элемента коллекции распределения
    WScript.Sleep(100)
    i=i+1
Loop
 
do until gCon.GetProperty("endPars") and not BigFold.count
    if BigFold.count then
        For Each elem in BigFold
            do While UBound(Filter(Processes.items,"?"))=-1 'ожидание появления свободных процессов-обработчиков
                'msgbox "Все процессы заняты"
                WScript.Sleep(700)
            loop
            For Each elem1 in Processes
                if Processes(elem1)="?" then 
                    Processes(elem1)=elem
                    'msgbox "3й скрипт (распределитель), процесс "&elem1&" задание - "&vbcrlf&Processes(elem1)
                    BigFold.remove(elem)
                    exit For
                end if
            next
        Next
    end if  
    WScript.Sleep(1000)
loop
 
gCon.PutProperty "endDeleg",true 'оповещение об окончании раздачи заданий
 
do Until UBound(Filter(Processes.items,"?"))=3 'ожидание завершения работы всех процессов-обработчиков
    'msgbox "Ожидаем завершения обработчиков"
    WScript.Sleep(1000)
loop
    
    
Class GlobalContainer
    Private wnd, owner
    Sub Open(name)
        For Each wnd in CreateObject("Shell.Application").Windows
            if Instr(1,wnd.GetProperty("container_name"),name) = 1 Then Exit Sub
        Next
        owner = True
        Set wnd = GetObject("new:{C08AFD90-F2A1-11D1-8455-00A0C91F3880}")
        wnd.PutProperty "container_name", name
    End Sub
    
    Sub PutProperty(name, value)    
        wnd.PutProperty name, value
    End Sub
    
    Function GetProperty(name)
        On Error Resume Next
        if IsObject(wnd.GetProperty(name)) Then
            Set GetProperty = wnd.GetProperty(name)
        Else
            GetProperty = wnd.GetProperty(name)
        End if
    End Function
 
    Private Sub Class_Terminate()
        On Error Resume Next
        if owner Then wnd.Quit()
    End Sub
End Class

execut.vbs

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
Dim gCon, Arg, Processes
Set gCon = New GlobalContainer
gCon.Open "storage"
 
Arg=WScript.Arguments(0)*1
set BigFold=gCon.GetProperty("BigFold")
set Processes=gCon.GetProperty("Processes") 'подключение к коллекции распределения заданий
set CollFol=gCon.GetProperty("CollFol")
set calcCRC32=gCon.GetProperty("calcCRC32")
 
 
do until gCon.GetProperty("endDeleg") and not BigFold.count 
    if not Processes(Arg)="?" then 
        target=Processes(Arg)       
        For each elem in CollFol(target).bghash
            CollFol(target).bghash(elem)=calcCRC32(CollFol(target).bghash(elem))
        Next
        CollFol(target).flhash="\"&join(CollFol(target).bghash.items,"")
        CollFol(target).bghash=""
        'msgbox "Процесс №"&Arg&" получил задание"&vbcrlf&target&" результат:"&vbcrlf&CollFol(target).flhash        
        Processes(Arg)="?"
    end if  
    WScript.Sleep(700)
loop
 
 
Class GlobalContainer
    Private wnd, owner
    Sub Open(name)
        For Each wnd in CreateObject("Shell.Application").Windows
            if Instr(1,wnd.GetProperty("container_name"),name) = 1 Then Exit Sub
        Next
        owner = True
        Set wnd = GetObject("new:{C08AFD90-F2A1-11D1-8455-00A0C91F3880}")
        wnd.PutProperty "container_name", name
    End Sub
    
    Sub PutProperty(name, value)    
        wnd.PutProperty name, value
    End Sub
    
    Function GetProperty(name)
        On Error Resume Next
        if IsObject(wnd.GetProperty(name)) Then
            Set GetProperty = wnd.GetProperty(name)
        Else
            GetProperty = wnd.GetProperty(name)
        End if
    End Function
 
    Private Sub Class_Terminate()
        On Error Resume Next
        if owner Then wnd.Quit()
    End Sub
End Class

@testuser2 · 07.02.2020, 12:58 **[ТС]**

Переработал механизм хэширования. И вроде ничего, потребление памяти уменьшилось.. но есть один момент. Если запустить скрипт из notepad++ (с рабочей папкой notepad++) потребление памяти меньше, если запустить из проводника (с рабочей папкой скрипта) потребление больше. Еще один момент - 84 секунды (+-3) преодолеть не получилось. Ставишь больше параллельных процессов - толку ноль. Оптимальное максимальное колличество - 10-20.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
Dim fldpt, flname, a, cnt, flcnt, sel, ClonSumSz, CRCTable(255), CrcTableInit, cntcrc, gCon, endPars, contrCnt
cntcrc=0
'Const CAPICOM_HASH_ALGORITHM_MD2     = 1
'On error resume next
'Set objHashedData = WScript.CreateObject("CAPICOM.HashedData")
'objHashedData.Algorithm=CAPICOM_HASH_ALGORITHM_MD5
'objHashedData.Algorithm=CAPICOM_HASH_ALGORITHM_SHA_256
Set FSO = CreateObject("Scripting.FileSystemObject")
Set File = FSO.OpenTextFile(Fso.GetParentFolderName(WScript.ScriptFullName)&"\fileC.txt", 1)
CurDir=Fso.GetParentFolderName(WScript.ScriptFullName)
WritetxtPt=CurDir&"\folderreportNew.txt"
FoldList=CurDir&"\folders.txt"
BigFoldList=CurDir&"\bigfolders.txt"
DirCmdList=CurDir&"\dircmdlist.txt"
EmpFoldList=CurDir&"\empfoldlist.txt"
set CollFol=Crdict 'основная коллекция папок
set CollEmpFol=Crdict 'коллекция всех папок с нулевым размером
set BigFold=Crdict 'коллекция папок с избыточным колличеством файлов
set EmptyFinal=Crdict 'коллекция нулевых папок без вложенных в них
set Junctions=Crdict 'точки монтирования
set FoldHashes=Crdict 'контрольные суммы
set MisJunc=Crdict 'вспомогательная коллекция по работе с симлинками и джункциями
set FoldClones=Crdict 'папки-клоны с учетом в вложенных
set ClonesFinal=Crdict '-\- без учета вложенности
set Tasks=Crdict
Function Crdict
    set Crdict=CreateObject("Scripting.Dictionary")
end function
set WshShell = WScript.CreateObject("WScript.Shell")
Set gCon = New GlobalContainer
gCon.Open "storage"
gCon.PutProperty "BigFold",BigFold
gCon.PutProperty "CollFol",CollFol
gCon.PutProperty "Tasks",Tasks
gCon.PutProperty "endPars",false
gCon.PutProperty "calcCRC32",getRef("calcCRC32") 'разшаривание функции подсчета CRC32
 
'WScript.Sleep(1000)
 
Path1=Browse4Folder
 
'***Path1="C:\"
'Path1="C:\Users\User\Documents"
'Dialog Path1 'окно выбора папки
'Path1="E:\Programms\FirefoxPortable63.0x64copy"
'Path1="E:\Programms"
Old_Time = Timer 'запуск таймера
'Получение списка папок и файлов из выдачи (stdout) консольной комманды dir
'Stext=CreateObject("WScript.Shell").exec("cmd /c >nul chcp 1251 &&dir/s/o/a """&Path1&""" |findstr/p . |findstr/v ""<DIR>""").stdout.readall
Stext=CreateObject("WScript.Shell").exec("cmd /c >nul chcp 1251 &&dir/s/o/a """&Path1&""" |findstr/p . |findstr/v /e ""<DIR>..........\. <DIR>..........\.\.""").stdout.readall
 
'set OFile = FSO.OpenTextFile(DirCmdList, 2, True)
'OFile.Write(Stext) 'Запись stdout комманды в текстовый файл dircmdlist.txt
'OFile.Close
'msgbox " "
 
ArrTxt=split(Stext,vbcrlf)
 
'***ArrTxt=split(File.readall,vbcrlf)
 
strend=ArrTxt(UBound(ArrTxt)-1)
strend2=ArrTxt(UBound(ArrTxt)-2)
folders=left(strend,instr(strend,"п")-1)*1 'всего папок
files=left(strend2,instr(strend2,"ф")-1)*1 'всего файлов
st1=instr(strend2,"в")+2
st2=instr(strend2,"б")-1
st3=st2-st1
fullsize=Mid(strend2,st1,st3) 'полный размер
 
cnt = 2
if mid(Path1,len(path1))="\" then Path1=left(Path1,len(Path1)-1)
Set CollFol(Path1)=new FoldCl
CollFol(Path1).crd
CollFol(Path1).flhash=""
CurJunc="?"
'Парсинг
 
'WshShell.run(""""&CurDir&"\delegat.vbs "&"""")
set WshDeleg = WshShell.Exec(""""&FSO.GetSpecialFolder(1)&"\WScript.exe"" """&CurDir&"\delegat.vbs""") 'запуск процесса-делегата
 
do until cnt=UBound(ArrTxt)-3
    str=ArrTxt(cnt) 
    if mid(str,2,6)="Содерж" then
        foldpt=Mid(str,19)      
        if Junctions.exists(foldpt) then 
            if instr(Junctions(foldpt),Path1)=1 or MisJunc.exists(Junctions(foldpt)) then 
                CurJunc=foldpt
                Skipfl=true
            else 
                MisJunc(Junctions(foldpt))=foldpt
                CurJunc="?"
            end if
        end if
        if instr(foldpt,CurJunc)=0 then
            Set CollFol(foldpt)=new FoldCl 'создание объекта папки      
            CollFol(foldpt).crd
            'set Hashes(foldpt)=CollFol(foldpt)
            'if foldpt="C:\Windows\WinSxS\Temp\PendingRenames" then msgbox "PendingRenames "&Typename(CollFol(foldpt).flhash)
            if sel then 
                'Добавление папки в коллекцию (создание ссылки) "subfolders" родительской папки.
                set CollFol(left(foldpt,instrRev(foldpt,"\")-1)).subfolders(foldpt)=CollFol(foldpt)
            end if
            sel=true
            Skipfl=false
            CollFol(foldpt).flcnt=0
            contrCnt=0
        end if
    elseif Skipfl=false then
        if Trim(mid(str,18,7))="файлов" then
        'if instr(16,str,"файлов") then
            'if foldpt="C:\Windows\WinSxS\Temp\PendingRenames" then msgbox "C:\Windows\WinSxS\Temp\PendingRenames "&vbcrlf&CollFol(foldpt).flcnt
            if CollFol(foldpt).flcnt=0 then
                if CollFol(foldpt).flhash.count then 
                    CollFol(foldpt).flhash="\"&join(CollFol(foldpt).flhash.items,"")                    
                else
                    CollFol(foldpt).flhash="\_"
                end if
                CollFol(foldpt).size1=0
            else if CollFol(foldpt).flcnt>=2000 Then
                    'CollFol(foldpt).flhash="\"&calcCRC32(join(CollFol(foldpt).flhash.items))
                    CollFol(foldpt).bghash(cnt)=join(CollFol(foldpt).flhash.items,"")
                    'CollFol(foldpt).flhash.removeall
                    CollFol(foldpt).flhash=""
                    Tasks(cnt)=foldpt
                    'msgbox join(CollFol(foldpt).bghash.items,vbcrlf)
                    BigFold(foldpt)=""              
                    'msgbox join(CollFol(foldpt).flhash.items)
                    'Str1=foldpt&vbcrlf&Join(CollFol(foldpt).flhash.items,vbcrlf)
                    'set OFile = FSO.OpenTextFile(CurDir&"\Chcsums\"&cnt&".txt", 2, True)
                    'OFile.Write(Str1) 'Запись списка папок в текстовый файл folders.txt
                    'OFile.Close
                    'msgbox "запись"
                else
                    'CollFol(foldpt).flhash="\"&join(CollFol(foldpt).bghash.items,"")&join(CollFol(foldpt).flhash.items,"")
                    CollFol(foldpt).flhash="\"&join(CollFol(foldpt).flhash.items,"")
                    CollFol(foldpt).bghash=""
                end if
                'CollFol(foldpt).flhash="\_"&GetMD5(replace(join(CollFol(foldpt).flhash.keys,"")," ",""))
                'CollFol(foldpt).flhash=replace(join(CollFol(foldpt).flhash.items,"")," ","")
                CollFol(foldpt).size1=mid(str,25,15)*1
                'if foldpt="C:\Windows\WinSxS\Temp\PendingRenames" then msgbox "C:\Windows\WinSxS\Temp\PendingRenames"&vbcrlf&CollFol(foldpt).flcnt
            end if
        elseif mid(str,22,5)="<DIR>" then 
            'On error resume next
            CollFol(foldpt).flhash(cnt)="*"
            'if Err then 
                'MsgBox Err.Description & vbCrlf & Err.HelpContext & vbCrlf & Err.HelpFile & vbCrlf & Err.Number & vbCrlf & Err.Source 
                'MsgBox Path1&vbcrlf&CollFol.exists(left(foldpt,instrRev(foldpt,"\")-1))&" "&CollFol.exists(Path1)
                'MsgBox foldpt&vbcrlf&CurJunc
                'msgbox instr(foldpt,CurJunc)
                'MsgBox CollFol.exists(foldpt)
                'MsgBox Typename(CollFol(foldpt).flhash)
                'MsgBox FoldObj.flhash.count
            'end if
        else if mid(str,22,10)="<JUNCTION>" or mid(str,22,10)="<SYMLINKD>" then
                flpt=foldpt&"\"&mid(str,37,Instr(38,str,"[")-38)
                'Junctions(flpt)=mid(str,Instr(38,str,"["))
                a=Instr(38,str,"[")+1
                Junctions(flpt)=mid(str,a,len(str)-a)
            end if                  
            CollFol(foldpt).flcnt=CollFol(foldpt).flcnt+1
            contrCnt=contrCnt+1
            CollFol(foldpt).flhash(cnt)=str
            if contrCnt=2000 Then
                CollFol(foldpt).bghash(cnt)=join(CollFol(foldpt).flhash.items,"")
                CollFol(foldpt).flhash.removeall
                'msgbox "Новое задание "
                Tasks(cnt)=foldpt               
                contrCnt=0
            end if
            'flcnt=flcnt+1 'Подсчет общего колличества файлов
        end if
    end if
    ArrTxt(cnt)=""
    cnt=cnt+1   
Loop
do While Tasks.count 'ждать завершения распределения BigFold (хэширования) перед оповещением.
Wscript.sleep (800)
loop
gCon.PutProperty "endPars",true 'оповещение об окончании парсинга
do until WshDeleg.status 'ожидание завершения процесса-распределителя (делегата)
    Wscript.sleep(800)
loop
Set gCon=Nothing
'msgbox "1й этап окончен "
'msgbox CollFol.count
'Str=Join(CollFol.keys,vbcrlf)
'set OFile = FSO.OpenTextFile(FoldList, 2, True)
'OFile.Write(Str) 'Запись списка папок в текстовый файл folders.txt
'OFile.Close
'Str=Join(BigFold.keys,vbcrlf)
'set OFile = FSO.OpenTextFile(BigFoldList, 2, True)
'OFile.Write(Str) 'Запись списка папок в текстовый файл folders.txt
'OFile.Close
'msgbox "Запись файлов выполнена"
FoldCnt=CollFol.count+BigFold.count
set BigFold=Nothing
set ArrTxt=Nothing
'Disk=left(Path1,2)
 
Recurs1 CollFol(Path1),Path1,"",0,0
set FoldHashes=Nothing
set MisJunc=Nothing
ClnCnt=FoldClones.count
EmpCnt=CollEmpFol.count
'str=join(CollEmpFol.keys,vbcrlf)
'set OFile = FSO.OpenTextFile(EmpFoldList, 2, True)
'OFile.Write(Str) 'Запись списка пустых папок в текстовый файл emfoldlist.txt
'OFile.Close
 
Recurs2 CollFol(Path1),Path1
set CollFol=Nothing
'CollFol.removeall
FoldClones.removeall
 
'Подготовка и вывод итогов в диалоговое окно и в отчет
Dim ArrClnSz, n, str0, str1, str2, str3, StrFinal, OFile, SumSz, var
SumSz=0
if ClonesFinal.count then   
    ArrClnSz=ClonesFinal.keys
    'Cортировка массива размеров групп клонов
    for a = UBound(ArrClnSz) - 1 To 0 Step -1
        for j= 0 to a
            if ArrClnSz(j)<ArrClnSz(j+1) then
                temp=ArrClnSz(j+1)
                ArrClnSz(j+1)=ArrClnSz(j)
                ArrClnSz(j)=temp
            end if
        next
    next
    n=0 
    For Each elem in ArrClnSz
        Redim preserve Arr(n)
        var=""      
        For Each item in ClonesFinal(elem).items
            ccnt=item.count-1
            elsz=elem/ccnt
            prcnt=round(elem*100/ClonSumSz,2)
            var=var&BytesTostr(elsz,2)&" * "&ccnt&" = "&BytesTostr(elem,2)&" ("&prcnt&"%)"&vbcrlf&join(item.keys,vbcrlf)&vbcrlf
        next
        Arr(n)=var      
        n=n+1
    next
end if
Time_Elapsed=Timer-Old_Time
prcnt=round(ClonSumSz*100/fullsize,2)
msgbox Path1&vbcrlf&FoldCnt&" папок, "&files&" файлов, размер "&BytesToStr(fullsize,2)&vbcrlf&vbcrlf&"Папок-клонов (групп) без учета вложенности "&ClonesFinal.count&vbcrlf&"Общий размер, занимаемый папками-дублями "&BytesToStr(ClonSumSz,2)&" ("&prcnt&"%)"&vbcrlf&"Пустых папок без учета вложенности "&EmptyFinal.count&vbcrlf&vbcrlf&"Папок-клонов (групп) всего "&ClnCnt&vbCrlf&"Пустых папок всего "&EmpCnt&vbcrlf&vbcrlf&"Точек монтирования и симлинков "&Junctions.count&vbcrlf&vbcrlf&"Затрачено времени " &round(Time_Elapsed,3)&" c"
str0=Path1&": "&FoldCnt&" папок "&files&" файлов, размер "&BytesToStr(fullsize,2)
str1="Папки-клоны ("&ClonesFinal.count&" групп), общий занимаемый папками-дублями размер "&BytesToStr(ClonSumSz,2)&" ("&prcnt&"%)"&vbcrlf&vbcrlf&join(Arr,vbcrlf)
 
n=0
Redim Arr(0)
For Each elem in Junctions
    Redim preserve Arr(n)
    Arr(n)=elem&vbcrlf&"["&Junctions(elem)&"]"
    n=n+1
next
ln="============================================================="
str2=ln&vbcrlf&"Точки монтирования и симлинки ("&Junctions.count&" шт.)"&vbcrlf&vbcrlf&join(Arr,vbcrlf&vbcrlf)
n=0
Redim Arr(0)
For Each elem in EmptyFinal
    Redim preserve Arr(n)
    Arr(n)=elem&vbcrlf&EmptyFinal(elem)
    n=n+1
next
str3=ln&vbcrlf&"Пустые папки и их структура вложенности ("&EmptyFinal.count&" шт.)"&vbcrlf&vbcrlf&join(Arr,vbcrlf)
StrFinal=str0&vbcrlf&vbcrlf&ln&vbcrlf&str1&vbcrlf&str2&vbcrlf&vbcrlf&str3
 
set OFile = FSO.OpenTextFile(WritetxtPt, 2, True)
OFile.Write(StrFinal) 'Запись отчета в текстовый файл
OFile.Close
 
Set oShell = CreateObject("WScript.Shell")
oShell.Run WritetxtPt 'Запуск текстового файла с отчетом
 
'КОНЕЦ!!!
 
'--------------------Классы---------------------------
Class FoldCl
    dim size, size1, subfolders, flhash, bghash, flcnt, files
    sub crd
        set flhash=Crdict '=CreateObject("Scripting.Dictionary")
        set bghash=Crdict
        'set files=Crdict
        set subfolders=Crdict
    End sub
    sub res(x)
        Redim preserve flhash(x)
    End sub
End Class
 
Class GlobalContainer
    Private wnd, owner
    Sub Open(name)
        For Each wnd in CreateObject("Shell.Application").Windows
            if Instr(1,wnd.GetProperty("container_name"),name) = 1 Then Exit Sub
        Next
        owner = True
        Set wnd = GetObject("new:{C08AFD90-F2A1-11D1-8455-00A0C91F3880}")
        wnd.PutProperty "container_name", name
    End Sub
    
    Sub PutProperty(name, value)    
        wnd.PutProperty name, value
    End Sub
    
    Function GetProperty(name)
        On Error Resume Next
        if IsObject(wnd.GetProperty(name)) Then
            Set GetProperty = wnd.GetProperty(name)
        Else
            GetProperty = wnd.GetProperty(name)
        End if
    End Function
 
    Private Sub Class_Terminate()
        On Error Resume Next
        if owner Then wnd.Quit()
    End Sub
End Class
'--------------------Функции---------------------------      
Sub Recurs1(FoldObj,folpt,hash,size,contfl)
    dim subhash, n, chksums(),sumsize,subsize,subcontfl, sumcontfl
    n=0
    sumsize=0
    sumcontfl=0
    For each elem in FoldObj.subfolders     
        'if not Junctions.exists(elem) then
            Redim preserve chksums(n)
            Recurs1 CollFol(elem),elem,subhash,subsize,subcontfl
            'On error resume next
            CollFol(elem).flhash=CollFol(elem).flhash&subhash 'эквивалентно FoldObj.subfolders(elem).hash=subsize 
            if Err then 
                Str=Join(CollFol(elem).flhash.items)
                msgbox "elem "&elem&vbcrlf&"Тип flhash "&Typename(CollFol(elem).flhash)&vbcrlf&"Колличество файлов "&CollFol(elem).flcnt&vbcrlf&Str
                Err.Clear
            end if
            chksums(n)=CollFol(elem).flhash         
            CollFol(elem).size=CollFol(elem).size1+subsize
            CollFol(elem).flcnt=CollFol(elem).flcnt+subcontfl
            'if replace(replace(chksums(n),"\_",""),"*","")="" then
            if CollFol(elem).flcnt=0 then
                CollEmpFol(elem)=chksums(n)
            elseif FoldHashes.exists(chksums(n)) Then
                if not FoldClones.exists(chksums(n)) then 
                    set FoldClones(chksums(n))=Crdict
                    FoldClones(chksums(n))(FoldHashes(chksums(n)))=CollFol(elem).size
                end if
                'FoldClones(chksums(n))(elem)=CollFol(elem).size
                FoldClones(chksums(n))(elem)=""
            else 
                FoldHashes(chksums(n))=elem
            end if
            sumcontfl=sumcontfl+CollFol(elem).flcnt
            sumsize=sumsize+CollFol(elem).size          
            n=n+1
        'end if 
    next    
    'On error resume next
    'hash=FoldObj.flhash&join(chksums,"")
    hash=join(chksums,"")
    'if Err then 
        'MsgBox Err.Description & vbCrlf & Err.HelpContext & vbCrlf & Err.HelpFile & vbCrlf & Err.Number & vbCrlf & Err.Source 
        'MsgBox Path1&vbcrlf&CollFol.exists(left(foldpt,instrRev(foldpt,"\")-1))&" "&CollFol.exists(Path1)
        'MsgBox folpt
        'MsgBox Typename(FoldObj.flhash)
        'MsgBox FoldObj.flhash.count
    'end if
    'size=FoldObj.size1+sumsize
    contfl=sumcontfl
    size=sumsize
end sub
 
Sub Recurs2(FoldObj, folpt)
    Dim arrscl,ccnt,elsz,sz,sz2
    For Each elem in FoldObj.subfolders         
        if CollEmpFol.exists(elem) then 
            EmptyFinal(elem)=CollEmpFol(elem)
            CollEmpFol.remove(elem)
        elseif FoldClones.exists(CollFol(elem).flhash) then     
            elhsh=CollFol(elem).flhash
            elsz=CollFol(elem).size
            ccnt=FoldClones(elhsh).count-1
            sz=ccnt*elsz
            if not ClonesFinal.exists(sz) then          
                set ClonesFinal(sz)=Crdict
            end if
            'ClonesFinal(sz)(elhsh)=BytesTostr(elsz,2)&" * "&ccnt&" = "&BytesTostr(sz,2)&vbcrlf&join(FoldClones(elhsh).keys,vbcrlf)
            set ClonesFinal(sz)(elhsh)=FoldClones(elhsh)
            ClonSumSz=ClonSumSz+sz
            FoldClones.remove(elhsh)
        'elseif Junctions.exists(elem) then 'msgbox "junc "&elem&vbcrlf&Junctions(elem)
        else
            Recurs2 CollFol(elem),elem 'эквивал. Recurs2 FoldObj.subfolders(elem),elem
        end if
    next    
End sub
 
Function Browse4Folder
    Dim objFolder, objFolderItem, objShell, strPrompt, intOptions
    strPrompt = "Выберите каталог для анализа"
    strRoot=""
    intOptions = BIF_RETURNONLYFSDIRS + BIF_EDITBOX + BIF_NONEWFOLDER
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, strPrompt, intOptions, strRoot) 
    If (objFolder Is Nothing) Then
        Browse4Folder = ""
    Else
        Set objFolderItem = objFolder.Self
        Browse4Folder = objFolderItem.Path      
        Set objFolderItem = Nothing
        Set objFolder = Nothing
    End If  
    Set objShell = Nothing
End Function
 
Function BytesToStr(ByVal size2, precision)
    Dim sizes, total, rSize
    sizes=Array(" YB", " Zb", " Eb", " Pb", " Тб", " Гб", " Мб", " Кб", " бит")
    total=Ubound(sizes)
    while size2>1024
      total=total-1  
      size2=size2/1024
    wend
    rSize=round(size2,precision)
    BytesToStr=rSize&sizes(total) 
End Function
 
Function GetMD5(strText)
    Dim i, strResult
    strResult=""
    For i=1 To Len(strText)
        strResult = strResult & ChrB(Asc(Mid(strText, i, 1)))
    Next
    objHashedData.Hash strResult    
    GetMD5=objHashedData.Value
End Function 
 
Function calcCRC32(TextStr)
    Dim i, crc
    If CrcTableInit = False Then Call Init_CRCTable
    crc = -1
    For i = 1 To Len(TextStr)
        crc = (((crc And &HFFFFFF00) \ &H100) And &HFFFFFF) Xor (CRCTable((crc And &HFF) Xor Asc(Mid(TextStr, i, 1))))
    Next
    crc = crc Xor &HFFFFFFFF
    'TextStr=crc
    calcCRC32 = crc
End Function
Sub Init_CRCTable()
    'msgbox "crc "&cntcrc
    cntcrc=cntcrc+1
    Dim i, j, Limit, crc
    Limit = &HEDB88320
    For i = 0 To 255
        crc = i
        For j = 0 To 7
            If crc And 1 Then
              crc = (((crc And &HFFFFFFFE) \ 2) And &H7FFFFFFF) Xor Limit
            Else
              crc = ((crc And &HFFFFFFFE) \ 2) And &H7FFFFFFF
            End If
        Next
        CRCTable(i) = crc
    Next
    CrcTableInit = True
End Sub

delegat.vbs

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
Dim gCon, Tasks, PID
Set gCon = New GlobalContainer
gCon.Open "storage"
Set FSO = CreateObject("Scripting.FileSystemObject")
CurDir=Fso.GetParentFolderName(WScript.ScriptFullName)
Function Crdict
    set Crdict=CreateObject("Scripting.Dictionary")
end function
set WshShell = WScript.CreateObject("WScript.Shell")
Set Processes=Crdict
Set ProcReady=Crdict
'MsgBox "«начение переменной ""test"": " & gCon.GetProperty("test") ,vbInformation
'MsgBox "“ип переменной ""fso"": " & TypeName(gCon.GetProperty("fso")),vbInformation
set Tasks=gCon.GetProperty("Tasks") 'подключение к коллекции заданий
set BigFold=gCon.GetProperty("BigFold")
set CollFol=gCon.GetProperty("CollFol")
gCon.PutProperty "Processes",Processes '"разшаривание" коллекции распределения заданий
gCon.PutProperty "ProcReady",ProcReady
gCon.PutProperty "endDeleg",false
endPars=false '!!!!!
'set Tasks=Crdict
'Tasks("C:\")=""
'Tasks("C:\windows")=""
 
do until gCon.GetProperty("endPars") and not Tasks.count
    if Tasks.count then
        For Each elem in Tasks
            if ProcReady.count=0 and Processes.count<20 then
                'if ProcReady.count=4 then msgbox "Колличество работающих процессов "&ProcReady.count
                PID=WshShell.Exec(""""&FSO.GetSpecialFolder(1)&"\WScript.exe"" """&CurDir&"\execut.vbs""").ProcessID
                Processes(PID)=Array(Tasks(elem),elem)
                Tasks.remove(elem)
                WScript.Sleep(50)
                'msgbox "Распределитель: процесс "&PID&" получил задание - "&vbcrlf&Processes(PID)(0)&vbcrlf&Processes(PID)(1)
            else                
                'For Each PID in ProcReady
                do until ProcReady.count
                    WScript.Sleep(500)
                loop
                PID=Filter(ProcReady.keys,"")(0)
                'msgbox PID&" повторное задание"
                ProcReady.remove(PID)
                Processes(PID)=Array(Tasks(elem),elem)
                Tasks.remove(elem)
                'msgbox "Распределитель: процесс "&PID&" получил повторное задание - "&vbcrlf&Processes(PID)(0)&vbcrlf&Processes(PID)(1)                
                'exit For
                'next
            end if
        Next
    end if  
    WScript.Sleep(700)
loop
 
gCon.PutProperty "endDeleg",true 'оповещение об окончании раздачи заданий
'WScript.Sleep(5000)
'msgbox "Processes.count "&Processes.count
do While Processes.count 'ожидание завершения работы всех процессов-обработчиков
    'msgbox "Ожидаем завершения обработчиков"
    WScript.Sleep(800)
loop
 
For each elem in BigFold
    CollFol(elem).flhash="\"&join(CollFol(elem).bghash.items,"")
    'msgbox CollFol(elem).flhash
Next
    
Class GlobalContainer
    Private wnd, owner
    Sub Open(name)
        For Each wnd in CreateObject("Shell.Application").Windows
            if Instr(1,wnd.GetProperty("container_name"),name) = 1 Then Exit Sub
        Next
        owner = True
        Set wnd = GetObject("new:{C08AFD90-F2A1-11D1-8455-00A0C91F3880}")
        wnd.PutProperty "container_name", name
    End Sub
    
    Sub PutProperty(name, value)    
        wnd.PutProperty name, value
    End Sub
    
    Function GetProperty(name)
        On Error Resume Next
        if IsObject(wnd.GetProperty(name)) Then
            Set GetProperty = wnd.GetProperty(name)
        Else
            GetProperty = wnd.GetProperty(name)
        End if
    End Function
 
    Private Sub Class_Terminate()
        On Error Resume Next
        if owner Then wnd.Quit()
    End Sub
End Class

execut.vbs

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
Dim gCon, PID, Processes
Set gCon = New GlobalContainer
gCon.Open "storage"
'Arg=WScript.Arguments(0)*1
set BigFold=gCon.GetProperty("BigFold")
set Processes=gCon.GetProperty("Processes") 'подключение к коллекции распределения заданий
set ProcReady=gCon.GetProperty("ProcReady")
set CollFol=gCon.GetProperty("CollFol")
set calcCRC32=gCon.GetProperty("calcCRC32")
PID=GetPID 'получение собственного пида процесса скрипта
'msgbox "пауза"
 
n=0
do until gCon.GetProperty("endDeleg") and not isArray(Processes(PID))   
    if isArray(Processes(PID)) then
        n=0
        target=Processes(PID)       
        'msgbox "Исполнитель: получено задание "&vbcrlf&target(0)&vbcrlf&target(1)&vbcrlf&CollFol(target(0)).bghash(target(1))
        CollFol(target(0)).bghash(target(1))=calcCRC32(CollFol(target(0)).bghash(target(1)))
        'msgbox "CollFol(target(0)).bghash(target(1))="&CollFol(target(0)).bghash(target(1))
        Processes(PID)=""
        ProcReady(PID)=""
    end if
    n=n+1
    if n=10 then exit do  'если задание не поступило в течении 7 секунд (700*10) завершать скрипт
    WScript.Sleep(700)
loop
Processes.remove(PID)
ProcReady.remove(PID)
 
Class GlobalContainer
    Private wnd, owner
    Sub Open(name)
        For Each wnd in CreateObject("Shell.Application").Windows
            if Instr(1,wnd.GetProperty("container_name"),name) = 1 Then Exit Sub
        Next
        owner = True
        Set wnd = GetObject("new:{C08AFD90-F2A1-11D1-8455-00A0C91F3880}")
        wnd.PutProperty "container_name", name
    End Sub
    
    Sub PutProperty(name, value)    
        wnd.PutProperty name, value
    End Sub
    
    Function GetProperty(name)
        On Error Resume Next
        if IsObject(wnd.GetProperty(name)) Then
            Set GetProperty = wnd.GetProperty(name)
        Else
            GetProperty = wnd.GetProperty(name)
        End if
    End Function
 
    Private Sub Class_Terminate()
        On Error Resume Next
        if owner Then wnd.Quit()
    End Sub
End Class
 
Function GetPID
    With GetObject("winmgmts:root\cimv2:win32_process.Handle='" &_
        CreateObject("WScript.Shell").Exec("rundll32 kernel32,Sleep").ProcessId & "'")
        GetPID = .ParentProcessId
        .Terminate
    End With
End Function

@testuser2 · 07.02.2020, 16:44 **[ТС]**

Сообщение от testuser2

Если запустить скрипт из notepad++ (с рабочей папкой notepad++) потребление памяти меньше

Дело, как выяснилось, не в рабочей дирректории, а вот в чем, wscript, запущенный из SysWOW64 требует меньше памяти (процентов так, на 40) для работы чем из System32 и работатет, вроде бы чуть медленнее (не критично)

Сообщение от testuser2

объекты перестают освобождать память при их уничтожении

Проблемма решилась добавлением функции закрытия "окна" в класс "GlobalContainer"

Visual Basic
1
2
3
Sub Quit()        
        wnd.Quit()
End Sub

@testuser2 · 08.02.2020, 16:38 **[ТС]**

Кликните здесь для просмотра всего текста

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
Dim fldpt, flname, a, cnt, flcnt, sel, ClonSumSz, CRCTable(255), CrcTableInit, cntcrc, gCon, endPars, contrCnt
cntcrc=0
'Const CAPICOM_HASH_ALGORITHM_MD2     = 1
'On error resume next
'Set objHashedData = WScript.CreateObject("CAPICOM.HashedData")
'objHashedData.Algorithm=CAPICOM_HASH_ALGORITHM_MD5
'objHashedData.Algorithm=CAPICOM_HASH_ALGORITHM_SHA_256
Set FSO = CreateObject("Scripting.FileSystemObject")
CurDir=Fso.GetParentFolderName(WScript.ScriptFullName)
WritetxtPt=CurDir&"\folderreportNew.txt"
FoldList=CurDir&"\folders.txt"
BigFoldList=CurDir&"\bigfolders.txt"
DirCmdList=CurDir&"\dircmdlist.txt"
EmpFoldList=CurDir&"\empfoldlist.txt"
set CollFol=Crdict 'основная коллекция папок
set CollEmpFol=Crdict 'коллекция всех папок с нулевым размером
set BigFold=Crdict 'коллекция папок с избыточным колличеством файлов
set EmptyFinal=Crdict 'коллекция нулевых папок без вложенных в них
set Junctions=Crdict 'точки монтирования
set FoldHashes=Crdict 'контрольные суммы
set MisJunc=Crdict 'вспомогательная коллекция по работе с симлинками и джункциями
set FoldClones=Crdict 'папки-клоны с учетом в вложенных
set ClonesFinal=Crdict '-\- без учета вложенности
set Tasks=Crdict
Function Crdict
    set Crdict=CreateObject("Scripting.Dictionary")
end function
set WshShell = WScript.CreateObject("WScript.Shell")
Set gCon = New GlobalContainer
gCon.Open "storage"
gCon.PutProperty "BigFold",BigFold
gCon.PutProperty "CollFol",CollFol
gCon.PutProperty "Tasks",Tasks
gCon.PutProperty "endPars",false
gCon.PutProperty "calcCRC32",getRef("calcCRC32") 'разшаривание функции подсчета CRC32
 
'Path1="C:\Users\User\Documents"
'Dialog Path1 'окно выбора папки
'Path1="E:\Programms\FirefoxPortable63.0x64copy"
'Path1="E:\Programms"
Old_Time = Timer 'запуск таймера
 
Path1=Browse4Folder
'Получение списка папок и файлов из выдачи (stdout) консольной комманды dir
Stext=CreateObject("WScript.Shell").exec("cmd /c >nul chcp 1251 &&dir/s/o/a """&Path1&""" |findstr/p . |findstr/v /e ""<DIR>..........\. <DIR>..........\.\.""").stdout.readall
ArrTxt=split(Stext,vbcrlf)
 
'Запись stdout комманды в текстовый файл dircmdlist.txt
'set OFile = FSO.OpenTextFile(DirCmdList, 2, True)
'OFile.Write(Stext)
'OFile.Close
'msgbox " "
 
' **Set File = FSO.OpenTextFile(Fso.GetParentFolderName(WScript.ScriptFullName)&"\fileC.txt", 1)
' **Path1="C:\"
' **ArrTxt=split(File.readall,vbcrlf)
 
strend=ArrTxt(UBound(ArrTxt)-1)
strend2=ArrTxt(UBound(ArrTxt)-2)
folders=left(strend,instr(strend,"п")-1)*1 'всего папок
files=left(strend2,instr(strend2,"ф")-1)*1 'всего файлов
st1=instr(strend2,"в")+2
st2=instr(strend2,"б")-1
st3=st2-st1
fullsize=Mid(strend2,st1,st3) 'полный размер
 
cnt = 2
if mid(Path1,len(path1))="\" then Path1=left(Path1,len(Path1)-1)
Set CollFol(Path1)=new FoldCl
CollFol(Path1).crd
CollFol(Path1).flhash=""
CurJunc="?"
'Парсинг
 
'WshShell.run(""""&CurDir&"\delegat.vbs "&"""")
'set WshDeleg = WshShell.Exec(""""&FSO.GetSpecialFolder(1)&"\WScript.exe"" """&CurDir&"\delegat.vbs""") 'запуск процесса-делегата
 
set WshDeleg=WshShell.Exec(""""&WScript.fullname&""" """&CurDir&"\delegat.vbs""") 'запуск процесса-делегата
 
do until cnt=UBound(ArrTxt)-3
    str=ArrTxt(cnt) 
    if mid(str,2,6)="Содерж" then
        foldpt=Mid(str,19)      
        if Junctions.exists(foldpt) then 
            if instr(Junctions(foldpt),Path1)=1 or MisJunc.exists(Junctions(foldpt)) then 
                CurJunc=foldpt
                Skipfl=true
            else 
                MisJunc(Junctions(foldpt))=foldpt
                CurJunc="?"
            end if
        end if
        if instr(foldpt,CurJunc)=0 then
            Set CollFol(foldpt)=new FoldCl 'создание объекта папки      
            CollFol(foldpt).crd
            'set Hashes(foldpt)=CollFol(foldpt)
            'if foldpt="C:\Windows\WinSxS\Temp\PendingRenames" then msgbox "PendingRenames "&Typename(CollFol(foldpt).flhash)
            if sel then 
                'Добавление папки в коллекцию (создание ссылки) "subfolders" родительской папки.
                set CollFol(left(foldpt,instrRev(foldpt,"\")-1)).subfolders(foldpt)=CollFol(foldpt)
            end if
            sel=true
            Skipfl=false
            CollFol(foldpt).flcnt=0
            contrCnt=0
        end if
    elseif Skipfl=false then
        if Trim(mid(str,18,7))="файлов" then
        'if instr(16,str,"файлов") then
            'if foldpt="C:\Windows\WinSxS\Temp\PendingRenames" then msgbox "C:\Windows\WinSxS\Temp\PendingRenames "&vbcrlf&CollFol(foldpt).flcnt
            if CollFol(foldpt).flcnt=0 then
                if CollFol(foldpt).flhash.count then 
                    CollFol(foldpt).flhash="\"&join(CollFol(foldpt).flhash.items,"")                    
                else
                    CollFol(foldpt).flhash="\_"
                end if
                CollFol(foldpt).size1=0
            else if CollFol(foldpt).flcnt>=2000 Then
                    'CollFol(foldpt).flhash="\"&calcCRC32(join(CollFol(foldpt).flhash.items))
                    CollFol(foldpt).bghash(cnt)=join(CollFol(foldpt).flhash.items,"")
                    CollFol(foldpt).flhash=""
                    Tasks(cnt)=foldpt
                    'msgbox join(CollFol(foldpt).bghash.items,vbcrlf)
                    BigFold(foldpt)=""              
                    'Str1=foldpt&vbcrlf&Join(CollFol(foldpt).flhash.items,vbcrlf)
                    'set OFile = FSO.OpenTextFile(CurDir&"\Chcsums\"&cnt&".txt", 2, True)
                    'OFile.Write(Str1) 'Запись списка папок в текстовый файл folders.txt
                    'OFile.Close
                    'msgbox "запись"
                else
                    'CollFol(foldpt).flhash="\"&join(CollFol(foldpt).bghash.items,"")&join(CollFol(foldpt).flhash.items,"")
                    CollFol(foldpt).flhash="\"&join(CollFol(foldpt).flhash.items,"")
                    CollFol(foldpt).bghash=""
                end if
                'CollFol(foldpt).flhash="\_"&GetMD5(replace(join(CollFol(foldpt).flhash.keys,"")," ",""))
                'CollFol(foldpt).flhash=replace(join(CollFol(foldpt).flhash.items,"")," ","")
                CollFol(foldpt).size1=mid(str,25,15)*1
                'if foldpt="C:\Windows\WinSxS\Temp\PendingRenames" then msgbox "C:\Windows\WinSxS\Temp\PendingRenames"&vbcrlf&CollFol(foldpt).flcnt
            end if
        elseif mid(str,22,5)="<DIR>" then 
            'On error resume next
            CollFol(foldpt).flhash(cnt)="*"
            'if Err then 
                'MsgBox Err.Description & vbCrlf & Err.HelpContext & vbCrlf & Err.HelpFile & vbCrlf & Err.Number & vbCrlf & Err.Source 
                'MsgBox Path1&vbcrlf&CollFol.exists(left(foldpt,instrRev(foldpt,"\")-1))&" "&CollFol.exists(Path1)
                'MsgBox foldpt&vbcrlf&CurJunc
                'msgbox instr(foldpt,CurJunc)
                'MsgBox CollFol.exists(foldpt)
                'MsgBox Typename(CollFol(foldpt).flhash)
                'MsgBox FoldObj.flhash.count
            'end if
        else if mid(str,22,10)="<JUNCTION>" or mid(str,22,10)="<SYMLINKD>" then
                flpt=foldpt&"\"&mid(str,37,Instr(38,str,"[")-38)
                'Junctions(flpt)=mid(str,Instr(38,str,"["))
                a=Instr(38,str,"[")+1
                Junctions(flpt)=mid(str,a,len(str)-a)
            end if                  
            CollFol(foldpt).flcnt=CollFol(foldpt).flcnt+1
            contrCnt=contrCnt+1
            CollFol(foldpt).flhash(cnt)=str
            if contrCnt=2000 Then
                CollFol(foldpt).bghash(cnt)=join(CollFol(foldpt).flhash.items,"")
                CollFol(foldpt).flhash.removeall
                'msgbox "Новое задание "
                Tasks(cnt)=foldpt               
                contrCnt=0
            end if
            'flcnt=flcnt+1 'Подсчет общего колличества файлов
        end if
    end if
    ArrTxt(cnt)=""
    cnt=cnt+1   
Loop
do While Tasks.count 'ждать завершения распределения BigFold (хэширования) перед оповещением.
Wscript.sleep (800)
loop
gCon.PutProperty "endPars",true 'оповещение об окончании парсинга
do until WshDeleg.status 'ожидание завершения процесса-распределителя (делегата)
    Wscript.sleep(800)
loop
gCon.Quit
Set gCon=Nothing
'msgbox "1й этап окончен "
'msgbox CollFol.count
'Str=Join(CollFol.keys,vbcrlf)
'set OFile = FSO.OpenTextFile(FoldList, 2, True)
'OFile.Write(Str) 'Запись списка папок в текстовый файл folders.txt
'OFile.Close
'Str=Join(BigFold.keys,vbcrlf)
'set OFile = FSO.OpenTextFile(BigFoldList, 2, True)
'OFile.Write(Str) 'Запись списка папок в текстовый файл folders.txt
'OFile.Close
'msgbox "Запись файлов выполнена"
FoldCnt=CollFol.count+BigFold.count
set BigFold=Nothing
set ArrTxt=Nothing
'Disk=left(Path1,2)
 
Recurs1 CollFol(Path1),Path1,"",0,0
set FoldHashes=Nothing
set MisJunc=Nothing
ClnCnt=FoldClones.count
EmpCnt=CollEmpFol.count
'str=join(CollEmpFol.keys,vbcrlf)
'set OFile = FSO.OpenTextFile(EmpFoldList, 2, True)
'OFile.Write(Str) 'Запись списка пустых папок в текстовый файл emfoldlist.txt
'OFile.Close
 
Recurs2 CollFol(Path1),Path1
set CollFol=Nothing
'CollFol.removeall
FoldClones.removeall
 
'Подготовка и вывод итогов в диалоговое окно и в отчет
Dim ArrClnSz, n, str0, str1, str2, str3, StrFinal, OFile, SumSz, var
SumSz=0
if ClonesFinal.count then   
    ArrClnSz=ClonesFinal.keys
    'Cортировка массива размеров групп клонов
    for a = UBound(ArrClnSz) - 1 To 0 Step -1
        for j= 0 to a
            if ArrClnSz(j)<ArrClnSz(j+1) then
                temp=ArrClnSz(j+1)
                ArrClnSz(j+1)=ArrClnSz(j)
                ArrClnSz(j)=temp
            end if
        next
    next
    n=0 
    For Each elem in ArrClnSz
        Redim preserve Arr(n)
        var=""      
        For Each item in ClonesFinal(elem).items
            ccnt=item.count-1
            elsz=elem/ccnt
            prcnt=round(elem*100/ClonSumSz,2)
            var=var&BytesTostr(elsz,2)&" * "&ccnt&" = "&BytesTostr(elem,2)&" ("&prcnt&"%)"&vbcrlf&join(item.keys,vbcrlf)&vbcrlf
        next
        Arr(n)=var      
        n=n+1
    next
end if
Time_Elapsed=Timer-Old_Time
prcnt=round(ClonSumSz*100/fullsize,2)
msgbox Path1&vbcrlf&FoldCnt&" папок, "&files&" файлов, размер "&BytesToStr(fullsize,2)&vbcrlf&vbcrlf&"Папок-клонов (групп) без учета вложенности "&ClonesFinal.count&vbcrlf&"Общий размер, занимаемый папками-дублями "&BytesToStr(ClonSumSz,2)&" ("&prcnt&"%)"&vbcrlf&"Пустых папок без учета вложенности "&EmptyFinal.count&vbcrlf&vbcrlf&"Папок-клонов (групп) всего "&ClnCnt&vbCrlf&"Пустых папок всего "&EmpCnt&vbcrlf&vbcrlf&"Точек монтирования и симлинков "&Junctions.count&vbcrlf&vbcrlf&"Затрачено времени " &round(Time_Elapsed,3)&" c"
str0=Path1&": "&FoldCnt&" папок "&files&" файлов, размер "&BytesToStr(fullsize,2)
str1="Папки-клоны ("&ClonesFinal.count&" групп), общий занимаемый папками-дублями размер "&BytesToStr(ClonSumSz,2)&" ("&prcnt&"%)"&vbcrlf&vbcrlf&join(Arr,vbcrlf)
 
n=0
Redim Arr(0)
For Each elem in Junctions
    Redim preserve Arr(n)
    Arr(n)=elem&vbcrlf&"["&Junctions(elem)&"]"
    n=n+1
next
ln="============================================================="
str2=ln&vbcrlf&"Точки монтирования и симлинки ("&Junctions.count&" шт.)"&vbcrlf&vbcrlf&join(Arr,vbcrlf&vbcrlf)
n=0
Redim Arr(0)
For Each elem in EmptyFinal
    Redim preserve Arr(n)
    Arr(n)=elem&vbcrlf&EmptyFinal(elem)
    n=n+1
next
str3=ln&vbcrlf&"Пустые папки и их структура вложенности ("&EmptyFinal.count&" шт.)"&vbcrlf&vbcrlf&join(Arr,vbcrlf)
StrFinal=str0&vbcrlf&vbcrlf&ln&vbcrlf&str1&vbcrlf&str2&vbcrlf&vbcrlf&str3
 
set OFile = FSO.OpenTextFile(WritetxtPt, 2, True)
OFile.Write(StrFinal) 'Запись отчета в текстовый файл
OFile.Close
 
Set oShell = CreateObject("WScript.Shell")
oShell.Run WritetxtPt 'Запуск текстового файла с отчетом
 
'КОНЕЦ!!!
 
'--------------------Классы---------------------------
Class FoldCl
    dim size, size1, subfolders, flhash, bghash, flcnt, files
    sub crd
        set flhash=Crdict '=CreateObject("Scripting.Dictionary")
        set bghash=Crdict
        'set files=Crdict
        set subfolders=Crdict
    End sub
    sub res(x)
        Redim preserve flhash(x)
    End sub
End Class
 
Class GlobalContainer
    Private wnd, owner
    Sub Open(name)
        For Each wnd in CreateObject("Shell.Application").Windows
            if Instr(1,wnd.GetProperty("container_name"),name) = 1 Then Exit Sub
        Next
        owner = True
        Set wnd = GetObject("new:{C08AFD90-F2A1-11D1-8455-00A0C91F3880}")
        wnd.PutProperty "container_name", name
    End Sub
    
    Sub PutProperty(name, value)    
        wnd.PutProperty name, value
    End Sub
    
    Function GetProperty(name)
        On Error Resume Next
        if IsObject(wnd.GetProperty(name)) Then
            Set GetProperty = wnd.GetProperty(name)
        Else
            GetProperty = wnd.GetProperty(name)
        End if
    End Function
    
    Sub Quit()        
        wnd.Quit()
    End Sub
    
    Private Sub Class_Terminate()
        On Error Resume Next
        if owner Then wnd.Quit()
    End Sub
End Class
'--------------------Функции---------------------------      
Sub Recurs1(FoldObj,folpt,hash,size,contfl)
    dim subhash, n, chksums(),sumsize,subsize,subcontfl, sumcontfl
    n=0
    sumsize=0
    sumcontfl=0
    For each elem in FoldObj.subfolders     
        'if not Junctions.exists(elem) then
            Redim preserve chksums(n)
            Recurs1 CollFol(elem),elem,subhash,subsize,subcontfl
            'On error resume next
            CollFol(elem).flhash=CollFol(elem).flhash&subhash 'эквивалентно FoldObj.subfolders(elem).hash=subsize 
            if Err then 
                Str=Join(CollFol(elem).flhash.items)
                msgbox "elem "&elem&vbcrlf&"Тип flhash "&Typename(CollFol(elem).flhash)&vbcrlf&"Колличество файлов "&CollFol(elem).flcnt&vbcrlf&Str
                Err.Clear
            end if
            chksums(n)=CollFol(elem).flhash         
            CollFol(elem).size=CollFol(elem).size1+subsize
            CollFol(elem).flcnt=CollFol(elem).flcnt+subcontfl
            'if replace(replace(chksums(n),"\_",""),"*","")="" then
            if CollFol(elem).flcnt=0 then
                CollEmpFol(elem)=chksums(n)
            elseif FoldHashes.exists(chksums(n)) Then
                if not FoldClones.exists(chksums(n)) then 
                    set FoldClones(chksums(n))=Crdict
                    FoldClones(chksums(n))(FoldHashes(chksums(n)))=CollFol(elem).size
                end if
                'FoldClones(chksums(n))(elem)=CollFol(elem).size
                FoldClones(chksums(n))(elem)=""
            else 
                FoldHashes(chksums(n))=elem
            end if
            sumcontfl=sumcontfl+CollFol(elem).flcnt
            sumsize=sumsize+CollFol(elem).size          
            n=n+1
        'end if 
    next    
    'On error resume next
    'hash=FoldObj.flhash&join(chksums,"")
    hash=join(chksums,"")
    'if Err then 
        'MsgBox Err.Description & vbCrlf & Err.HelpContext & vbCrlf & Err.HelpFile & vbCrlf & Err.Number & vbCrlf & Err.Source 
        'MsgBox Path1&vbcrlf&CollFol.exists(left(foldpt,instrRev(foldpt,"\")-1))&" "&CollFol.exists(Path1)
        'MsgBox folpt
        'MsgBox Typename(FoldObj.flhash)
        'MsgBox FoldObj.flhash.count
    'end if
    'size=FoldObj.size1+sumsize
    contfl=sumcontfl
    size=sumsize
end sub
 
Sub Recurs2(FoldObj, folpt)
    Dim arrscl,ccnt,elsz,sz,sz2
    For Each elem in FoldObj.subfolders         
        if CollEmpFol.exists(elem) then 
            EmptyFinal(elem)=CollEmpFol(elem)
            CollEmpFol.remove(elem)
        elseif FoldClones.exists(CollFol(elem).flhash) then     
            elhsh=CollFol(elem).flhash
            elsz=CollFol(elem).size
            ccnt=FoldClones(elhsh).count-1
            sz=ccnt*elsz
            if not ClonesFinal.exists(sz) then          
                set ClonesFinal(sz)=Crdict
            end if
            'ClonesFinal(sz)(elhsh)=BytesTostr(elsz,2)&" * "&ccnt&" = "&BytesTostr(sz,2)&vbcrlf&join(FoldClones(elhsh).keys,vbcrlf)
            set ClonesFinal(sz)(elhsh)=FoldClones(elhsh)
            ClonSumSz=ClonSumSz+sz
            FoldClones.remove(elhsh)
        'elseif Junctions.exists(elem) then 'msgbox "junc "&elem&vbcrlf&Junctions(elem)
        else
            Recurs2 CollFol(elem),elem 'эквивал. Recurs2 FoldObj.subfolders(elem),elem
        end if
    next    
End sub
 
Function Browse4Folder
    Dim objFolder, objFolderItem, objShell, strPrompt, intOptions
    strPrompt = "Выберите каталог для анализа"
    strRoot=""
    intOptions = BIF_RETURNONLYFSDIRS + BIF_EDITBOX + BIF_NONEWFOLDER
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, strPrompt, intOptions, strRoot) 
    If (objFolder Is Nothing) Then
        Browse4Folder = ""
    Else
        Set objFolderItem = objFolder.Self
        Browse4Folder = objFolderItem.Path      
        Set objFolderItem = Nothing
        Set objFolder = Nothing
    End If  
    Set objShell = Nothing
End Function
 
Function BytesToStr(ByVal size2, precision)
    Dim sizes, total, rSize
    sizes=Array(" YB", " Zb", " Eb", " Pb", " Тб", " Гб", " Мб", " Кб", " бит")
    total=Ubound(sizes)
    while size2>1024
      total=total-1  
      size2=size2/1024
    wend
    rSize=round(size2,precision)
    BytesToStr=rSize&sizes(total) 
End Function
 
Function GetMD5(strText)
    Dim i, strResult
    strResult=""
    For i=1 To Len(strText)
        strResult = strResult & ChrB(Asc(Mid(strText, i, 1)))
    Next
    objHashedData.Hash strResult    
    GetMD5=objHashedData.Value
End Function 
 
Function calcCRC32(TextStr)
    Dim i, crc
    If CrcTableInit = False Then Call Init_CRCTable
    crc = -1
    For i = 1 To Len(TextStr)
        crc = (((crc And &HFFFFFF00) \ &H100) And &HFFFFFF) Xor (CRCTable((crc And &HFF) Xor Asc(Mid(TextStr, i, 1))))
    Next
    crc = crc Xor &HFFFFFFFF
    'TextStr=crc
    calcCRC32 = crc
End Function
Sub Init_CRCTable()
    'msgbox "crc "&cntcrc
    cntcrc=cntcrc+1
    Dim i, j, Limit, crc
    Limit = &HEDB88320
    For i = 0 To 255
        crc = i
        For j = 0 To 7
            If crc And 1 Then
              crc = (((crc And &HFFFFFFFE) \ 2) And &H7FFFFFFF) Xor Limit
            Else
              crc = ((crc And &HFFFFFFFE) \ 2) And &H7FFFFFFF
            End If
        Next
        CRCTable(i) = crc
    Next
    CrcTableInit = True
End Sub

delegat.vbs

Кликните здесь для просмотра всего текста

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
Dim gCon, Tasks, Num
Set gCon = New GlobalContainer
gCon.Open "storage"
Set FSO = CreateObject("Scripting.FileSystemObject")
CurDir=Fso.GetParentFolderName(WScript.ScriptFullName)
Function Crdict
    set Crdict=CreateObject("Scripting.Dictionary")
end function
set WshShell = WScript.CreateObject("WScript.Shell")
Set Processes=Crdict
Set ProcReady=Crdict
'MsgBox "«начение переменной ""test"": " & gCon.GetProperty("test") ,vbInformation
'MsgBox "“ип переменной ""fso"": " & TypeName(gCon.GetProperty("fso")),vbInformation
set Tasks=gCon.GetProperty("Tasks") 'подключение к коллекции заданий
set BigFold=gCon.GetProperty("BigFold")
set CollFol=gCon.GetProperty("CollFol")
gCon.PutProperty "Processes",Processes '"разшаривание" коллекции распределения заданий
gCon.PutProperty "ProcReady",ProcReady
gCon.PutProperty "endDeleg",false
endPars=false '!!!!!
'set Tasks=Crdict
'Tasks("C:\")=""
'Tasks("C:\windows")=""
Num=0 'порядковый номер процесса
j=1 'параметр, определяющий "affinity" процесса запускаемого скрипта
do until gCon.GetProperty("endPars") and not Tasks.count
    if Tasks.count then
        For Each elem in Tasks
            if ProcReady.count=0 and Processes.count<20 then
                'if ProcReady.count=4 then msgbox "Колличество работающих процессов "&ProcReady.count
                'Num=WshShell.Exec(""""&FSO.GetSpecialFolder(1)&"\WScript.exe"" """&CurDir&"\execut.vbs""").ProcessID
                'Num=WshShell.Exec(""""&WScript.fullname&""" """&CurDir&"\execut.vbs""").ProcessID
                'WshShell.Exec(""""&WScript.fullname&""" """&CurDir&"\execut.vbs"" "&Num)
                WshShell.Run("cmd.exe /c start/b /affinity "&j&" "&WScript.fullname&" """&CurDir&"\execut.vbs"" "&Num),0
                Processes(Num)=Array(Tasks(elem),elem)
                Tasks.remove(elem)
                Num=Num+1
                j=j*2
                if j=16 then j=1
                WScript.Sleep(100)
                'msgbox "Распределитель: процесс "&Num&" получил задание - "&vbcrlf&Processes(Num)(0)&vbcrlf&Processes(Num)(1)
            else                
                'For Each Num in ProcReady
                do until ProcReady.count
                    WScript.Sleep(300)
                loop
                Num2=Filter(ProcReady.keys,"")(0)
                'msgbox Num2&" повторное задание"
                ProcReady.remove(Num2)
                Processes(Num2)=Array(Tasks(elem),elem)
                Tasks.remove(elem)
                'msgbox "Распределитель: процесс "&Num2&" получил повторное задание - "&vbcrlf&Processes(Num2)(0)&vbcrlf&Processes(Num2)(1)             
                'exit For
                'next
            end if
        Next
    end if  
    WScript.Sleep(700)
loop
 
gCon.PutProperty "endDeleg",true 'оповещение об окончании раздачи заданий
'WScript.Sleep(5000)
'msgbox "Processes.count "&Processes.count
do While Processes.count 'ожидание завершения работы всех процессов-обработчиков
    'msgbox "Ожидаем завершения обработчиков"
    WScript.Sleep(800)
loop
 
'msgbox BigFold.count&vbcrlf&join(BigFold.keys,vbcrlf)
For each elem in BigFold
    CollFol(elem).flhash="\"&join(CollFol(elem).bghash.items,"")
    'msgbox CollFol(elem).flhash
Next
    
Class GlobalContainer
    Private wnd, owner
    Sub Open(name)
        For Each wnd in CreateObject("Shell.Application").Windows
            if Instr(1,wnd.GetProperty("container_name"),name) = 1 Then Exit Sub
        Next
        owner = True
        Set wnd = GetObject("new:{C08AFD90-F2A1-11D1-8455-00A0C91F3880}")
        wnd.PutProperty "container_name", name
    End Sub
    
    Sub PutProperty(name, value)    
        wnd.PutProperty name, value
    End Sub
    
    Function GetProperty(name)
        On Error Resume Next
        if IsObject(wnd.GetProperty(name)) Then
            Set GetProperty = wnd.GetProperty(name)
        Else
            GetProperty = wnd.GetProperty(name)
        End if
    End Function
 
    Private Sub Class_Terminate()
        On Error Resume Next
        if owner Then wnd.Quit()
    End Sub
End Class

execut.vbs

Кликните здесь для просмотра всего текста

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
Dim gCon, Num, Processes
Set gCon = New GlobalContainer
gCon.Open "storage"
Num=WScript.Arguments(0)*1
set BigFold=gCon.GetProperty("BigFold")
set Processes=gCon.GetProperty("Processes") 'подключение к коллекции распределения заданий
set ProcReady=gCon.GetProperty("ProcReady")
set CollFol=gCon.GetProperty("CollFol")
set calcCRC32=gCon.GetProperty("calcCRC32")
 
'msgbox "Аргумент "&Num
 
n=0
do until gCon.GetProperty("endDeleg") and not isArray(Processes(Num))   
    if isArray(Processes(Num)) then
        n=0
        target=Processes(Num)       
        'msgbox "Исполнитель: получено задание "&vbcrlf&target(0)&vbcrlf&target(1)&vbcrlf&CollFol(target(0)).bghash(target(1))
        CollFol(target(0)).bghash(target(1))=calcCRC32(CollFol(target(0)).bghash(target(1)))
        'msgbox "CollFol(target(0)).bghash(target(1))="&CollFol(target(0)).bghash(target(1))
        Processes(Num)=""
        ProcReady(Num)=""
    end if
    n=n+1
    if n=10 then exit do  'если задание не поступило в течении 7 секунд (700*10) завершать скрипт
    WScript.Sleep(700)
loop
Processes.remove(Num)
ProcReady.remove(Num)
 
Class GlobalContainer
    Private wnd, owner
    Sub Open(name)
        For Each wnd in CreateObject("Shell.Application").Windows
            if Instr(1,wnd.GetProperty("container_name"),name) = 1 Then Exit Sub
        Next
        owner = True
        Set wnd = GetObject("new:{C08AFD90-F2A1-11D1-8455-00A0C91F3880}")
        wnd.PutProperty "container_name", name
    End Sub
    
    Sub PutProperty(name, value)    
        wnd.PutProperty name, value
    End Sub
    
    Function GetProperty(name)
        On Error Resume Next
        if IsObject(wnd.GetProperty(name)) Then
            Set GetProperty = wnd.GetProperty(name)
        Else
            GetProperty = wnd.GetProperty(name)
        End if
    End Function
 
    Private Sub Class_Terminate()
        On Error Resume Next
        if owner Then wnd.Quit()
    End Sub
End Class
 
Function GetPID
    With GetObject("winmgmts:root\cimv2:win32_process.Handle='" &_
        CreateObject("WScript.Shell").Exec("rundll32 kernel32,Sleep").ProcessId & "'")
        GetPID = .ParentProcessId
        .Terminate
    End With
End Function

Добавлено через 46 минут
Вот она ошибка - подключение функции CalcCRC32 из главного файла "глобал контейнером". После того как встроил функцию в файл execut.vbs, сразу стала видна многопоточность, процессор заработал на максимуме! Т.е. одна функция работала как бы в один поток, и выдавала одну скорость, что при 20, что при 30 обращающихся к ней процессах.

Новые блоги и статьи Все статьи Все блоги /
Отчёт о затраченных материалах за определенный период с макетом печатной формы Maks 21.04.2026 Отчёт из решения ниже размещён в конфигурации КА2. Задача: разработка отчёта по затраченным материалам за определённый период, с возможностью вывода печатной формы отчёта с шапкой и подвалом. В. . .	Отчёт о спецтехнике находящейся в ремонте Maks 20.04.2026 Отчёт из решения ниже размещен в конфигурации КА2. Задача: отобразить спецтехнику, которая на данный момент находится в ремонте. Есть нетиповой документ "Заявка на ремонт спецтехники" который. . .	Памятка для бота и "визитка" для читателей "Semantic Universe Layer (Слой семантической вселенной)" Hrethgir 19.04.2026 Сгенерировано для краткого описания по случаю сборки и компиляции скелета серверного приложения. И пусть после этого скажут, что статьи сгенерированные AI - туфта и не интересно. И это не реклама -. . .	Запрет удаления строк ТЧ документа при определённом условии Maks 19.04.2026 Алгоритм из решения ниже реализован на примере нетипового документа "Аккумуляторы", разработанного в конфигурации КА2. У данного документа есть ТЧ, в которой в зависимости от прав доступа. . .
Модель заражения группы наркоманов alhaos 17.04.2026 Условия задачи сформулированы тут Суть: - Группа наркоманов из 10 человек. - Только один инфицирован ВИЧ. - Колются одной иглой. - Колются раз в день. - Колются последовательно через. . .	Мысли в слух. Про "навсегда". kumehtar 16.04.2026 Подумалось тут, что наверное очень глупо использовать во всяких своих установках понятие "навсегда". Это очень сильное понятие, и я только начинаю понимать край его смысла, не смотря на то что давно. . .	My Business CRM MaGz GoLd 16.04.2026 Всем привет, недавно возникла потребность создать CRM, для личных нужд. Собственно программа предоставляет из себя базу данных клиентов, в которой можно фиксировать звонки, стадии сделки, а также. . .	Знаешь почему 90% людей редко бывают счастливыми? kumehtar 14.04.2026 Потому что они ждут. Ждут выходных, ждут отпуска, ждут удачного момента. . . а удачный момент так и не приходит.

@testuser2 1391 / 848 / 92 Регистрация: 08.02.2017 Сообщений: 3,620 Записей в блоге: 2
	25.01.2020, 12:27 [ТС]
	Да, кстати, надо исключить все эти ресеклы Изображения 0

@testuser2 1391 / 848 / 92 Регистрация: 08.02.2017 Сообщений: 3,620 Записей в блоге: 2
	26.01.2020, 05:51 [ТС]
	Добавил ms5 хэширование строк стандартной библиотекой «capicom.dll», но по итогу, это только замедляет выполнение (148с против 10-30с) и нагружает процессор. Миниатюры 0

@testuser2 1391 / 848 / 92 Регистрация: 08.02.2017 Сообщений: 3,620 Записей в блоге: 2
	30.01.2020, 15:54 [ТС]
	Время первого прохода (по некэшированному диску) немного дольше (100 с чем-то сек.). Пик потребления памяти в пике нещадное, с этим ни чего не поделать.., и это самый главный контраргумент против таки методов работы с ф.с. Миниатюры 0

@testuser2 1391 / 848 / 92 Регистрация: 08.02.2017 Сообщений: 3,620 Записей в блоге: 2
	03.02.2020, 18:17 [ТС]
	Немного о том, какие проблемы и задачи хотелось бы решить. В первую очередь - пожирание памяти, для этого надо добавить crc32 хеширование, самое лёгкое и быстрое. Но при всем, оно все же медленное, по этому следующий пункт - многопоточность, перенести это хеширование на паралельно запущенные процессы 3-4 копий отдельного (вспомогательного) скрипта. Задача не самая простая, но кое-что уже нашел.. 0