Batya
|
 Posted: Tue Jun 23, 2009 16:20 Post subject: |
 |
|
natalja
vbs-скрипт:
| Code: | '====================================================================================
' Переименование и перемещение файлов или папок согласно Excel-файла.
' Столбцы в таблице - Имя1, Имя2, Категория, Путь, Статус.
' Параметры скрипта:
' {excel-файл}
'====================================================================================
Option Explicit
'=============== Изменяемые параметры ===============================================
Const StartCell = "A2" 'Первая ячейка таблицы
'====================================================================================
Dim FSO, WSH, Mess, XlsFile, FF, Path, FPath, FNewPath, Status, objXL, i, j
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSH = CreateObject("WScript.Shell")
Set objXL = CreateObject("Excel.Application")
Set FF = CreateObject("Scripting.Dictionary")
MessDefine
CheckParams
objXL.Workbooks.Open XlsFile
i = objXL.Range(StartCell).Row
j = objXL.Range(StartCell).Column
Do
Path = GetPath(Trim(objXL.Cells(i,j+3).Value)) & "\"
FPath = Path & Trim(objXL.Cells(i,j+1).Value)
Path = Path & Trim(objXL.Cells(i,j+2).Value) & "\"
FNewPath = Path & Trim(objXL.Cells(i,j ).Value)
If Not FF.Exists(FPath) Then
If FExists(FPath) Then
If Not FExists(FNewPath) Then
BuildTree(Path)
On Error Resume Next
FMove FPath, FNewPath
If Err.Number = 0 Then
Status = Mess(6)
Else
Status = Err.Description
End If
On Error GoTo 0
Else
Status = Mess(5)
End If
Else
Status = Mess(4)
End If
Else
Status = Mess(3)
End If
FF.Add FPath, Status
objXL.Cells(i,j+4).Value = Status
i = i + 1
Loop Until objXL.Cells(i,j).Value = ""
'Сохранение результатов
objXL.Application.ActiveWorkbook.Save
objXL.Quit()
MsgBox Mess(7), vbInformation + vbOKOnly, Mess(0)
Quit
'===== Процедуры и функции ===============================================================
'Проверка входных параметров
Sub CheckParams
With WScript
If .Arguments.Count = 0 Then
MsgBox Mess(1), vbCritical + vbOKOnly, Mess(0)
Quit
End If
XlsFile = GetPath(.Arguments(0))
If Not FSO.FileExists(XlsFile) Then
MsgBox Mess(2), vbCritical + vbOKOnly, Mess(0)
Quit
End If
End With
End Sub
'Путь
Function GetPath(pPath)
GetPath = FSO.GetAbsolutePathName(WSH.ExpandEnvironmentStrings(pPath))
End Function
'Существование файла или папки
Function FExists(pPath)
FExists = FSO.FileExists(pPath) Or FSO.FolderExists(pPath)
End Function
'Перемещение файла или папки
Function FMove(pPath, pNewPath)
If FSO.FileExists(pPath) Then FSO.MoveFile pPath, pNewPath
If FSO.FolderExists(pPath) Then FSO.MoveFolder pPath, pNewPath
End Function
'Создание дерева папок
Sub BuildTree(pFolder)
Dim lPF
lPF = FSO.GetParentFolderName(pFolder)
If Not FSO.FolderExists(lPF) Then
BuildTree(lPF)
Else
If Not FSO.FolderExists(pFolder) Then FSO.CreateFolder pFolder
End If
End Sub
'Описание сообщений
Sub MessDefine
Set Mess = CreateObject("Scripting.Dictionary")
With Mess
.Add 0, "Переименование и перемещение согласно Excel-файла"
.Add 1, "Не указаны параметры!"
.Add 2, "Excel-файл не существует!"
.Add 3, "Повторное вхождение в список"
.Add 4, "Исходный файл или папка не существует"
.Add 5, "Уже существует целевой файл или папка с требуемым именем"
.Add 6, "Успешное выполнение"
.Add 7, "Операция завершена."
End With
End Sub
'Выход
Sub Quit
Set objXL = Nothing
Set FF = Nothing
Set Mess = Nothing
Set WSH = Nothing
Set FSO = Nothing
WScript.Quit
End Sub |
Сохрани код в текстовый файл с расширением vbs. Перетащи получившийся файл на панель TC - получится кнопка.
Затем 2 варианта:
1. Либо на кнопке нажми правую кнопку мыши -> Изменить. В строке "Параметры" напиши полный путь к Excel-файлу -> ОК. Нажми кнопку.
2. Либо просто перетащи Excel-файл на эту кнопку.
В Excel-файле должно быть 4 заполненных колонки - Имя1, Имя2, Категория, Путь. После выполнения операции будет заполнена 5-я колонка Статус.
Внимание! В момент выполнения скрипта Excel-файл НЕ должен быть открыт.
_________________
Нет, я не сплю. Я просто медленно моргаю.
Last edited by Batya on Wed Jun 24, 2009 14:19; edited 1 time in total |
|
Rules
Search
FAQ
Memberlist
Usergroups
Register
Profile
Log in to check your private messages
Log in
