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ファイルをスクリプトファイルにドラッグ&ドロップすることで、指定したフォルダに添付ファイルを保存することが出来ます。

関連記事

  1. VBScript

    文字コードを指定してURLエンコードを行う

    本題に入る前にまずは下記エントリーをご覧ください。・64ビット…

  2. VBScript

    Adobe Illustratorを操作するVBScript

    Acrobatと同様にタイプライブラリが用意されているため、VBAやV…

  3. VBScript

    パスワードに使えそうなランダムな文字列を作成するVBScript

    前回の記事の続きです。前回はGUIDを作成するスクリプトでした…

  4. VBScript

    Office文書を旧バージョンのファイル形式に変換するVBScript

    xlsxやdocxといった新しい形式のOffice文書をスクリプトファ…

  5. Windows関連

    Windows 8を従来のスタイルに変更するスクリプト

    2012/3/2 追記:下記情報はWindows Develope…

コメント

  • コメント (0)

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

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

Time limit is exhausted. Please reload CAPTCHA.

最近の記事

アーカイブ

RapidSSL_SEAL-90x50
PAGE TOP