複数の階層に別れた2000程のﾌｫﾙﾀﾞがあり､各ﾌｫﾙﾀﾞの中にPDFﾌｧｲﾙが入っています｡これらPDFﾌｧｲﾙを同一ﾌｫﾙﾀﾞ内に移動させ､『PDF→透明ﾃｷｽﾄ付きPD…

お手元にExcelはありますでしょうか｡

ExcelのVBAでPDFを収集するﾏｸﾛと書き戻すﾏｸﾛを書いてみました｡

VBAとはなんぞやという場合は､こちらを参考にしてみてください｡

http://www.officepro.jp/excelvba/ini/index1.html

http://www.officepro.jp/excelvba/ini/index2.html

http://www.officepro.jp/excelvba/ini/index3.html

標準ﾓｼﾞｭｰﾙに以下のｺｰﾄﾞをｺﾋﾟﾍﾟすればいいです｡

ｺｰﾄﾞの最初の､2行は実際の環境に変更してください｡

rootというのはPDFの入っているﾌｫﾙﾀﾞの一番上の階層のﾌｫﾙﾀﾞ

作業となっているのは集める為のﾌｫﾙﾀﾞです｡

Const RootFolderPass = "C:\Documents and Settings\hogehoge\ﾃﾞｽｸﾄｯﾌﾟ\root"
Const MyFolderPass = "C:\Documents and Settings\hogehoge\ﾃﾞｽｸﾄｯﾌﾟ\作業"

Private FSO As Object
Private r As Long

Sub PDF収集()
 Set FSO = CreateObject("Scripting.FileSystemObject")
 r = 1
 Cells.Clear
 Call getPDF(FSO.GetFolder(RootFolderPass))
 Set FSO = Nothing
End Sub

Sub getPDF(fold As Object)
 Dim myFile As Object
 Dim myFold As Object
 Dim strName As String
 Dim i As Long
 Dim j As Integer
 
 For Each myFile In fold.Files
 If StrConv(Right(myFile.Name, 4), vbLowerCase) = ".pdf" Then
 Cells(r, 1).Value = myFile.Path
 strName = Left(myFile.Name, Len(myFile.Name) - 4)
 j = Len(strName)
 i = 0
 While Not Range("B:B").Find(strName, lookat:=xlWhole, MatchCase:=False) Is Nothing
 i = i + 1
 strName = Left(strName, j) & i
 Wend
 Cells(r, 2).Value = strName
 
 On Error Resume Next
 Call FSO.CopyFile(myFile.Path, MyFolderPass & "\" & strName & ".pdf")
 If Err.Number > 0 Then Cells(r, 3).Value = "失敗"
 On Error GoTo 0
 r = r + 1
 End If
 Next
 For Each myFold In fold.SubFolders
 Call getPDF(myFold)
 Next
End Sub

Sub PDF反映()
 Dim i As Long
 Dim lastRow As Long
 
 lastRow = Cells(Rows.Count, 1).End(xlUp).Row
 For i = 1 To lastRow
 If Cells(i, 3).Value <> "失敗" Then
 On Error Resume Next
 Call FSO.CopyFile(MyFolderPass & "\" & Cells(i, 2).Value & ".pdf", Cells(i, 1).Value, True)
 If Err.Number > 0 Then Cells(i, 4).Value = "失敗"
 On Error GoTo 0
 End If
 Next
End Sub

ｺｰﾄﾞでは､PDF収集を実行するとPDFﾌｧｲﾙを指定したﾌｫﾙﾀﾞに収集します｡

(ｺﾋﾟｰにしてますので元のﾌｧｲﾙは残ります)

ここでは同名のﾌｧｲﾙが存在するときの為に､同名のﾌｧｲﾙがあったら末尾に数字が入るようになっています｡

ExcelのｼｰﾄのA列に元のﾊﾟｽ､B列にﾌｧｲﾙ名､C列には読み取り専用などで移動できない場合に"失敗"と表示するようにしています｡

次に､OCR処理後にPDF反映を実行すると元の場所に上書きします｡

上書きを失敗した場合は､D列に"失敗"と表示します｡

先の処理の同名で末尾に数字がついたﾌｧｲﾙも元に戻ります｡

うまく動かなかった場合はｺﾒﾝﾄ欄をｵｰﾌﾟﾝしていただければ修正します｡

VBS を使用した例です｡

pdf ﾌｧｲﾙがある最上位階層(そのﾌｫﾙﾀﾞ自身は対象外です｡)で

下記を実行してください｡

CopyAll.bat がﾌｧｲﾙをｺﾋﾟｰするﾊﾞｯﾁ､

CopyBack.bat がﾌｧｲﾙを元にｺﾋﾟｰするﾊﾞｯﾁです｡

使用方法：

notepad 等に下記をｺﾋﾟｰし拡張子を vbs で保存します｡

Option Explicit
'-------------------------------------------------------
' ｽｸﾘﾌﾟﾄがあるﾌｫﾙﾀﾞ下(ｻﾌﾞﾌｫﾙﾀﾞも含む)のPDF
' ﾌｧｲﾙをｽｸﾘﾌﾟﾄのあるﾌｫﾙﾀﾞにｺﾋﾟｰするﾊﾞｯﾁ･･･CopyAll.bat
' と､ｺﾋﾟｰしたﾌｧｲﾙをｺﾋﾟｰﾊﾞｯｸするﾊﾞｯﾁ･･････CopyBack.bat
' を生成します｡
'-------------------------------------------------------

'-------------------------------------------------------
' ｺﾋﾟｰ対象のﾌｧｲﾙが重複なく､ｵﾘｼﾞﾅﾙ名を使用する場合は useOriginalName = True にしてください｡
' ｺﾋﾟｰ対象のﾌｧｲﾙが重複する場合は useOriginalName = False にしてください｡
'-------------------------------------------------------
Const useOriginalName = False

Public fso
Set fso = CreateObject( "Scripting.FileSystemObject" )

Public cFolder
Set cFolder = fso.getFile( WScript.ScriptFullName ). ParentFolder

Public copyBat
Set copyBat= fso.CreateTextFile( cFolder.Path & "\copyAll.bat" )

Public copyBackBat
Set copyBackBat = fso.CreateTextFile( cFolder.Path & "\copyBack.bat" )

Public fileID
fileID = 1
MakeFileList cFolder, True

copyBat.Close
copyBackBat.Close

'-------------------------------------------------------
Sub MakeFileList( rootFolder, isTop )
'-------------------------------------------------------
 Dim file, objName
 If isTop = False Then
 For Each file In rootFolder.Files
 If fso.GetExtensionName( file.Path ) = "pdf" Then
If useOriginalName = True Then
 objName = file.Name
Else
 objName = "WK_" & Right( "000000" & fileID, 6 ) & ".pdf"
 fileID = fileID + 1
End If
copyBat.WriteLine "COPY /Y """ & file.Path & """ """ & cFolder.Path & "\" & objName & """"
copyBackBat.WriteLine "COPY /Y """ & cFolder.Path & "\" & objName & """ """ & file.Path & """"
End If
 Next
 End If

 Dim folder
 For Each folder In rootFolder.SubFolders
 MakeFileList folder, False
 Next
End Sub