VBAコードは、電子メールを検索し、Excel

Question

私は特定の件名のメールのための私の見通しからの受信トレイのいずれかを並べ替えると、（その表）メールの本文をコピーするコードを記述しようとしていますに体をコピーしますエクセルに入る。これは私がこれまで持っていたものです。コードを動作させることができず、検索する受信トレイを指定する方法がわからない助けをよろしく！

Sub CopyEmail() 

    Dim olApp As Outlook.Application 
    Dim olNs As Outlook.Namespace 
    Dim olFldr As Outlook.MAPIFolder 
    Dim olItms As Outlook.Items 
    Dim olMail As Variant 

    Set olApp = New Outlook.Application 
    Set olNs = olApp.GetNamespace(”MAPI”) 'get a runtime error here 
    Set olFldr = olNs.GetDefaultFolder(olFolderInbox) 
    Set olItms = olFldr.Items 

    Dim NLXemail As String 
    NLXemail = "Patient Receipts" 

    olItms.Sort NLXemail 

     If InStr(1, olMail.Subject, NLXemail, vbTextCompare) > 0 Then 
      ThisWorkbook.Sheets("Sheet1").Cells(3, 1).Value = outMail.Body 

     End If 

    Set olFldr = Nothing 
    Set olNs = Nothing 
    Set olApp = Nothing 

End Sub 

Answer 1

これは、本体をExcelにコピーします。

Option Explicit 
'This Code is Downloaded from OfficeTricks.com 
'Visit this site for more such Free Code 
Sub Export_Outlook_Emails_To_Excel() 
    'Add Tools->References->"Microsoft Outlook nn.n Object Library" 
    'nn.n varies as per our Outlook Installation 
    Dim Folder As Outlook.MAPIFolder 
    Dim sFolders As Outlook.MAPIFolder 
    Dim iRow As Integer, oRow As Integer 
    Dim MailBoxName As String, Pst_Folder_Name As String 

    'Mailbox or PST Main Folder Name (As how it is displayed in your Outlook Session) 
    MailBoxName = "MailBox Name" 

    'Mailbox Folder or PST Folder Name (As how it is displayed in your Outlook Session) 
    Pst_Folder_Name = "Folder Name" 'Sample "Inbox" or "Sent Items" 

    'To directly a Folder at a high level 
    'Set Folder = Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name) 

    'To access a main folder or a subfolder (level-1) 
    For Each Folder In Outlook.Session.Folders(MailBoxName).Folders 
     If VBA.UCase(Folder.Name) = VBA.UCase(Pst_Folder_Name) Then GoTo Label_Folder_Found 
     For Each sFolders In Folder.Folders 
      If VBA.UCase(sFolders.Name) = VBA.UCase(Pst_Folder_Name) Then 
       Set Folder = sFolders 
       GoTo Label_Folder_Found 
      End If 
     Next sFolders 
    Next Folder 

Label_Folder_Found: 
    If Folder.Name = "" Then 
     MsgBox "Invalid Data in Input" 
     GoTo End_Lbl1: 
    End If 

    'Read Through each Mail and export the details to Excel for Email Archival 
    ThisWorkbook.Sheets(1).Activate 
    Folder.Items.Sort "Received" 

    'Insert Column Headers 
    ThisWorkbook.Sheets(1).Cells(1, 1) = "Sender" 
    ThisWorkbook.Sheets(1).Cells(1, 2) = "Subject" 
    ThisWorkbook.Sheets(1).Cells(1, 3) = "Date" 
    ThisWorkbook.Sheets(1).Cells(1, 4) = "Size" 
    ThisWorkbook.Sheets(1).Cells(1, 5) = "EmailID" 
    'ThisWorkbook.Sheets(1).Cells(1, 6) = "Body" 

    'Export eMail Data from PST Folder 
    oRow = 1 
    For iRow = 1 To Folder.Items.Count 
     'If condition to import mails received in last 60 days 
     'To import all emails, comment or remove this IF condition 
     If VBA.DateValue(VBA.Now) - VBA.DateValue(Folder.Items.Item(iRow).ReceivedTime) <= 60 Then 
      oRow = oRow + 1 
      ThisWorkbook.Sheets(1).Cells(oRow, 1).Select 
      ThisWorkbook.Sheets(1).Cells(oRow, 1) = Folder.Items.Item(iRow).SenderName 
      ThisWorkbook.Sheets(1).Cells(oRow, 2) = Folder.Items.Item(iRow).Subject 
      ThisWorkbook.Sheets(1).Cells(oRow, 3) = Folder.Items.Item(iRow).ReceivedTime 
      ThisWorkbook.Sheets(1).Cells(oRow, 4) = Folder.Items.Item(iRow).Size 
      ThisWorkbook.Sheets(1).Cells(oRow, 5) = Folder.Items.Item(iRow).SenderEmailAddress 
      'ThisWorkbook.Sheets(1).Cells(oRow, 6) = Folder.Items.Item(iRow).Body 
     End If 
    Next iRow 
    MsgBox "Outlook Mails Extracted to Excel" 
    Set Folder = Nothing 
    Set sFolders = Nothing 

End_Lbl1: 
End Sub 

詳細については、以下のリンクを参照してください。

http://officetricks.com/outlook-email-download-to-excel/

Answer 2

それがわかりました。以下のスクリプトは、特定のOutlookメールボックス内の特定の電子メールを検索し、電子メールの本文から内容（表）をExcelにコピーします。

Sub Copyemailbody_refresh() 

Dim Folder As Outlook.MAPIFolder 
Dim sFolders As Outlook.MAPIFolder 
Dim MailBoxName As String, Pst_Folder_Name As String 
Dim oMail As Outlook.MailItem 
Dim y As Long, x As Long 
Dim olInsp As Outlook.Inspector 
Dim wdDoc As Word.Document 
Dim tb As Word.Table 
Dim Myemail As String 
Dim Atmt As Attachment 
Dim irow As Integer 
irow = 1 
'set email date 
Dim Emaildate As String 
Emaildate = Sheets("Refresh").Range("G12").Value 
'set email subject 
Myemail = "Today's receipts " & Emaildate” 
'Mailbox or PST Main Folder Name to set the name of the inbox - I have several mailboxes, needed to specify 
MailBoxName = "Mymailbox1" 

'Mailbox Folder or PST Folder Name (As how it is displayed in your Outlook Session) 
Pst_Folder_Name = "Inbox" 'Sample "Inbox" or "Sent Items" 

'To direct to a Folder at a high level 
Set Folder = Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name) 

'copying the email contents into the refresh file 
For Each oMail In Folder.Items 
If oMail.Subject = Myemail Then 
    With oMail 
    Set olInsp = .GetInspector 
    Set wdDoc = olInsp.WordEditor 

    For Each tb In wdDoc.Tables 'assumes only 1 table in the body of the email 

For y = 1 To tb.Rows.Count 
For x = 1 To tb.Columns.Count 

Sheets("Refresh").Select 
Range("A1").Select 
Selection.Offset(y, x).Value = tb.Cell(y, x).Range 

    Next 

    Next 

Next 

    End With 

End If 

Next 

'since the table was pasted as a word object, needed to convert text to numbers to perform calc on the table– not sure of a quicker way to do this than Text to columns 

Sheets("Refresh").Select 
Columns("B:B").Select 
Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited 
Columns("C:C").Select 
Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited 
Columns("D:D").Select 
Selection.TextToColumns Destination:=Range("D1"), DataType:=xlDelimited 
Columns("E:E").Select 
Selection.TextToColumns Destination:=Range("E1"), DataType:=xlDelimited 
End Sub