VBAまたはマクロを使用してOutlookメールメッセージをExcelにコピーする方法
私はVBAとマクロの初心者です。誰かがVBAコードとマクロで私を助けてくれれば、それは役に立ちます。
毎日、標準の件名が「タスク完了」という50〜60通のメールが届きます。特定のフォルダに移動するすべてのメールに対するルールを作成しました：「タスク完了」。
1日に50〜60通すべてのメールを読んで、すべてのメールを更新するのは非常に時間がかかります。受信トレイに届く50-60通のメールはすべて、件名は同じですが、ユーザーが異なります。メールの本文は異なります。
Outlook 2010とExcel 2010を使用しています。
何をコピーする必要があるかについて言及していないため、以下のコードではそのセクションを空のままにしました。
また、最初にメールをフォルダーに移動してから、そのフォルダーでマクロを実行する必要もありません。受信メールでマクロを実行し、同時にフォルダーに移動できます。
これで開始できます。あなたがコードを理解するのに問題に直面しないように、コードをコメントしました。
まず、Outlookモジュールに以下のコードを貼り付けます。
それから
- ツール~~>ルールとアラートをクリックします
- 「新しいルール」をクリックします
- 「空のルールから開始」をクリックします
- 「到着時にメッセージを確認する」を選択します
- 条件の下で、「件名に特定の単語を含む」をクリックします
- ルールの説明の下にある「特定の単語」をクリックします。
- ポップアップするダイアログボックスにチェックしたい単語を入力し、「追加」をクリックします。
- [OK]をクリックして、[次へ]をクリックします
- 「指定したフォルダに移動」を選択しますおよび同じボックスで「スクリプトを実行」を選択します
- 下のボックスで、実行する特定のフォルダーとスクリプト（モジュールにあるマクロ）を指定します。
- 完了をクリックして完了です。
新しいメールが到着すると、指定したフォルダにメールが移動するだけでなく、そこからのデータもExcelにエクスポートされます。
[〜＃〜] untested [〜＃〜]
Const xlUp As Long = -4162
Sub ExportToExcel(MyMail As MailItem)
Dim strID As String, olNS As Outlook.Namespace
Dim olMail As Outlook.MailItem
Dim strFileName As String
'~~> Excel Variables
Dim oXLApp As Object, oXLwb As Object, oXLws As Object
Dim lRow As Long
strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set olMail = olNS.GetItemFromID(strID)
'~~> Establish an Excel application object
On Error Resume Next
Set oXLApp = GetObject(, "Excel.Application")
'~~> If not found then create new instance
If Err.Number <> 0 Then
Set oXLApp = CreateObject("Excel.Application")
End If
Err.Clear
On Error GoTo 0
'~~> Show Excel
oXLApp.Visible = True
'~~> Open the relevant file
Set oXLwb = oXLApp.Workbooks.Open("C:\Sample.xls")
'~~> Set the relevant output sheet. Change as applicable
Set oXLws = oXLwb.Sheets("Sheet1")
lRow = oXLws.Range("A" & oXLApp.Rows.Count).End(xlUp).Row + 1
'~~> Write to Outlook
With oXLws
'
'~~> Code here to output data from email to Excel File
'~~> For example
'
.Range("A" & lRow).Value = olMail.Subject
.Range("B" & lRow).Value = olMail.SenderName
'
End With
'~~> Close and Clean up Excel
oXLwb.Close (True)
oXLApp.Quit
Set oXLws = Nothing
Set oXLwb = Nothing
Set oXLApp = Nothing
Set olMail = Nothing
Set olNS = Nothing
End Sub
[〜＃〜] followup [〜＃〜]
電子メールの本文からコンテンツを抽出するには、SPLIT（）を使用してコンテンツを分割し、関連する情報を解析します。この例をご覧ください
Dim MyAr() As String
MyAr = Split(olMail.body, vbCrLf)
For i = LBound(MyAr) To UBound(MyAr)
'~~> This will give you the contents of your email
'~~> on separate lines
Debug.Print MyAr(i)
Next i
新しい紹介2
マクロ「SaveEmailDetails」の以前のバージョンでは、このステートメントを使用してInboxを見つけました。
Set FolderTgt = CreateObject("Outlook.Application"). _
GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
その後、新しいバージョンのOutlookをインストールしましたが、デフォルトの受信トレイを使用しないことがわかりました。私の電子メールアカウントごとに、それぞれ独自の受信トレイを持つ個別のストア（電子メールアドレスの名前）を作成しました。これらの受信ボックスはいずれもデフォルトではありません。
このマクロは、デフォルトの受信ボックスを保持しているストアの名前をイミディエイトウィンドウに出力します。
Sub DsplUsernameOfDefaultStore()
Dim NS As Outlook.NameSpace
Dim DefaultInboxFldr As MAPIFolder
Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI")
Set DefaultInboxFldr = NS.GetDefaultFolder(olFolderInbox)
Debug.Print DefaultInboxFldr.Parent.Name
End Sub
私のインストールでは、これは「Outlook Data File」を出力します。
任意のストアの受信ボックスにアクセスする方法を示す追加のステートメントをマクロ「SaveEmailDetails」に追加しました。
新しい紹介1
多くの人々が以下のマクロを選択し、有用であると判断し、さらなるアドバイスを求めて直接私に連絡しました。これらの連絡先に続いて、マクロにいくつかの改善を加えたため、以下の改訂版を投稿しました。また、Outlook階層を持つフォルダーのMAPIFolderオブジェクトを一緒に返すマクロのペアを追加しました。デフォルトのフォルダ以外にアクセスしたい場合に便利です。
元のテキストは、以前の質問にリンクした日付ごとに1つの質問を参照していました。最初の質問は削除されたため、リンクは失われました。そのリンクは Outlookメールに基づいてExcelシートを更新する（閉じた）
元のテキスト
「Outlook電子メールからExcelブックにデータを抽出するにはどうすればよいですか？」という質問には、驚くほど多くのバリエーションがあります。たとえば、[Outlook-vba]について2つの質問があり、同じ質問が8月13日に行われました。その質問は、私が答えようとした12月のバリエーションを参照しています。
12月の質問については、2部構成の回答で船外に出ました。最初の部分は、Outlookフォルダー構造を調査し、データをテキストファイルまたはExcelブックに書き込む一連のティーチングマクロでした。 2番目の部分では、抽出プロセスの設計方法について説明しました。この質問に対して、Siddarthは優れた簡潔な回答を提供し、次の段階を支援するフォローアップを提供しました。
すべてのバリエーションの質問者が理解できないと思われるのは、画面上でデータがどのように見えるかを表示しても、テキストまたはhtml本文がどのように見えるかを教えてくれないということです。この答えは、その問題を乗り越える試みです。
以下のマクロは、Siddarthのマクロよりも複雑ですが、12月の回答に含めたものよりもずっと単純です。追加できるものは他にもありますが、最初はこれで十分だと思います。
このマクロは、新しいExcelブックを作成し、受信トレイ内のすべての電子メールの選択されたプロパティを出力して、このワークシートを作成します。
マクロの上部近くに、8つのハッシュ（＃）を含むコメントがあります。そのコメントの下のステートメントmustは、Excelブックが作成されるフォルダーを識別するため、変更する必要があります。
ハッシュを含む他のすべてのコメントは、マクロを要件に適合させるための修正を提案します。
データを抽出する電子メールはどのように識別されますか？送信者、件名、本文内の文字列、またはこれらすべてですか？コメントは、興味のないメールを排除するのに役立ちます。質問を正しく理解できれば、興味深いメールにはSubject = "Task Completed"。
コメントは、興味深い電子メールからデータを抽出するのに役立ちませんが、ワークシートには、電子メール本文のテキストバージョンとhtmlバージョン（存在する場合）が表示されます。私の考えは、マクロが見るものを見て、抽出プロセスの設計を開始できるということです。
これは上記の画面イメージには示されていませんが、マクロはテキスト本文に2つのバージョンを出力します。最初のバージョンは変更されていません。つまり、タブ、キャリッジリターン、ラインフィードに従い、ブレークしないスペースはスペースのように見えます。 2番目のバージョンでは、これらのコードを[TB]、[CR]、[LF]、[NBSP]の文字列に置き換えて、それらが見えるようにしました。私の理解が正しければ、2番目のテキスト本文に以下が表示されると予想されます。
アクティビティ[TAB]カウント[CR] [LF]開く[TAB] 35 [CR] [LF] HCQA [TAB] 42 [CR] [LF] HCQC [TAB] 60 [CR] [LF] HAbst [TAB] 50 45 5 2 2 1 [CR] [LF]など
この文字列の元から値を抽出することは難しくありません。
メールのプロパティに加えて抽出した値を出力するようにマクロを修正してみます。この変更を成功させた場合にのみ、抽出したデータを既存のブックに書き込もうとします。また、処理済みのメールを別のフォルダーに移動します。これらの変更を行う必要がある場所を示しましたが、それ以上のヘルプは提供しません。この情報が必要になった時点で補足質問に回答します。
がんばろう。
元のテキストに含まれるマクロの最新バージョン
Option Explicit
Public Sub SaveEmailDetails()
' This macro creates a new Excel workbook and writes to it details
' of every email in the Inbox.
' Lines starting with hashes either MUST be changed before running the
' macro or suggest changes you might consider appropriate.
Dim AttachCount As Long
Dim AttachDtl() As String
Dim ExcelWkBk As Excel.Workbook
Dim FileName As String
Dim FolderTgt As MAPIFolder
Dim HtmlBody As String
Dim InterestingItem As Boolean
Dim InxAttach As Long
Dim InxItemCrnt As Long
Dim PathName As String
Dim ReceivedTime As Date
Dim RowCrnt As Long
Dim SenderEmailAddress As String
Dim SenderName As String
Dim Subject As String
Dim TextBody As String
Dim xlApp As Excel.Application
' The Excel workbook will be created in this folder.
' ######## Replace "C:\DataArea\SO" with the name of a folder on your disc.
PathName = "C:\DataArea\SO"
' This creates a unique filename.
' #### If you use a version of Excel 2003, change the extension to "xls".
FileName = Format(Now(), "yymmdd hhmmss") & ".xlsx"
' Open own copy of Excel
Set xlApp = Application.CreateObject("Excel.Application")
With xlApp
' .Visible = True ' This slows your macro but helps during debugging
.ScreenUpdating = False ' Reduces flash and increases speed
' Create a new workbook
' #### If updating an existing workbook, replace with an
' #### Open workbook statement.
Set ExcelWkBk = xlApp.Workbooks.Add
With ExcelWkBk
' #### None of this code will be useful if you are adding
' #### to an existing workbook. However, it demonstrates a
' #### variety of useful statements.
.Worksheets("Sheet1").Name = "Inbox" ' Rename first worksheet
With .Worksheets("Inbox")
' Create header line
With .Cells(1, "A")
.Value = "Field"
.Font.Bold = True
End With
With .Cells(1, "B")
.Value = "Value"
.Font.Bold = True
End With
.Columns("A").ColumnWidth = 18
.Columns("B").ColumnWidth = 150
End With
End With
RowCrnt = 2
End With
' FolderTgt is the folder I am going to search. This statement says
' I want to seach the Inbox. The value "olFolderInbox" can be replaced
' to allow any of the standard folders to be searched.
' See FindSelectedFolder() for a routine that will search for any folder.
Set FolderTgt = CreateObject("Outlook.Application"). _
GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
' #### Use the following the access a non-default Inbox.
' #### Change "Xxxx" to name of one of your store you want to access.
Set FolderTgt = Session.Folders("Xxxx").Folders("Inbox")
' This examines the emails in reverse order. I will explain why later.
For InxItemCrnt = FolderTgt.Items.Count To 1 Step -1
With FolderTgt.Items.Item(InxItemCrnt)
' A folder can contain several types of item: mail items, meeting items,
' contacts, etc. I am only interested in mail items.
If .Class = olMail Then
' Save selected properties to variables
ReceivedTime = .ReceivedTime
Subject = .Subject
SenderName = .SenderName
SenderEmailAddress = .SenderEmailAddress
TextBody = .Body
HtmlBody = .HtmlBody
AttachCount = .Attachments.Count
If AttachCount > 0 Then
ReDim AttachDtl(1 To 7, 1 To AttachCount)
For InxAttach = 1 To AttachCount
' There are four types of attachment:
' * olByValue 1
' * olByReference 4
' * olEmbeddedItem 5
' * olOLE 6
Select Case .Attachments(InxAttach).Type
Case olByValue
AttachDtl(1, InxAttach) = "Val"
Case olEmbeddeditem
AttachDtl(1, InxAttach) = "Ebd"
Case olByReference
AttachDtl(1, InxAttach) = "Ref"
Case olOLE
AttachDtl(1, InxAttach) = "OLE"
Case Else
AttachDtl(1, InxAttach) = "Unk"
End Select
' Not all types have all properties. This code handles
' those missing properties of which I am aware. However,
' I have never found an attachment of type Reference or OLE.
' Additional code may be required for them.
Select Case .Attachments(InxAttach).Type
Case olEmbeddeditem
AttachDtl(2, InxAttach) = ""
Case Else
AttachDtl(2, InxAttach) = .Attachments(InxAttach).PathName
End Select
AttachDtl(3, InxAttach) = .Attachments(InxAttach).FileName
AttachDtl(4, InxAttach) = .Attachments(InxAttach).DisplayName
AttachDtl(5, InxAttach) = "--"
' I suspect Attachment had a parent property in early versions
' of Outlook. It is missing from Outlook 2016.
On Error Resume Next
AttachDtl(5, InxAttach) = .Attachments(InxAttach).Parent
On Error GoTo 0
AttachDtl(6, InxAttach) = .Attachments(InxAttach).Position
' Class 5 is attachment. I have never seen an attachment with
' a different class and do not see the purpose of this property.
' The code will stop here if a different class is found.
Debug.Assert .Attachments(InxAttach).Class = 5
AttachDtl(7, InxAttach) = .Attachments(InxAttach).Class
Next
End If
InterestingItem = True
Else
InterestingItem = False
End If
End With
' The most used properties of the email have been loaded to variables but
' there are many more properies. Press F2. Scroll down classes until
' you find MailItem. Look through the members and note the name of
' any properties that look useful. Look them up using VB Help.
' #### You need to add code here to eliminate uninteresting items.
' #### For example:
'If SenderEmailAddress <> "[email protected]" Then
' InterestingItem = False
'End If
'If InStr(Subject, "Accounts payable") = 0 Then
' InterestingItem = False
'End If
'If AttachCount = 0 Then
' InterestingItem = False
'End If
' #### If the item is still thought to be interesting I
' #### suggest extracting the required data to variables here.
' #### You should consider moving processed emails to another
' #### folder. The emails are being processed in reverse order
' #### to allow this removal of an email from the Inbox without
' #### effecting the index numbers of unprocessed emails.
If InterestingItem Then
With ExcelWkBk
With .Worksheets("Inbox")
' #### This code creates a dividing row and then
' #### outputs a property per row. Again it demonstrates
' #### statements that are likely to be useful in the final
' #### version
' Create dividing row between emails
.Rows(RowCrnt).RowHeight = 5
.Range(.Cells(RowCrnt, "A"), .Cells(RowCrnt, "B")) _
.Interior.Color = RGB(0, 255, 0)
RowCrnt = RowCrnt + 1
.Cells(RowCrnt, "A").Value = "Sender name"
.Cells(RowCrnt, "B").Value = SenderName
RowCrnt = RowCrnt + 1
.Cells(RowCrnt, "A").Value = "Sender email address"
.Cells(RowCrnt, "B").Value = SenderEmailAddress
RowCrnt = RowCrnt + 1
.Cells(RowCrnt, "A").Value = "Received time"
With .Cells(RowCrnt, "B")
.NumberFormat = "@"
.Value = Format(ReceivedTime, "mmmm d, yyyy h:mm")
End With
RowCrnt = RowCrnt + 1
.Cells(RowCrnt, "A").Value = "Subject"
.Cells(RowCrnt, "B").Value = Subject
RowCrnt = RowCrnt + 1
If AttachCount > 0 Then
.Cells(RowCrnt, "A").Value = "Attachments"
.Cells(RowCrnt, "B").Value = "Inx|Type|Path name|File name|Display name|Parent|Position|Class"
RowCrnt = RowCrnt + 1
For InxAttach = 1 To AttachCount
.Cells(RowCrnt, "B").Value = InxAttach & "|" & _
AttachDtl(1, InxAttach) & "|" & _
AttachDtl(2, InxAttach) & "|" & _
AttachDtl(3, InxAttach) & "|" & _
AttachDtl(4, InxAttach) & "|" & _
AttachDtl(5, InxAttach) & "|" & _
AttachDtl(6, InxAttach) & "|" & _
AttachDtl(7, InxAttach)
RowCrnt = RowCrnt + 1
Next
End If
If TextBody <> "" Then
' ##### This code was in the original version of the macro
' ##### but I did not find it as useful as the other version of
' ##### the text body. See below
' This outputs the text body with CR, LF and TB obeyed
'With .Cells(RowCrnt, "A")
' .Value = "text body"
' .VerticalAlignment = xlTop
'End With
'With .Cells(RowCrnt, "B")
' ' The maximum size of a cell 32,767
' .Value = Mid(TextBody, 1, 32700)
' .WrapText = True
'End With
'RowCrnt = RowCrnt + 1
' This outputs the text body with NBSP, CR, LF and TB
' replaced by strings.
With .Cells(RowCrnt, "A")
.Value = "text body"
.VerticalAlignment = xlTop
End With
TextBody = Replace(TextBody, Chr(160), "[NBSP]")
TextBody = Replace(TextBody, vbCr, "[CR]")
TextBody = Replace(TextBody, vbLf, "[LF]")
TextBody = Replace(TextBody, vbTab, "[TB]")
With .Cells(RowCrnt, "B")
' The maximum size of a cell 32,767
.Value = Mid(TextBody, 1, 32700)
.WrapText = True
End With
RowCrnt = RowCrnt + 1
End If
If HtmlBody <> "" Then
' ##### This code was in the original version of the macro
' ##### but I did not find it as useful as the other version of
' ##### the html body. See below
' This outputs the html body with CR, LF and TB obeyed
'With .Cells(RowCrnt, "A")
' .Value = "Html body"
' .VerticalAlignment = xlTop
'End With
'With .Cells(RowCrnt, "B")
' .Value = Mid(HtmlBody, 1, 32700)
' .WrapText = True
'End With
'RowCrnt = RowCrnt + 1
' This outputs the html body with NBSP, CR, LF and TB
' replaced by strings.
With .Cells(RowCrnt, "A")
.Value = "Html body"
.VerticalAlignment = xlTop
End With
HtmlBody = Replace(HtmlBody, Chr(160), "[NBSP]")
HtmlBody = Replace(HtmlBody, vbCr, "[CR]")
HtmlBody = Replace(HtmlBody, vbLf, "[LF]")
HtmlBody = Replace(HtmlBody, vbTab, "[TB]")
With .Cells(RowCrnt, "B")
.Value = Mid(HtmlBody, 1, 32700)
.WrapText = True
End With
RowCrnt = RowCrnt + 1
End If
End With
End With
End If
Next
With xlApp
With ExcelWkBk
' Write new workbook to disc
If Right(PathName, 1) <> "\" Then
PathName = PathName & "\"
End If
.SaveAs FileName:=PathName & FileName
.Close
End With
.Quit ' Close our copy of Excel
End With
Set xlApp = Nothing ' Clear reference to Excel
End Sub
元の投稿には含まれていないが、上記のマクロの一部のユーザーが有用であることがわかっているマクロ
Public Sub FindSelectedFolder(ByRef FolderTgt As MAPIFolder, _
ByVal NameTgt As String, ByVal NameSep As String)
' This routine (and its sub-routine) locate a folder within the hierarchy and
' returns it as an object of type MAPIFolder
' NameTgt The name of the required folder in the format:
' FolderName1 NameSep FolderName2 [ NameSep FolderName3 ] ...
' If NameSep is "|", an example value is "Personal Folders|Inbox"
' FolderName1 must be an outer folder name such as
' "Personal Folders". The outer folder names are typically the names
' of PST files. FolderName2 must be the name of a folder within
' Folder1; in the example "Inbox". FolderName2 is compulsory. This
' routine cannot return a PST file; only a folder within a PST file.
' FolderName3, FolderName4 and so on are optional and allow a folder
' at any depth with the hierarchy to be specified.
' NameSep A character or string used to separate the folder names within
' NameTgt.
' FolderTgt On exit, the required folder. Set to Nothing if not found.
' This routine initialises the search and finds the top level folder.
' FindSelectedSubFolder() is used to find the target folder within the
' top level folder.
Dim InxFolderCrnt As Long
Dim NameChild As String
Dim NameCrnt As String
Dim Pos As Long
Dim TopLvlFolderList As Folders
Set FolderTgt = Nothing ' Target folder not found
Set TopLvlFolderList = _
CreateObject("Outlook.Application").GetNamespace("MAPI").Folders
' Split NameTgt into the name of folder at current level
' and the name of its children
Pos = InStr(NameTgt, NameSep)
If Pos = 0 Then
' I need at least a level 2 name
Exit Sub
End If
NameCrnt = Mid(NameTgt, 1, Pos - 1)
NameChild = Mid(NameTgt, Pos + 1)
' Look for current name. Drop through and return nothing if name not found.
For InxFolderCrnt = 1 To TopLvlFolderList.Count
If NameCrnt = TopLvlFolderList(InxFolderCrnt).Name Then
' Have found current name. Call FindSelectedSubFolder() to
' look for its children
Call FindSelectedSubFolder(TopLvlFolderList.Item(InxFolderCrnt), _
FolderTgt, NameChild, NameSep)
Exit For
End If
Next
End Sub
Public Sub FindSelectedSubFolder(FolderCrnt As MAPIFolder, _
ByRef FolderTgt As MAPIFolder, _
ByVal NameTgt As String, ByVal NameSep As String)
' See FindSelectedFolder() for an introduction to the purpose of this routine.
' This routine finds all folders below the top level
' FolderCrnt The folder to be seached for the target folder.
' NameTgt The NameTgt passed to FindSelectedFolder will be of the form:
' A|B|C|D|E
' A is the name of outer folder which represents a PST file.
' FindSelectedFolder() removes "A|" from NameTgt and calls this
' routine with FolderCrnt set to folder A to search for B.
' When this routine finds B, it calls itself with FolderCrnt set to
' folder B to search for C. Calls are nested to whatever depth are
' necessary.
' NameSep As for FindSelectedSubFolder
' FolderTgt As for FindSelectedSubFolder
Dim InxFolderCrnt As Long
Dim NameChild As String
Dim NameCrnt As String
Dim Pos As Long
' Split NameTgt into the name of folder at current level
' and the name of its children
Pos = InStr(NameTgt, NameSep)
If Pos = 0 Then
NameCrnt = NameTgt
NameChild = ""
Else
NameCrnt = Mid(NameTgt, 1, Pos - 1)
NameChild = Mid(NameTgt, Pos + 1)
End If
' Look for current name. Drop through and return nothing if name not found.
For InxFolderCrnt = 1 To FolderCrnt.Folders.Count
If NameCrnt = FolderCrnt.Folders(InxFolderCrnt).Name Then
' Have found current name.
If NameChild = "" Then
' Have found target folder
Set FolderTgt = FolderCrnt.Folders(InxFolderCrnt)
Else
'Recurse to look for children
Call FindSelectedSubFolder(FolderCrnt.Folders(InxFolderCrnt), _
FolderTgt, NameChild, NameSep)
End If
Exit For
End If
Next
' If NameCrnt not found, FolderTgt will be returned unchanged. Since it is
' initialised to Nothing at the beginning, that will be the returned value.
End Sub