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

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

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

  2. Excel

    フォルダ内にあるExcelファイルをカウントするVBScript

    「フォルダ内 Excel 数える VBScript」といったキーワード…

  3. Office関連

    [Outlook VBA]最小化起動時にApplication.Startupイベントが発生しない。…

    Outlook起動時、すべてのアドインが読み込まれた後に発生するApp…

  4. VBScript

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

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

  5. Office関連

    「2014年12月のWindows Update以降コマンドボタンが使えなくなった」トラブルへのFi…

    当ブログでも「KB2553154の更新プログラムをアンインストールする…

  6. VBScript

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

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

コメント

  • コメント (0)

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

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

Time limit is exhausted. Please reload CAPTCHA.

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

Translate

最近の記事

アーカイブ

PAGE TOP