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

@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 · 09.02.2020, 07:07 **[ТС]**

Распределение процессов по ядрам(потокам) процессора дает некоторое преимущество. Процессор используется более "плотно".
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
104
105
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")
cpustr=GetObject("winmgmts:\\.\root\cimv2:Win32_Processor.DeviceID='CPU0'").NumberOfLogicalProcessors
gCon.PutProperty "cpustr",cpustr
gCon.PutProperty "Processes",Processes '"разшаривание" коллекции распределения заданий
gCon.PutProperty "ProcReady",ProcReady
gCon.PutProperty "endDeleg",false
endPars=false '!!!!!
'set Tasks=Crdict
'Tasks("C:\")=""
'Tasks("C:\windows")=""
Num=0 'порядковый номер процесса
param=1 'параметр, определяющий "affinity" процесса запускаемого скрипта
j=0
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
                'WshShell.Exec(""""&WScript.fullname&""" """&CurDir&"\execut.vbs"" "&Num)
                WshShell.Run("cmd.exe /c start/b /affinity "&param&" "&WScript.fullname&" """&CurDir&"\execut.vbs"" "&Num),0
                Processes(Num)=Array(Tasks(elem),elem)
                Tasks.remove(elem)
                Num=Num+1
                j=j+1
                param=param*2
                if j=cpustr then j=0 :param=1 end if
                'if j=16 then j=1
                if Num>10 then WScript.Sleep(200)
                '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
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
Dim gCon, Num, Processes, CrcTableInit, CRCTable(255)
Set gCon = New GlobalContainer
gCon.Open "storage"
Num=WScript.Arguments(0)*1
Set FSO = CreateObject("Scripting.FileSystemObject")
set BigFold=gCon.GetProperty("BigFold")
set Processes=gCon.GetProperty("Processes") 'подключение к коллекции распределения заданий
set ProcReady=gCon.GetProperty("ProcReady")
set CollFol=gCon.GetProperty("CollFol")
'Inc_File Fso.GetParentFolderName(WScript.ScriptFullName)&"\CalcCRC32.vbs"
'set calcCRC32=gCon.GetProperty("calcCRC32")
 
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)))
        Processes(Num)=""
        ProcReady(Num)=""
    end if
    n=n+1
    if n=7 then exit do  'если задание не поступило в течении 7 секунд (700*10) завершать скрипт
    WScript.Sleep(700)
loop
Processes.remove(Num)
ProcReady.remove(Num)
'if ProcReady.exists(Num) then 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 GetNum
    With GetObject("winmgmts:root\cimv2:win32_process.Handle='" &_
        CreateObject("WScript.Shell").Exec("rundll32 kernel32,Sleep").ProcessId & "'")
        GetNum = .ParentProcessId
        .Terminate
    End With
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
 
' Sub Inc_File(FileName)
  ' Dim objTextStream, strInc
  ' Set objTextStream = FSO.OpenTextFile(FileName, 1)
  ' strInc = objTextStream.ReadAll
  ' objTextStream.Close
  ' ExecuteGlobal strInc
' End Sub

@testuser2 · 10.02.2020, 16:20 **[ТС]**

Более правильный рассчет параметра affinity
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
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") '***
cpustr=2^GetObject("winmgmts:\\.\root\cimv2:Win32_Processor.DeviceID='CPU0'").NumberOfLogicalProcessors
gCon.PutProperty "cpustr",cpustr
gCon.PutProperty "Processes",Processes '"разшаривание" коллекции распределения заданий
gCon.PutProperty "ProcReady",ProcReady
gCon.PutProperty "endDeleg",false
endPars=false '!!!!!
j=1
param=1 'параметр, определяющий "affinity" процесса запускаемого скрипта
Num=0 'порядковый номер (идентификатор) процесса
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<30 then
                'WshShell.Exec(""""&WScript.fullname&""" """&CurDir&"\execut.vbs"" "&Num)
                if j=cpustr then j=1 :param=1 end if
                WshShell.Run("cmd.exe /c start/b /affinity "&param&" "&WScript.fullname&" """&CurDir&"\execut.vbs"" "&Num),0
                Processes(Num)=Array(Tasks(elem),elem)
                Tasks.remove(elem)
                Num=Num+1               
                j=j*2
                param=Hex(j)                
                if Num>10 then WScript.Sleep(300)
                '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
'WScript.Sleep(2000)
'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

Новые блоги и статьи Все статьи Все блоги /
Скрипты Tampermonkey для CyberForum, ChatGPT, Claude и пр. Jin X 06.09.2026 Скрипты Tampermonkey для CyberForum, ChatGPT, Claude и пр. Работая с форумом и нейросетями в браузере часто хочется что-то подкорректировать или добавить какого-то функционала. Ниже прикреплён. . .	Программа опроса у.з. расходомера SLS-720F Argus19 02.09.2026 Программа опроса у. з. расходомера SLS-720F Программа опрашивает один раз в минуту три ультразвуковых расходомера SLS-720F через интерфейс RS-485 по протоколу Modbus RTU. Опрашиваются регистры. . .	Hyper-V: Компьютер должен поддерживать доверенный платформенный модуль 2.0. Maks 31.08.2026 При установке Windows 11 на виртуальную машину Hyper-V 2-го поколения вылезла такая ошибка: Решение: в параметрах виртуальной машины, в разделе "Безопасность" (Security) активировать флаг. . .	Архитектура биовида Стива в Майнкрафте: Зачем бонобо кубический каннибализм anaschu 30.08.2026 Кубический Вагинокапитализм в Minecraft: Математический инвариант ОДУ и рок Стивов-бонобо Главная задача разработанной «Модели Всего» — наглядно продемонстрировать наличие системной «судьбы». . .
Оттачиваю умение писать js программы. russiannick 30.08.2026 Проектом выходного дня стало написание Книги шифров Виженера. Итогом стала версия 200, синий туман. Синий туман назван так, потому что замораживает текст под собой. Нажатие синих кнопок управляют. . .	мат медиц модель 30. презентация проекта anaschu 27.08.2026 хоп хоп хоп хидахоп, а я кладую))	Как у меня протекала болезнь zorxor 27.08.2026 Здравствуйте, друзья! Эта запись блога предназначена именно для вас - для моих дорогих друзей, которые знали меня лично. Чтобы ответить на вопрос - а что же со мной произошло на самом деле? Я учился. . .	Нашел вот забавное видео о измерениях. Лучшее что я видел на эту тему kumehtar 26.08.2026 ILETXiw9bMQ Основная суть и тезисы по измерениям: 0D (Нулевое измерение): точка, не имеющая длины, ширины, высоты или объема. Объект не может перемещаться в 0D. 1D (Первое измерение):. . .