2017年12月
          1 2
3 4 5 6 7 8 9
10 11 12 13 14 15 16
17 18 19 20 21 22 23
24 25 26 27 28 29 30
31            

« ∇Windows7トラブル解決(クライアント証明書がインストール出来ない) | トップページ | ∇Windows7トラブル解決(プロダクトキーの認証期限切れ) »

2011年4月 9日 (土)

◆Outlook VBA(複数メールの添付ファイルを一括保存3 と Excel一覧出力)

久しぶりのOutlook VBAネタです。
またまたコメントを頂きましたので
(1)添付ファイル一括保存マクロ
(2)Excel一覧出力
改良してみました。

Excel一覧出力時に添付ファイルにハイパーリンクを設定できないかというものです。
一応できたので公開してみます。
添付ファイル一括保存は保存先に同一ファイル名があるとファイル名を変更してしまうので
メール側の添付ファイル名をその変更したファイル名に変えてやり、Excel一覧出力では
その変更したファイル名で一覧出力するというふうに変更しました。
セルも添付ファイルごとに別々に出力するようにしました。したがって一番右端に出力していきます。
ハイパーリンクを設定したくない場合は、保存先フォルダの指定ダイアログでキャンセルしてください。
一点注意点ですが、メール側の添付ファイル名(FileName)は見た目上変化がありませんが、
管理上のファイル名(DisplyName)が保存したファイル名になります。
詳細は下記ソースを参照してください(ちょっと長いですが)。

'################################################################################
'# <機能名>      選択メールの添付ファイルを指定フォルダに一括保存
'# <機能概要>    選択メールの添付ファイルを指定フォルダに一括保存する
'################################################################################
Sub 選択メールの添付ファイルを指定フォルダに一括保存()
    Dim cDir As String, oSel As Object, oF As Object
    Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
    Dim myNameSpace As Outlook.NameSpace
    Dim myFolder As Outlook.MAPIFolder
    Dim mySendFolder As Outlook.MailItem
    Dim myCopiedItem As Outlook.Items
    Dim lMax As Integer, i As Integer
    Dim MyTitle As String
    Dim Leng As Long, hWnd As Long, ret As Long

    Dim myAttachments As Outlook.Attachment
    Dim MsgTxt As String, a As String
    Dim myExlApp As Object, Files As Object
    Dim lSubject As String
    Dim fs As Object
    Dim lpath As String, lVal As String
    Dim cnt As Integer
   
    On Error Resume Next
    Set myOlApp = CreateObject("Outlook.Application")
    Set myOlExp = myOlApp.ActiveExplorer
    Set myOlSel = myOlExp.Selection
   
    Set myExlApp = CreateObject("excel.Application")
    cDir = myExlApp.GetSaveAsFilename("DUMMY", "全ファイル(*.*),*.*", , "保存先フォルダ指定")
    If cDir = "False" Or cDir = "FALSE" Then GoTo p_exit
   
    cDir = Mid(cDir, 1, InStrRev(cDir, "\") - 1)
   
    '現在のウィンドウタイトル取得
    hWnd = GetActiveWindow()
    MyTitle = String(250, Chr(10))
    Leng = Len(MyTitle)
    ret = GetWindowText(hWnd, MyTitle, Leng)

    Set fs = CreateObject("Scripting.FileSystemObject")
    '選択されたメールの添付ファイルを保存
    On Error GoTo 0
    For Each oSel In myOlSel
        i = i + 1
        ret = SetWindowText(hWnd, oSel & "(" & i & "/" & myOlSel.Count & ")" & "を処理中...")
        For Each oF In oSel.Attachments
            lpath = cDir & "\" & oF.FileName
            'lpath = cDir & "\" & oF.DisplayName
            If Not (fs.FileExists(lpath)) Then
                oF.SaveAsFile lpath
            Else
                cnt = 0
                Do Until Not (fs.FileExists(lpath))
                    cnt = cnt + 1
                    lVal = Mid(oF.FileName, 1, InStrRev(oF.FileName, ".") - 1)
                    lVal = lVal & "_" & cnt & Mid(oF.FileName, InStrRev(oF.FileName, "."))
                    lpath = cDir & "\" & lVal
                    oF.DisplayName = lVal
                Loop
               
                oF.SaveAsFile lpath
            End If
        Next
       
    Next
   
    ret = SetWindowText(hWnd, MyTitle)
    MsgBox "終了しました。総数:" & i
    ret = Shell("c:\windows\explorer.exe " & cDir, vbNormalFocus)

p_exit:
    Set fs = Nothing
    Set myExlApp = Nothing
    Set oSel = Nothing
    Set oF = Nothing
    Set myOlApp = Nothing
    Set myOlExp = Nothing
    Set myOlSel = Nothing
   
End Sub


'################################################################################
'# <機能名>      選択メール情報をExcel一覧化
'# <機能概要>    選択メールの内容をExcelブックに一覧化する
'################################################################################
Sub 選択メールの情報をExcel一覧化()
    Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
    Dim MsgTxt As String, a As String
    Dim Files As Variant, oF As Variant
    Dim myExlApp As Object, oNewWb As Object, oSel As Object
    Dim i As Integer, j As Integer
    Dim lSubject As String
    Dim lMsg As String
    Dim lSentOnBehalfOfName As String
    Dim lSenderName  As String
    Dim lReceivedByName  As String
    Dim lReceivedOnBehalfOfName   As String
    Dim lReplyRecipientNames  As String
    Dim lTo  As String
    Dim lCC  As String
    Dim lBCC  As String
    Dim lCreationTime  As String
    Dim lSize  As Long
    Dim lsenderemailaddress  As String
    Dim lTempFile  As String
    Const cSt As String = "31665"
    Const cEd As String = "掲載内容に"
   
    '現在のウィンドウタイトル取得
    Dim Leng As Long, hWnd As Long, ret As Long, lMax As Long, MyTitle As String
    hWnd = GetActiveWindow()
    MyTitle = String(250, Chr(10))
    Leng = Len(MyTitle)
    ret = GetWindowText(hWnd, MyTitle, Leng)
   
    Set myOlApp = CreateObject("Outlook.Application")
    Set myOlExp = myOlApp.ActiveExplorer
    Set myOlSel = myOlExp.Selection
   
    '新規ブック作成
    Set myExlApp = CreateObject("excel.Application")
    Set oNewWb = myExlApp.workbooks.Add
    '一覧整形
    myExlApp.ActiveWindow.Zoom = 85
    With oNewWb.sheets(1)
        .cells.WrapText = True
        .Range("A1:N1") = Array("件名", "本文", "受信日時", "サイズ", "送信者表示名", "送信者", "受信者表示名", "受信者", "", "TO", "CC", "BCC", "送信者Address", "添付ファイル")
        .Columns("A:A").ColumnWidth = 32
        .Columns("B:B").ColumnWidth = 40
        .Columns("C:D").ColumnWidth = 15.71
        .Columns("K:k").ColumnWidth = 15.71
        .rows("2:2").Select
    End With
    myExlApp.ActiveWindow.FreezePanes = True
    With oNewWb.sheets(1)
        .Range("A1").Select
    End With
   
    MsgBox "添付ファイルがある場合、その保存先フォルダを指定してください。"
    cDir = myExlApp.GetSaveAsFilename("DUMMY", "全ファイル(*.*),*.*", , "保存先フォルダ指定")
    If cDir = "False" Or cDir = "FALSE" Then
        cDir = ""
    Else
        cDir = Mid(cDir, 1, InStrRev(cDir, "\") - 1)
    End If
    i = 1
    lMax = myOlSel.Count
    For Each oSel In myOlSel
       
        lSubject = oSel.Subject
        lMsg = oSel.Body
        lSentOnBehalfOfName = oSel.SentOnBehalfOfName
        lSenderName = oSel.SenderName
        lReceivedByName = oSel.ReceivedByName
        lReceivedOnBehalfOfName = oSel.ReceivedOnBehalfOfName
        lReplyRecipientNames = oSel.ReplyRecipientNames
        lTo = oSel.To
        lCC = oSel.CC
        lBCC = oSel.BCC
        lCreationTime = oSel.ReceivedTime
        lSize = oSel.Size
       
        i = i + 1
        a = lSubject & " (" & i - 1 & "/" & lMax & ")"
        ret = SetWindowText(hWnd, a & "を処理中...")
       
        oNewWb.sheets(1).cells(i, 1).Value = lSubject
        oNewWb.sheets(1).cells(i, 2).Value = lMsg
        oNewWb.sheets(1).cells(i, 3).Value = lCreationTime
        oNewWb.sheets(1).cells(i, 4).Value = Format(Int(lSize / 1024), "##,###") & "KB"
        oNewWb.sheets(1).cells(i, 5).Value = lSentOnBehalfOfName
        oNewWb.sheets(1).cells(i, 6).Value = lSenderName
        oNewWb.sheets(1).cells(i, 7).Value = lReceivedByName
        oNewWb.sheets(1).cells(i, 8).Value = lReceivedOnBehalfOfName
        oNewWb.sheets(1).cells(i, 9).Value = lReplyRecipientNames
        oNewWb.sheets(1).cells(i, 10).Value = lTo
        oNewWb.sheets(1).cells(i, 11).Value = lCC
        oNewWb.sheets(1).cells(i, 12).Value = lBCC
        oNewWb.sheets(1).cells(i, 13).Value = lsenderemailaddress
        lTempFile = ""
        j = 0
        For Each oF In oSel.Attachments
            lTempFile = lTempFile & oF.DisplayName & Chr(10)
            oNewWb.sheets(1).cells(i, 14 + j).Value = oF.DisplayName
            If cDir <> "" Then
                oNewWb.sheets(1).Hyperlinks.Add Anchor:=oNewWb.sheets(1).cells(i, 14 + j), Address:= _
                        cDir & "\" & oF.DisplayName, TextToDisplay:=oF.DisplayName
            End If
            j = j + 1
        Next
       
       
    Next

    myExlApp.Visible = True
   
p_Error:
    Set oF = Nothing
    Set oSel = Nothing
    Set myExlApp = Nothing
    Set oNewWb = Nothing
    Set myOlApp = Nothing
    Set myOlExp = Nothing
    Set myOlSel = Nothing
    ret = SetWindowText(hWnd, MyTitle)
    MsgBox "終了しました。総数:" & i - 1
End Sub

« ∇Windows7トラブル解決(クライアント証明書がインストール出来ない) | トップページ | ∇Windows7トラブル解決(プロダクトキーの認証期限切れ) »

パソコン・インターネット」カテゴリの記事

コメント

平陽凛さん

返事が遅くなり大変申し訳ありません。
コードまで書いていただき、本当にありがとうございます。大変助かりました!早速使っています。
私の思いついていたやり方とは、全く違っていて、こちらの方が遥かにエレガントだと思います。
filenameとdisplaynameのこんな使い方があったなんて、知りませんでした。
言葉では言い表せないほど感謝しています。ありがとうございます!

nobuoさん、こんにちは
思いついたやり方と全く違っていたとの事ですが、使って頂けて嬉しい限りです。当方も当初想定していなかったハイパーリンクという発想は素晴らしいと思いました。
また、何かありましたらご提案ください。

はじめまして。仕事で添付メールを格納したりしていたのですが、自動的にできると知って驚きです。参考になります。
ただ共有フォルダ(他の人のメールフォルダ)のを格納したい場合ってのはできるのでしょうか??
アクセス権限はあるのですが。。。

添付ファイルの保存とメール自体も別フォルダで保存しています。
ぜひできれば今後の業務の効率アップになります。
よろしくお願いします。

VBA初心者さん、こんばんは
平陽凛です。

ご質問の内容がよく分からないのですが、VBA初心者さんのメールを共有フォルダ(他人のフォルダ)に書き込みたいということでしょうか?

普通に考えて、書きこむ人が書込み先のフォルダに対してアクセス権を持っているのであれば、共有フォルダであろうとサーバ上のフォルダであろうと書き込めると思います。

私のソースで可能だと思いますので実際に試してみてはいかがでしょうか?

返事が遅くなり申し訳ございません。

自分宛に来たメールではなくて、共有フォルダで来たメール(他人宛)を格納したいのです。
アクセス権があれば大丈夫だということで安心しました。
時間が空いたとき頑張ってみます。
ありがとうございました。

VBA初心者さん、こんにちは
平陽凜です。
共有フォルダでメールを運用したことがないのでよく分からないのですが、他人に届いたメールをVBA初心者さんのOutlookで、あたかも受信したように受信フォルダに取り込めるのであれば、そのメールを選択して任意のフォルダに保存できると思います。
もしかしたら、セキュリティエラーが発生するかもしれませんがそのときは是非エラーメッセージを教えてください。

選択メールの情報をExcel一覧化()を使わせてもらっており、大変助かっております。
現在、大量(5000件以上)のメールを一度に一覧化したいのですが、
lMsg = oSel.Body
のところで実行エラーでとまってしまいます。
680数件目でとまるのですが、何かしら回避する方法はありますでしょうか?
お手数おかけいたしますが、ご確認いただけたらと思います。

コメントを書く

(ウェブ上には掲載しません)

« ∇Windows7トラブル解決(クライアント証明書がインストール出来ない) | トップページ | ∇Windows7トラブル解決(プロダクトキーの認証期限切れ) »