会社内でmsgファイルから添付ファイルを抽出するVBScriptを以下のコードで利用させてもらっています。ただ、同じファイル名の場合は取出すことができません。アンケート.xlsx、アンケート(2).xlsx、などという形でもれなく取出せるようにできないでしょうか？よろしくお願いいたします。
Option Explicit
Dim args
Dim olApp
Dim i
Const SaveFolderPath = "C:\Test" '添付ファイルの保存先フォルダ(※要変更)
Set args = WScript.Arguments
If args.Count < 1 Then
MsgBox "msgファイルを当スクリプトファイルにドラッグ＆ドロップしてください。", vbExclamation + vbSystemModal
WScript.Quit
End If
With CreateObject("Scripting.FileSystemObject")
If .FolderExists(SaveFolderPath) = False Then
MsgBox "添付ファイルの保存先フォルダが見つかりませんでした。" & vbCrLf & _
"処理を中止します。", vbCritical + vbSystemModal
WScript.Quit
End If
Set olApp = CreateObject("Outlook.Application")
For i = 0 To args.Count - 1
If .FileExists(args(i)) = True Then
Select Case LCase(.GetExtensionName(args(i)))
Case "msg" 'msgファイルのみ処理
SaveMsgAttachments olApp, args(i), AddPathSeparator(SaveFolderPath)
End Select
End If
Next
olApp.Quit
End With
MsgBox "処理が終了しました。", vbInformation + vbSystemModal
Private Sub SaveMsgAttachments(ByVal OutlookApp, ByVal MsgFilePath, ByVal SaveFolderPath)
Dim itm 'Outlook.MailItem
Dim atc 'Outlook.Attachment
Dim fn
With OutlookApp.GetNamespace("MAPI")
Set itm = .OpenSharedItem(MsgFilePath)
Select Case LCase(TypeName(itm))
Case "mailitem"
If itm.Attachments.Count < 1 Then
MsgBox "添付ファイルがありません。" & vbCrLf & _
"(ファイル名：" & MsgFilePath & ")", vbExclamation + vbSystemModal
Exit Sub
Else
With CreateObject("Scripting.FileSystemObject")
For Each atc In itm.Attachments
fn = SaveFolderPath & atc.FileName
If .FileExists(fn) = True Then
.DeleteFile fn, True '同名のファイルがあったら事前に削除
End If
atc.SaveAsFile fn
Next
End With
End If
End Select
End With
End Sub
Private Function AddPathSeparator(ByVal s)
If Right(s, 1) <> ChrW(92) Then s = s & ChrW(92)
AddPathSeparator = s
End Function
