目前，下面列出的代码将从传入的电子邮件中复制正文信息并打开指定的Excel工作表并将内容复制到Excel工作表并关闭它 . 我还想将传入电子邮件中的附件保存到此指定路径：C：\ Users \ ltorres \ Desktop \ Projects

我试过这个，但是这个代码不会与outlook结合 . 我必须用excel运行它

Public Sub saveAttachtoDisk (itm As Outlook.MailItem)

Dim objAtt As Outlook.Attachment

Dim saveFolder As String

Dim dateFormat As String

saveFolder = "C:\Users\ltorres\Desktop\Projects"

dateFormat = Format(Now, "yyyy-mm-dd H-mm")

For Each objAtt In itm.Attachments

objAtt.SaveAsFile saveFolder & "\" & dateFormat & objAtt.DisplayName

Set objAtt = Nothing

Next

End Sub

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:\Users\ltorres\Desktop\Projects\Project 2\TemplateFinal\lighting.xlsm")

'~~> Set the relevant output sheet. Change as applicable

Set oXLws = oXLwb.Sheets("Multiplier")

lRow = oXLws.Range("A" & oXLws.Rows.Count).End(xlUp).Row + 1

'~~> Write to outlook

With oXLws

lRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1

Dim MyAr() As String

MyAr = Split(olMail.Body, vbCrLf)

For i = LBound(MyAr) To UBound(MyAr)

.Range("A" & lRow).Value = MyAr(i)

lRow = lRow + 1

Next i

'

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