質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

87.59%

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

解決済

回答 1

投稿

  • 評価
  • クリップ 0
  • VIEW 217

score 15

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

'*************************************************************
' ドラッグ&ドロップした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
  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 1

check解決した方法

0

ループ処理の中にある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

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 87.59%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る