VBSでMSGファイルから添付ファイルを抽出するスクリプト

Question

処理時間を短縮させることはできないでしょうか。

'*************************************************************
' ドラッグ＆ドロップしたmsgファイルから添付ファイルを抽出し、
' 指定したフォルダに保存するスクリプト
' 
' 2015/12/16 @kinuasa
' 2021/07/22 @Nonomura 保存フォルダをVBSのあるフォルダに変更　https://qiita.com/asterisk9101/items/54cdcedb9ef60ea0bb21  @asterisk9101が2015年06月09日に更新
'*************************************************************
 
Option Explicit

Dim fso											'2021/07/22 @Nonomura
set fso = createObject("Scripting.FileSystemObject")					'2021/07/22 @Nonomura

Dim strFolderPath									'2021/07/22 @Nonomura
strFolderPath = fso.getParentFolderName(WScript.ScriptFullName)				'2021/07/22 @Nonomura

Dim Dup 										'2021/07/22 @Nonomura　重複ファイル名蓄積   
Dim MyFlag										'2021/07/22 @Nonomura  重複フラグ
Dim Mydic
Set Mydic = CreateObject("Scripting.Dictionary")
  
Dup = "削除された添付ファイル,MSGファイル"  & vbCrLf					'2021/07/22 @Nonomura  重複メッセージ
MyFlag = 0										'2021/07/22 @Nonomura  重複フラグ


Dim args
Dim olApp
Dim i
'Const SaveFolderPath = "C:\Users\user\Desktop\添付ファイル抽出" '添付ファイルの保存先フォルダ(※要変更) 2021/07/22 @Nonomura ↓に変更
dim SaveFolderPath									'2021/07/22 @Nonomura
SaveFolderPath = strFolderPath								'2021/07/22 @Nonomura
 
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), Mydic, Dup, MyFlag	'2021/07/22 @Nonomura 引数追加
      End Select
    End If
  Next
  olApp.Quit
End With

 if MyFlag = 1 then
  msgbox "添付ファイルの一部は、ファイル名が同一であったため、上書きされました。" & vbCrLf & _
	"重複データ.csvを確認してください。"						'2021/07/22 @Nonomura  重複メッセージ

  Dim ts 
  Set ts = fso.CreateTextFile(SaveFolderPath & "\重複データ.csv", True, True)

  ts.Write (Dup) ' 書き込み
  ts.Close ' ファイルを閉じる
 End if


 
MsgBox "処理が終了しました。", vbInformation + vbSystemModal

Private Sub SaveMsgAttachments(ByVal OutlookApp, ByVal MsgFilePath, ByVal SaveFolderPath, ByRef Mydic, ByRef Dup, ByRef MyFlag) '2021/07/22 @Nonomura 引数追加 
  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
		Dup = Dup & atc.FileName & "," & Mydic(atc.FileName) & vbCrLf		'2021/07/22 @Nonomura 
                If Mydic.Exists(atc.FileName) = True Then				'2021/07/22 @Nonomura
		  Mydic.Remove atc.FileName						'2021/07/22 @Nonomura
		  Mydic.Add atc.FileName, .getFileName(MsgFilePath)			'2021/07/22 @Nonomura
                End If
                .DeleteFile fn, True '同名のファイルがあったら事前に削除
              End If
              If Mydic.Exists(atc.FileName) = False Then				'2021/07/22 @Nonomura
                Mydic.Add atc.FileName, .getFileName(MsgFilePath)			'2021/07/22 @Nonomura
              Else									'2021/07/22 @Nonomura
                MyFlag = 1								'2021/07/22 @Nonomura  重複フラグ
              End If									'2021/07/22 @Nonomura
              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

Answer 1

ループ処理の中にあるcreateObject("Scripting.FileSystemObject")をfsoに置き換えて、呼び出し元から引数としてオブジェクトを渡してあげるようにしたら多少速くなりました。

'*************************************************************
' ドラッグ＆ドロップしたmsgファイルから添付ファイルを抽出し、
' 指定したフォルダに保存するスクリプト
' 
' 2015/12/16 @kinuasa
' 2021/07/22 @Nonomura 保存フォルダをVBSのあるフォルダに変更　https://qiita.com/asterisk9101/items/54cdcedb9ef60ea0bb21  @asterisk9101が2015年06月09日に更新
'*************************************************************
 
Option Explicit

Dim fso											'2021/07/22 @Nonomura
set fso = createObject("Scripting.FileSystemObject")					'2021/07/22 @Nonomura

Dim strFolderPath									'2021/07/22 @Nonomura
strFolderPath = fso.getParentFolderName(WScript.ScriptFullName)				'2021/07/22 @Nonomura

Dim Dup 										'2021/07/22 @Nonomura　重複ファイル名蓄積   
Dim list										'2021/07/22 @Nonomura
Dim MyFlag										'2021/07/22 @Nonomura  重複フラグ
Dim Mydic
Set Mydic = CreateObject("Scripting.Dictionary")
  
Dup = "削除された添付ファイル,削除されたMSG,上書きしたMSG"  & vbCrLf					'2021/07/22 @Nonomura  重複メッセージ
list = "MSGファイル,添付ファイル"  & vbCrLf
MyFlag = 0										'2021/07/22 @Nonomura  重複フラグ


Dim args
Dim olApp
Dim i
'Const SaveFolderPath = "C:\Users\user\Desktop\添付ファイル抽出" '添付ファイルの保存先フォルダ(※要変更) 2021/07/22 @Nonomura ↓に変更
dim SaveFolderPath									'2021/07/22 @Nonomura
SaveFolderPath = strFolderPath								'2021/07/22 @Nonomura
 
Set args = WScript.Arguments
If args.Count < 1 Then
  MsgBox "msgファイルを当スクリプトファイルにドラッグ＆ドロップしてください。", vbExclamation + vbSystemModal
  WScript.Quit
End If
 
With fso
  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), Mydic, Dup, MyFlag, list, fso	'2021/07/22 @Nonomura 引数追加
      End Select
    End If
  Next
  olApp.Quit
End With

 if MyFlag = 1 then
  msgbox "添付ファイルの一部は、ファイル名が同一であったため、上書きされました。" & vbCrLf & _
	"重複データ.csvを確認してください。"						'2021/07/22 @Nonomura  重複メッセージ

  Dim ts 
  Set ts = fso.CreateTextFile(SaveFolderPath & "\!重複データ.csv", True, True)

  ts.Write (Dup) ' 書き込み
  ts.Close ' ファイルを閉じる
  Set ts = fso.CreateTextFile(SaveFolderPath & "\!添付ファイルリスト.csv", True, True)
  ts.Write (list) ' 書き込み
  ts.Close ' ファイルを閉じる

 End if


 
MsgBox "処理が終了しました。", vbInformation + vbSystemModal

Private Sub SaveMsgAttachments(ByVal OutlookApp, ByVal MsgFilePath, ByVal SaveFolderPath, ByRef Mydic, ByRef Dup, ByRef MyFlag, ByRef list, ByVal fso) '2021/07/22 @Nonomura 引数追加 
  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 fso
            For Each atc In itm.Attachments
              fn = SaveFolderPath & atc.FileName
              list = list & .getFileName(MsgFilePath) & "," & atc.FileName & vbCrLf	'2021/07/22 @Nonomura
              If .FileExists(fn) = True Then
		Dup = Dup & atc.FileName & "," & Mydic(atc.FileName) & "," & .getFileName(MsgFilePath) & vbCrLf		'2021/07/22 @Nonomura 
                If Mydic.Exists(atc.FileName) = True Then				'2021/07/22 @Nonomura
		  Mydic.Remove atc.FileName						'2021/07/22 @Nonomura
		  Mydic.Add atc.FileName, .getFileName(MsgFilePath)			'2021/07/22 @Nonomura
                End If
                .DeleteFile fn, True '同名のファイルがあったら事前に削除
              End If
              If Mydic.Exists(atc.FileName) = False Then				'2021/07/22 @Nonomura
                Mydic.Add atc.FileName, .getFileName(MsgFilePath)			'2021/07/22 @Nonomura
              Else									'2021/07/22 @Nonomura
                MyFlag = 1								'2021/07/22 @Nonomura  重複フラグ
              End If									'2021/07/22 @Nonomura
              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