ThisOutlookSession
Option Explicit
Const saveFld = "XXX" Const checker = "YYY"
Public Sub addMenu() Const cMenu As String = "menu bar" Const cCtl1 As String = "Toolsメニュー(&M)" Const cCtl2 As String = "選択メールの添付ファイルを指定フォルダに一括保存" Const cCtl3 As String = "下書きメールに添付ファイルを添付して送信トレイに一括格納" Const cCtl4 As String = "選択メールを一括送信" Const cCtl5 As String = "選択メールの情報をExcel一覧化" Const cCtl99 As String = "バージョン情報"
Dim oExp As Outlook.Explorer Dim oBar As Office.CommandBar Dim myControl Dim mySubControl
Set oExp = Outlook.ActiveExplorer Set oBar = oExp.CommandBars.Item(cMenu)
For Each myControl In oBar.Controls If cCtl1 Like myControl.Caption & "*" Then myControl.Delete End If Next Set myControl = oBar.Controls.Add(msoControlPopup, , , 7, True)
With myControl .Caption = cCtl1
Set mySubControl = .Controls.Add(msoControlButton, , , , True) With mySubControl .Caption = cCtl2 & "(&H)" .FaceId = 721 .Style = msoButtonIconAndCaption .Tag = cCtl2 .Visible = True .OnAction = "doSaveAttachments" End With
Set mySubControl = .Controls.Add(msoControlButton, , , , True) With mySubControl .Caption = cCtl3 & "(&K)" .BeginGroup = True .FaceId = 3739 .Style = msoButtonIconAndCaption .Tag = cCtl3 .Visible = True .OnAction = cCtl3 End With
Set mySubControl = .Controls.Add(msoControlButton, , , , True) With mySubControl .Caption = cCtl4 & "(&S)" .FaceId = 2617 .Style = msoButtonIconAndCaption .Tag = cCtl4 .Visible = True .OnAction = cCtl4 End With
Set mySubControl = .Controls.Add(msoControlButton, , , , True) With mySubControl .Caption = cCtl5 & "(&E)" .BeginGroup = True .FaceId = 366 .Style = msoButtonIconAndCaption .Tag = cCtl5 .Visible = True .OnAction = cCtl5 End With
Set mySubControl = .Controls.Add(msoControlButton, , , , True) With mySubControl .Caption = cCtl99 & "(&A)" .BeginGroup = True .FaceId = 3998 .Style = msoButtonIconAndCaption .Tag = cCtl99 .Visible = True .OnAction = cCtl99 End With End With
Set oExp = Nothing Set oBar = Nothing Set myControl = Nothing Set mySubControl = Nothing End Sub
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) Dim mail As MailItem Dim recip As recipient Dim ccToOkada As Boolean Dim ccToOkadaSan As Boolean
ccToOkadaSan = False Debug.Print "begin to send" Debug.Print Item.Class If Item.Class = olMail Then Debug.Print "send mail" Set mail = Item
If mail.Attachments.Count > 0 Then Debug.Print "has attachments"
For Each recip In mail.Recipients Debug.Print recip.Name If recip.Name = checker Then ccToOkadaSan = True Exit For End If Next
If Not ccToOkadaSan Then MsgBox checker & "さんにCCしてください。" mail.CC = mail.CC & "," & checker Cancel = True End If End If End If End Sub
' メール受信時に発生するイベント Private Sub Application_NewMailEx(ByVal EntryIDCollection As String) Dim i As Integer Dim c As Integer Dim colID As Variant ' If InStr(EntryIDCollection, ",") = 0 Then saveAttachments EntryIDCollection Else colID = Split(EntryIDCollection, ",") For i = LBound(colID) To UBound(colID) saveAttachments colID(i) Next End If End Sub
' ' 添付ファイルの保存を行うサブ プロシージャ Private Sub saveAttachments(ByVal strEntryID As String) Dim objFSO As Object ' FileSystemObject Dim objMsg As Object Dim fld As String Dim command As String Dim Atmt As Attachment Dim FileName As String
fld = saveFld
Set objFSO = CreateObject("Scripting.FileSystemObject") Set objMsg = Application.Session.GetItemFromID(strEntryID) If objMsg.MessageClass = "IPM.Note" Then ' Save any attachments found For Each Atmt In objMsg.Attachments ' This path must exist! Change folder name as necessary. Debug.Print objMsg.MessageClass If Not objFSO.FolderExists(fld & "\" & Format(objMsg.ReceivedTime, "yyyymmdd")) Then objFSO.CreateFolder (fld & "\" & Format(objMsg.ReceivedTime, "yyyymmdd")) End If
FileName = fld & "\" & Format(objMsg.ReceivedTime, "yyyymmdd") & "\" & Atmt.FileName If Not objFSO.FileExists(FileName) Then Atmt.SaveAsFile FileName Debug.Print objFSO.GetExtensionName(FileName) If objFSO.GetExtensionName(FileName) = "rar" Or objFSO.GetExtensionName(FileName) = "zip" Then command = """C:\Program Files\WinRAR\WinRAR.exe"" x -pbis2011 -o+ " & FileName & " " & fld & "\" & Format(objMsg.ReceivedTime, "yyyymmdd") & "\" Call runCommand(command) End If End If Next Atmt End If
Set objMsg = Nothing Set objFSO = Nothing End Sub
'************************** ユソユ- ************************** '*** Code by Martin Green ******** martin@fontstuff.com *** '******* Office Tips Web Site - www.fontstuff.com ********* '**********************************************************
Sub GetAttachments() ' This Outlook macro checks a the Outlook Inbox for messages ' with attached files (of any type) and saves them to disk. ' NOTE: make sure the specified save folder exists before ' running the macro.
' On Error GoTo GetAttachments_err
' Declare variables Dim ns As NameSpace Dim Inbox As MAPIFolder Dim Item As Object Dim Atmt As Attachment Dim FileName As String Dim i As Integer Dim fld As String Dim fso As FileSystemObject Dim command As String
Set fso = New FileSystemObject fld = saveFld Set ns = GetNamespace("MAPI") Set Inbox = ns.GetDefaultFolder(olFolderInbox) i = 0 ' Check Inbox for messages and exit of none found If Inbox.Items.Count = 0 Then MsgBox "There are no messages in the Inbox.", vbInformation, _ "Nothing Found" Exit Sub End If ' Check each message for attachments For Each Item In Inbox.Items If Item.MessageClass = "IPM.Note" Then ' Save any attachments found For Each Atmt In Item.Attachments ' This path must exist! Change folder name as necessary. Debug.Print Item.MessageClass If Not fso.FolderExists(fld & "\" & Format(Item.ReceivedTime, "yyyymmdd")) Then fso.CreateFolder (fld & "\" & Format(Item.ReceivedTime, "yyyymmdd")) End If
FileName = fld & "\" & Format(Item.ReceivedTime, "yyyymmdd") & "\" & Atmt.FileName If Not fso.FileExists(FileName) Then Atmt.SaveAsFile FileName Debug.Print fso.GetExtensionName(FileName) If fso.GetExtensionName(FileName) = "rar" Or fso.GetExtensionName(FileName) = "zip" Then command = """C:\Program Files\WinRAR\WinRAR.exe"" e -pbis2011 -o+ " & FileName & " " & fld & "\" & Format(Item.ReceivedTime, "yyyymmdd") & "\" Call runCommand(command) End If End If i = i + 1 Next Atmt End If Next Item ' Show summary message If i > 0 Then MsgBox "I found " & i & " attached files." _ & vbCrLf & "I have saved them into the " & fld & " folder." _ & vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!" Else MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!" End If ' Clear memory GetAttachments_exit: Set Atmt = Nothing Set Item = Nothing Set ns = Nothing Exit Sub ' Handle errors GetAttachments_err: MsgBox "An unexpected error has occurred." _ & vbCrLf & "Please note and report the following information." _ & vbCrLf & "Macro Name: GetAttachments" _ & vbCrLf & "Error Number: " & Err.Number _ & vbCrLf & "Error Description: " & Err.Description _ , vbCritical, "Error!" Resume GetAttachments_exit End Sub
Sub SaveAttachmentsToFolder() ' This Outlook macro checks a named subfolder in the Outlook Inbox ' (here the "Sales Reports" folder) for messages with attached ' files of a specific type (here file with an "xls" extension) ' and saves them to disk. Saved files are timestamped. The user ' can choose to view the saved files in Windows Explorer. ' NOTE: make sure the specified subfolder and save folder exist ' before running the macro. On Error GoTo SaveAttachmentsToFolder_err ' Declare variables Dim ns As NameSpace Dim Inbox As MAPIFolder Dim SubFolder As MAPIFolder Dim Item As Object Dim Atmt As Attachment Dim FileName As String Dim i As Integer Dim varResponse As VbMsgBoxResult Dim fld As String
fld = saveFld Set ns = GetNamespace("MAPI") Set Inbox = ns.GetDefaultFolder(olFolderInbox) Set SubFolder = Inbox.Folders("Sales Reports") ' Enter correct subfolder name. i = 0 ' Check subfolder for messages and exit of none found If SubFolder.Items.Count = 0 Then MsgBox "There are no messages in the Sales Reports folder.", vbInformation, _ "Nothing Found" Exit Sub End If ' Check each message for attachments For Each Item In SubFolder.Items For Each Atmt In Item.Attachments ' Check filename of each attachment and save if it has "xls" extension If Right(Atmt.FileName, 3) = "xls" Then ' This path must exist! Change folder name as necessary. FileName = fld & "\" & _ Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName Atmt.SaveAsFile FileName i = i + 1 End If Next Atmt Next Item ' Show summary message If i > 0 Then varResponse = MsgBox("I found " & i & " attached files." _ & vbCrLf & "I have saved them into the " & fld & " folder." _ & vbCrLf & vbCrLf & "Would you like to view the files now?" _ , vbQuestion + vbYesNo, "Finished!") ' Open Windows Explorer to display saved files if user chooses If varResponse = vbYes Then Shell "Explorer.exe /e," & fld & "", vbNormalFocus End If Else MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!" End If ' Clear memory SaveAttachmentsToFolder_exit: Set Atmt = Nothing Set Item = Nothing Set ns = Nothing Exit Sub ' Handle Errors SaveAttachmentsToFolder_err: MsgBox "An unexpected error has occurred." _ & vbCrLf & "Please note and report the following information." _ & vbCrLf & "Macro Name: GetAttachments" _ & vbCrLf & "Error Number: " & Err.Number _ & vbCrLf & "Error Description: " & Err.Description _ , vbCritical, "Error!" Resume SaveAttachmentsToFolder_exit End Sub
Private Sub Application_Startup() addMenu End Sub
Public Sub doSaveAttachments() ' Declare variables Dim ns As NameSpace Dim Inbox As MAPIFolder Dim Atmt As Attachment Dim FileName As String Dim i As Integer Dim fld As String Dim fso As FileSystemObject Dim command As String Dim mail As Object Dim theMail As MailItem
Set fso = New FileSystemObject fld = saveFld Set ns = GetNamespace("MAPI") Set Inbox = ns.GetDefaultFolder(olFolderInbox) Debug.Print Inbox.GetExplorer().Selection.Count For Each mail In Application.ActiveExplorer.Selection Set theMail = mail Debug.Print theMail.Subject For Each Atmt In theMail.Attachments ' This path must exist! Change folder name as necessary. Debug.Print theMail.MessageClass If Not fso.FolderExists(fld & "\" & Format(theMail.ReceivedTime, "yyyymmdd")) Then fso.CreateFolder (fld & "\" & Format(theMail.ReceivedTime, "yyyymmdd")) End If
FileName = fld & "\" & Format(theMail.ReceivedTime, "yyyymmdd") & "\" & Atmt.FileName If Not fso.FileExists(FileName) Then Debug.Print "Save to " & FileName Atmt.SaveAsFile FileName Debug.Print fso.GetExtensionName(FileName) If fso.GetExtensionName(FileName) = "rar" Or fso.GetExtensionName(FileName) = "zip" Then command = """C:\Program Files\WinRAR\WinRAR.exe"" e -pbis2011 -o+ " & FileName & " " & fld & "\" & Format(theMail.ReceivedTime, "yyyymmdd") & "\" Debug.Print command Call runCommand(command) End If End If i = i + 1 Next Atmt Next End Sub
Public Sub runCommand(command As String) Dim WSH, wExec, sCmd As String, Result As String Set WSH = CreateObject("WScript.Shell") ''(1) sCmd = """C:\Program Files\WinRAR\WinRAR.exe"" e -pbis2011 -o+ Y:\次期データ交換\90_杭州送付\20110414\2011-4-14-会議記録.rar Y:\次期データ交換\90_杭州送付\20110414" ''(2) sCmd = command 'Set wExec = WSH.Exec("%ComSpec% /c " & sCmd) ''(3) Call WSH.run("%ComSpec% /c " & sCmd, 0, True) ' Do While wExec.Status = 0 ''(4) ' DoEvents ' Loop ' Result = wExec.StdOut.ReadAll ''(5) '' MsgBox Result ' Set wExec = Nothing Set WSH = Nothing End Sub
|
|
|