VBScript

msgファイルから添付ファイルを抽出するVBScript

msgファイルから添付ファイルを抽出するスクリプト」といったキーワードでのアクセスがありました。

恐らくエクスポートしたOutlookのメールファイル(msg)から添付ファイルだけを取り出すのが目的なのだろうと思います。

目的の処理は、Outlook経由であれば、NameSpaceオブジェクトのOpenSharedItemメソッドとAttachmentオブジェクトのSaveAsFileメソッドを使うことで処理できるかと思います。

'*************************************************************
' ドラッグ&ドロップしたmsgファイルから添付ファイルを抽出し、
' 指定したフォルダに保存するスクリプト
' 
' 2015/12/16 @kinuasa
'*************************************************************

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

上記コードでは、msgファイルをスクリプトファイルにドラッグ&ドロップすることで、指定したフォルダに添付ファイルを保存することが出来ます。

オトカドールをプレイしてきたよ。前のページ

Selenium WebDriverを使用してMicrosoft EdgeとOfficeを連携させる。次のページ

関連記事

  1. Office関連

    Outlookの予定本文の一部を文字装飾するVBAマクロ

    Outlookの予定本文の一部をマクロで太字にしたい」との質問がありま…

  2. Office関連

    未読アイテムの件数を取得するOutlookマクロ

    「Outlook 未読 件数 マクロ」といったキーワード検索でのアクセ…

  3. Office関連

    Wordのテンプレートをインストールするスクリプト

    Wordマクロをテンプレートにして使用する場合、通常そのテンプレートフ…

  4. VBScript

    Acrobatを使ってPDFファイルを結合するVBScript

    「Acrobat PDF 結合 コマンドライン」といったキーワード検索…

  5. VBScript

    Illustratorに登録されたPDFプリセットを列挙するVBScript

    前回の記事で、VBSからIllustratorが操作できることを紹介し…

  6. VBScript

    ファイル選択ダイアログ

    ファイル選択ダイアログを表示するVBScriptをまとめてみま…

コメント

  • コメント (0)

  • トラックバックは利用できません。

  1. この記事へのコメントはありません。

Time limit is exhausted. Please reload CAPTCHA.

※本ページはプロモーションが含まれています。

Translate

最近の記事

アーカイブ

PAGE TOP