Количество примечаний в Word-файлах

[Fresh96]

Здравствуйте. Прошу помощи в решении такой задачи:
Есть папка с Word(*docx) файлами. Хотелось бы с помощью скрипта посчитать количество примечаний в каждом из документов и вывести результат в файл(например csv) в виде:
Имя файла; Количество примечаний
П2_2.docx;62
И5_1.docx;17

и т.д.

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

Документ с примечаниями (2 шт) приложил.
----
Кросс-темы: тут (http://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=55775) и тут (http://www.excelworld.ru/forum/4-9643-1)

[Iska]

Примерно так:
Option Explicit

Dim strDestFile

Dim objSourceFolder
Dim strSourceFolder

Dim objFSO
Dim objFile
Dim objTS

Dim objWord


strDestFile = "out.csv"

Set objSourceFolder = WScript.CreateObject("Shell.Application").BrowseForFolder(0, "Select source folder:", 81, "")

If Not objSourceFolder Is Nothing Then
strSourceFolder = objSourceFolder.self.Path

Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")

If objFSO.FolderExists(strSourceFolder) Then
Set objWord = Nothing
Set objTS = objFSO.CreateTextFile(objFSO.BuildPath(strSourceFolder, strDestFile), True)

objTS.WriteLine "Имя файла;Количество примечаний"

For Each objFile In objFSO.GetFolder(strSourceFolder).Files
Select Case LCase(objFSO.GetExtensionName(objFile.Name))
Case "doc", "docx"
If objWord Is Nothing Then
Set objWord = WScript.CreateObject("Word.Application")
End If

With objWord.Documents.Open(objFile.Path)
objTS.WriteLine objFile.Name & ";" & .Comments.Count
.Close
End With
Case Else
' Nothing to do
End Select
Next

objTS.Close
Set objTS = Nothing

If Not objWord Is Nothing Then
objWord.Quit
Set objWord = Nothing
End If
Else
WScript.Echo "Can't use folder [" & strSourceFolder & "]."
WScript.Quit 1
End If
Else
WScript.Echo "Cancelled choice folder."
End If

WScript.Quit 0

[Fresh96]

Iska, уже какой раз выручаете. Спасибо. :up

А не могли бы Вы еще немного подкорректировать скриптик, чтобы он проходился и по файлам в подпапках.
Структура папок, для примера, такая:

ПапкаНакоторуюУказываю (в ней несколько подпапок в которых Word-файлы)
| |
Папка01 (в ней файлы) Папка02 (в ней тоже файлы ворда) ....

[Iska]

«Немного» не получится:
Option Explicit

Dim strDestFile

Dim objSourceFolder
Dim strSourceFolder

Dim objFSO
Dim objDictionary
Dim objTS
Dim strPath


strDestFile = "out.csv"

Set objSourceFolder = WScript.CreateObject("Shell.Application").BrowseForFolder(0, "Select source folder:", 81, "")

If Not objSourceFolder Is Nothing Then
strSourceFolder = objSourceFolder.self.Path

Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")

If objFSO.FolderExists(strSourceFolder) Then
Set objDictionary = WScript.CreateObject("Scripting.Dictionary")

ScanSubFolders objFSO.GetFolder(strSourceFolder)

If objDictionary.Count > 0 Then
Set objTS = objFSO.CreateTextFile(objFSO.BuildPath(strSourceFolder, strDestFile), True)
objTS.WriteLine "Путь к файлу;Количество примечаний"

With WScript.CreateObject("Word.Application")
For Each strPath In objDictionary.Items
With .Documents.Open(strPath)
objTS.WriteLine strPath & ";" & .Comments.Count
.Close
End With
Next

.Quit
End With

objTS.Close
Set objTS = Nothing
Else
WScript.Echo "Nothing found."
End If
Else
WScript.Echo "Can't use folder [" & strSourceFolder & "]."
WScript.Quit 1
End If

Set objFSO = Nothing
Set objSourceFolder = Nothing
Else
WScript.Echo "Cancelled choice folder."
End If

WScript.Quit 0
'=============================================================================

'=============================================================================
Sub ScanSubFolders(objFolder)
Dim objSubFolder
Dim objFile

For Each objFile In objFolder.Files
Select Case LCase(objFSO.GetExtensionName(objFile.Name))
Case "doc", "docx"
objDictionary.Add objFile.Path, objFile.Path
Case Else
' Nothing to do
End Select
Next

For Each objSubFolder In objFolder.SubFolders
ScanSubFolders objSubFolder
Next
End Sub
'=============================================================================

[Fresh96]

Iska, всё работает.

На 160 файлах в 14 подпапках = ~5 минут работы (но это ерунда, по сравнению с ручной обработкой).

Уже совестно просить, но попробовал переделать Ваш файл под обработку PDF (там комментарии). Ничего не выходит, точнее выходит одна ругань скрипта (в программировании я не знаток).

Вот здесь (http://docs.ongetc.com/?q=content/pdf-pages-counting-using-vb-script) скрипт выполняет подсчет количества страниц в PDF-файлах.

Для подсчета количества страниц в PDF:
strFilename="c:\test.pdf"
Set objAcroExch = CreateObject("AcroExch.PDDoc")
objAcroExch.Open strFilename
CountPages = objAcroExch.GetNumPages
objAcroExch.Close

msgbox CountPages

Как я понимаю, нужно заменить GetNumPages(и, возможно, что то еще) на чтение количества комментариев, но нигде не могу найти, что написать (http://www.onestopqa.com/resources/Accessing PDFs.pdf).

[Fresh96]

Наваял такой код для показа количества комментариев:
Set pdSourceDoc = CreateObject("AcroExch.PDDoc")

strFilename="C:\1\TestDoc.pdf"
pdSourceDoc.Open strFilename
iSourcePageCount = pdSourceDoc.GetNumPages()
Set pAcroSourcePage = pdSourceDoc.AcquirePage(0)
iSourceAnnotationCount = pAcroSourcePage.GetNumAnnots()
msgbox iSourcePageCount
msgbox iSourceAnnotationCount

Количество страниц "iSourcePageCount" показывает верно, а
количество комментариев "iSourceAnnotationCount" показывает в 2 раза больше. Не пойму почему?

Если этот код верный помогите интегрировать его в код из поста
«Немного» не получится:
читать дальше » »

[Iska]

Fresh96, у меня нет Adobe Acrobat.

а количество комментариев "iSourceAnnotationCount" показывает в 2 раза больше. Не пойму почему? »
Interapplication Communication API Reference - Adobe (http://www.adobe.com/content/dam/Adobe/en/devnet/acrobat/pdfs/iac_api_reference.pdf):
GetNumAnnots

Gets the number of annotations on the page.

Annotations that have associated pop-up windows, such as a strikeout, count as two annotations. Also note that widget annotations (Acrobat form fields) are included.

[Fresh96]

Iska, спасибо за пояснение.

Получилось так (к сожалению должен быть установлен Adobe Acrobat):

Option Explicit

Dim strDestFile

Dim objSourceFolder
Dim strSourceFolder

Dim iSourcePageCount
Dim iSourceAnnotationCount
Dim iSourceAnnotationCountPage
Dim pAcroSourcePage
Dim pdSourceDoc

Dim objFSO
Dim objDictionary
Dim objTS
Dim strPath

Dim i


strDestFile = "out_pdf.csv"
iSourceAnnotationCount = 0

Set pdSourceDoc = CreateObject("AcroExch.PDDoc")
Set objSourceFolder = WScript.CreateObject("Shell.Application").BrowseForFolder(0, "Select source folder:", 81, "")

If Not objSourceFolder Is Nothing Then
strSourceFolder = objSourceFolder.self.Path

Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")

If objFSO.FolderExists(strSourceFolder) Then
Set objDictionary = WScript.CreateObject("Scripting.Dictionary")

ScanSubFolders objFSO.GetFolder(strSourceFolder)

If objDictionary.Count > 0 Then
Set objTS = objFSO.CreateTextFile(objFSO.BuildPath(strSourceFolder, strDestFile), True)
objTS.WriteLine "Путь к файлу;Количество примечаний"

For Each strPath In objDictionary.Items
pdSourceDoc.Open(strPath)
iSourcePageCount = pdSourceDoc.GetNumPages()
for i=0 to iSourcePageCount-1
Set pAcroSourcePage = pdSourceDoc.AcquirePage(i)
iSourceAnnotationCountPage = pAcroSourcePage.GetNumAnnots()/2
iSourceAnnotationCount = iSourceAnnotationCount + iSourceAnnotationCountPage
'msgbox iSourcePageCount
'msgbox iSourceAnnotationCount
Next
objTS.WriteLine strPath & ";" & iSourceAnnotationCount
iSourceAnnotationCount = 0
pdSourceDoc.Close
Next
objTS.Close
Set objTS = Nothing
Else
WScript.Echo "Nothing found."
End If

Else
WScript.Echo "Can't use folder [" & strSourceFolder & "]."
WScript.Quit 1
End If

Set objFSO = Nothing
Set objSourceFolder = Nothing
Else
WScript.Echo "Вы не выбрали папку с файлами."
End If

WScript.Quit 0
'=============================================================================

'=============================================================================
Sub ScanSubFolders(objFolder)
Dim objSubFolder
Dim objFile

For Each objFile In objFolder.Files
Select Case LCase(objFSO.GetExtensionName(objFile.Name))
Case "pdf"
objDictionary.Add objFile.Path, objFile.Path
Case Else
' Nothing to do
End Select
Next

For Each objSubFolder In objFolder.SubFolders
ScanSubFolders objSubFolder
Next
End Sub
'=============================================================================

[Iska]

Fresh96, не стоит ли вынести создание объекта «AcroExch.PDDoc» за пределы цикла?

[Fresh96]

Подправил.