Batya
|
 Posted: Mon Jan 26, 2009 12:18 Post subject: |
 |
|
vbs-скрипт:
| Code: | '==============================================================================
' Замена указанными файлами одноименных файлов во всех вложенных папках
' Параметры:
' {папка с исходными файлами} {корневая папка, в которой заменяются файлы}
' Пример параметров вызова из TC:
' "%P" "%T"
' Автор - Batya
'==============================================================================
Option Explicit
'================= Изменяемые параметры =======================================
Const ViewSubFolders = False 'Просматривать ли вложенные папки в исходной папке
'==============================================================================
Dim FSO, FileList, SourceDir, TargetDir, Mess, oSA, WSH, Count
SetMess
Set oSA = CreateObject("Shell.Application")
Set WSH = CreateObject("WScript.Shell")
CheckParam
If MessBox(Mess(10) & vbNewLine & SourceDir & vbNewLine & vbNewLine & _
Mess(11) & vbNewLine & TargetDir, 4) = vbCancel Then Quit
Count = 0
Set FileList = CreateObject("Scripting.Dictionary")
FillFileList FileList, SourceDir
FilesReplace FileList, TargetDir
MessBox Mess(7) & vbNewLine & vbNewLine & Mess(8) & Count & Mess(9), 3
Quit
Sub CheckParam
If WScript.Arguments.Count = 0 Then
MessBox Mess(1), 1
Quit
End If
If WScript.Arguments.Count < 2 Then
MessBox Mess(2), 1
Quit
End If
SourceDir = WScript.Arguments(0)
TargetDir = WScript.Arguments(1)
Set FSO = CreateObject("Scripting.FileSystemObject")
If SourceDir = "" Then
SourceDir = OpenFolder(Mess(5))
Else
SourceDir = GetPath(SourceDir)
End If
If TargetDir = "" Then
TargetDir = OpenFolder(Mess(6))
Else
TargetDir = GetPath(TargetDir)
End If
If Not FSO.FolderExists(SourceDir) Then
MessBox Mess(3), 1
Quit
End If
If Not FSO.FolderExists(TargetDir) Then
MessBox Mess(4), 1
Quit
End If
End Sub
Sub FillFileList(byRef pFileList, pFolder)
Dim lF, lFolder
Set lFolder = FSO.GetFolder(pFolder)
For Each lF In lFolder.Files
If Not pFileList.Exists(lF) Then
pFileList.Add lF.Name, lF.Path
End If
Next
If ViewSubFolders Then
For Each lF In lFolder.SubFolders
FillFileList pFileList, lF.Path
Next
End If
Set lFolder = Nothing
End Sub
Sub SetMess
Set Mess = CreateObject("Scripting.Dictionary")
Mess.Add 0, "Замена одноименных файлов"
Mess.Add 1, "Не указаны входные параметры!"
Mess.Add 2, "Указаны не все входные параметры!"
Mess.Add 3, "Исходная папка не существует!"
Mess.Add 4, "Целевая папка не существует!"
Mess.Add 5, "Укажите исходную папку"
Mess.Add 6, "Укажите целевую папку"
Mess.Add 7, "Операция завершена."
Mess.Add 8, "Заменена произведена для "
Mess.Add 9, " файлов."
Mess.Add 10, "Выполнить замену файлами из папки"
Mess.Add 11, "файлов в папке"
End Sub
Function MessBox(pMess, pMode)
Dim lIcon
Select Case pMode
Case 1 lIcon = vbCritical + vbOKOnly
Case 2 lIcon = vbExclamation + vbOKOnly
Case 3 lIcon = vbInformation + vbOKOnly
Case 4 lIcon = vbQuestion + vbOKCancel
End Select
MessBox = MsgBox(pMess, lIcon, Mess(0))
End Function
Sub FilesReplace(pFileList, pFolder)
Dim lF, lFolder, lAttr
Set lFolder = FSO.GetFolder(pFolder)
For Each lF In lFolder.Files
If pFileList.Exists(lF.Name) Then
lAttr = lF.Attributes
lF.Attributes = lF.Attributes And Not 3
FSO.CopyFile pFileList(lF.Name), lF.Path, True
Count = Count + 1
lF.Attributes = lAttr
End If
Next
For Each lF In lFolder.SubFolders
FilesReplace pFileList, lF.Path
Next
Set lFolder = Nothing
End Sub
Function OpenFolder(pTitle)
Dim oF, lSelect
Set oF = oSA.BrowseForFolder(0, pTitle, 16)
lSelect = Not (TypeName(oF) = "Nothing")
If lSelect Then
OpenFolder = oF.Self.Path
End If
Set oF = Nothing
If Not lSelect Then
Quit
End If
End Function
Function GetPath(pPath)
GetPath = FSO.GetAbsolutePathName(WSH.ExpandEnvironmentStrings(pPath))
End Function
Sub Quit
Set Mess = Nothing
Set FSO = Nothing
Set oSA = Nothing
Set WSH = Nothing
WScript.Quit
End Sub |
Здесь в скрипте можно по желанию изменить параметр ViewSubFolders, который указывает, брать ли в исходной папке новые файлы в том числе из вложенных подпапок.
_________________
Нет, я не сплю. Я просто медленно моргаю.
Last edited by Batya on Mon Feb 02, 2009 16:19; edited 1 time in total |
|
Rules
Search
FAQ
Memberlist
Usergroups
Register
Profile
Log in to check your private messages
Log in
