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. VBScript

    Expression WebでVBScriptのコードを書いてみる。

    今日たまたま下記の記事を見つけました。10年近く前の古い記事です。…

  2. Windows関連

    OSのバージョン情報をクリップボードにコピーするVBScript

    OSのバージョンやビルド番号をブログの記事内に書くことがあるのですが、…

  3. VBScript

    動画回転用簡易FFmpegフロントエンド

    アーケードゲームのプレイを録画した際、機器によっては録画した動画の向き…

  4. Windows関連

    ダウンロードフォルダーのパスを取得するVBScript

    ダウンロードフォルダーのパスを取得する必要があったので、過去に書いた記…

  5. VBScript

    Windowsのバージョン情報を取得する

    小ネタです。verコマンドを利用してWindowsのバージ…

  6. VBScript

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

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

コメント

  • コメント (0)

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

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

Time limit is exhausted. Please reload CAPTCHA.

最近の記事

アーカイブ

PAGE TOP