'--- RenamedDoc.vbs'
' Reading Document Properties, rename documents

' Путь к обрабатывемому каталогу'
' sFolder = "C:\Common\Develop\vbs\RenamedDoc\doc1"
' sFolder = "\\uachpc077\c$\!ins\_RECOVER_FROM_036\Microsoft Excel 2007 XML Document"
sFolder = "\\uachpc077\c$\!ins\_RECOVER_FROM_036\Microsoft Word 2007 XML Document"

gi_NeedTitle  = 1 ' 1 - добавляем Title документа / 0 - не обрабатываем, если остались документы с заголовком в нечитабельной кодировки'
gi_NeedRename = 1 ' 1 - переименовываем документы / 0 - только формируем протокол (в папке документов) _log_RenamedDoc.txt с новыми именами'

Set fso = CreateObject("Scripting.FileSystemObject")  
Set NewFile = fso.CreateTextFile( sFolder & "\_log_RenamedDoc.txt", True)
Set folder = fso.GetFolder(sFolder)
Set files = folder.Files
countDoc = 0 : countErr = 0 : countRen = 0
For each folderIdx In files
	If ( InStr(folderIdx.Name,".xls")>0 OR InStr(folderIdx.Name,".doc")>0 ) AND Left(folderIdx.Name, 2)<>"~$" Then
		countDoc = countDoc + 1
		sOldName = folderIdx.Name
		sLog = ""
		sNewName = uf_newNameDocFile (sFolder, sOldName)
		If sNewName=sOldName Then
			countErr = countErr + 1
			sLog = "(no_read)" & vbTab & sOldName & vbTab & "--"
		Else
			'--- переименование файла'
			Err.Clear
			On Error Resume Next
			If gi_NeedRename=1 Then fso.MoveFile sFolder &"\"& sOldName, sFolder &"\"& sNewName
			If Err.Number = 0 Then
				countRen = countRen + 1
				sLog = "(renamed)" & vbTab & sOldName & vbTab & sNewName 
			Else
				countErr = countErr + 1
				sLog = "(err_rename)" & vbTab & sOldName & vbTab & sNewName 
			End IF
			On Error GoTo 0
		End IF
		
		NewFile.WriteLine( sLog )
	End IF
	
Next
NewFile.Close

s = "Doc:" & Cstr(countDoc) & " Err:" & Cstr(countErr) & " Ren:"  & Cstr(countRen)

msgbox s,,"Finish"


' --- Формирование нового имени файла'
' Параметры: путь к документу, имя файла документа (файл должен быть word/excel)
' Резульат - новое имя файла с добавленными слевой стороны имени файла свойствами офисного документа: 
'   дата, последний_редактировавший, заголовок, автор_документа (если отличен от редактировавшего)'
' --------------------------------------------------------------------------------------------------
Function uf_newNameDocFile (pPath, pName)

	' Microsoft Developer Support OLE File Property Reader 2.1 Sample (KB 224351)
	' http://www.microsoft.com/download/en/details.aspx?displaylang=en&id=8422
	Dim objDoc : Set objDoc = CreateObject("DSOFile.OleDocumentProperties")
	
	i = InStrRev( pName, "." )
	sOld = Left( pName, i - 1) 'только имя файла'
	ext = Right( pName, Len(pName) - i ) 'расширение файла'
	s = ""
	
	Err.Clear
	On Error Resume Next
	objDoc.Open( pPath & "\" & pName) 
	If Err.Number = 0 Then
		sDt = "" 'время последнего редактирования в формате ГГГГ-ММ-ДД_ЧЧММ'
		If len(Trim(objDoc.SummaryProperties.DateLastSaved))>0 Then 
			sDt = objDoc.SummaryProperties.DateLastSaved
			sDt = Mid(sDt,7,4) & "-" &  Mid(sDt,4,2) & "-" & Mid(sDt,1,2) & "_" & Replace(Mid(sDt,12,5),":","")
		End IF
		If len(sDt)>0 AND sDt<>"--_" Then s = s & sDt
		If len(objDoc.SummaryProperties.LastSavedBy)>0 Then s = s & " _(e)"& objDoc.SummaryProperties.LastSavedBy
		If gi_NeedTitle=1 Then 'есть требование обрабатывать Title'
			If len(objDoc.SummaryProperties.Title)>0 Then 
				sTitle = Trim( Replace(Replace(objDoc.SummaryProperties.Title, vbTab,""), "|",""))
				If sTitle="Number:" Then sTitle=""
				If Len(sTitle)>0 Then s = s & " _(t)"& sTitle
			End IF
		End IF
		If len(objDoc.SummaryProperties.Author)>0 AND (objDoc.SummaryProperties.Author<>objDoc.SummaryProperties.LastSavedBy) _
			Then s = s & " _(a)"& objDoc.SummaryProperties.Author
		' замены недопустимых и часто повторяемых символов'
		s = Replace(s,"і","i") 'украинская литера на латинскую'
		s = Replace(s,"“","`") 'разновидности кавычек'
		s = Replace(s,"”","`")
		s = Replace(s,"«","`")
		s = Replace(s,"»","`")
		s = Replace(s,"""","`")
		s = Replace(s,"?","_") 'символы подстановок'
		s = Replace(s,"*","_")
		s = Replace(s,":","_")
		s = Replace(s,"/","_")
		s = Replace(s,"\","_")
		s = Replace(s,"|","_")
		s = Replace(s,"____","__") 'многократные дубли пробелов и подчеркиваний'
		s = Replace(s,"____","__")
		s = Replace(s,"____","__")
		s = Replace(s,"  "," ")
		s = Replace(s,"  "," ")
	End IF
	If Len(s)> 0 Then s = s & " (" & sOld& ")." & ext Else s = pName 'оставляем имя прежним, если свойства не были получены'
	On Error GoTo 0
			
	Set objDoc = Nothing
	uf_newNameDocFile = s
End FUNCTION

(no_read)    119880.doc    --
(err_rename)    122475.doc    2003-09-26_1045 _(e)DokuchayevaL _(t)ПЕРЕЛІК ДОКУМЕНТІВ, НЕОБХІДНИХ ДЛЯ ВІДКРИТТЯ КОРПОРАТИВНОГО РАХУНКУ В НАЦІОНАЛЬНІЙ ВАЛЮТІ ТИПУ “Н” ТА РАХУНКУ В ІНОЗЕМНІЙ ВАЛЮ _(a)Gvozdyev Yuriy (122475).doc
(renamed)    128002.doc    2009-07-03_1050 _(e)NeduzhyiS _(t)Постачальник_        ПП `МОСТ-СЕРВІС` _(a)user (128002).doc
(renamed)    128462.doc    2009-11-23_1739 _(e)NeduzhyiS _(t)Оплата за рекламу в журналi ` Партнер -Черкаси` № 10-12, 2009 р (128462).doc
(renamed)    251401.doc    2011-10-12_1812 _(e)VietrovS _(t)Оплата за марки поштовi для регiонального вiддiлення АТ ` ОТП Банк` в м _(a)NeduzhyiS (251401).doc