通过VBA发送电子邮件

试图通过Outlook发送电子邮件，但它不保存excel文件，所以它不能做附件。 我的代码也不能popupOutlook窗口。 之前正在工作，但由于networking驱动器，它不再工作。

Sub Backup_required() 'coded by Atul , Vij Dim OutlookApp, MItem As Object Dim cell As Range Dim Subj As String Dim EmailAddr As String Dim Recipient As String Dim Msg As String Dim ws As Worksheet, ws2 As Worksheet, ws3 As Worksheet Dim wb As Workbook, wb2 As Workbook Dim main_book As String Dim newWorkbook As String Application.DisplayAlerts = False 'create outblook object Set OutlookApp = CreateObject("Outlook.Application") Application.ScreenUpdating = False 'defines the user name user = Environ("username") main_book = ActiveWorkbook.Name Set wb = Workbooks(main_book) 'email subject Subj = "Blackline Reconciliation - Backup Required!" 'coded by Atul , Vij Call pathDefinition 'operation for all sheets in BS_Download template with comments For Each g In Workbooks(main_book).Worksheets Set ws = wb.Worksheets(g.Name) If g.Name <> "Sap Data" And g.Name <> "Automated BL Import" Then lastRow = ws.Range("B" & Rows.Count).End(xlUp).Row 'select every cells in all sheets in BS_Download template with comments For Each a In ws.Range("W2:W" & lastRow) If Left(a, 1) <> "*" And a.Value <> 0 And a.Offset(0, 1).Value = 0 Then B = a.Row f = a.Value 'add new book where the cell with met conditions are copied Workbooks.Add newWorkbook = ActiveWorkbook.Name Workbooks(newWorkbook).Worksheets(1).Range("A1:AA1").Value = ws.Range("A1:AA1").Value Set wb2 = Workbooks(newWorkbook) Set ws3 = wb2.Worksheets(1) 'select all cells in all sheets in BS_Download template with comments For Each d In Workbooks(main_book).Worksheets If d.Name <> "Sap Data" And d.Name <> "Automated BL Import" Then Set ws2 = wb.Worksheets(d.Name) 'compare if condition is met in all cells in all sheets in BS_Download template with comments lastRow2 = ws2.Range("B" & Rows.Count).End(xlUp).Row For Each e In ws2.Range("W2:W" & lastRow2) C = e.Row If e.Value = f And Left(e, 1) <> "*" And e.Offset(0, 1) = 0 Then lastRow3 = ws3.Range("B" & Rows.Count).End(xlUp).Row + 1 ws3.Range("A" & lastRow3, "AA" & lastRow3).Value = ws2.Range("A" & C, "AA" & C).Value e.Value = "*" & e.Value If Left(a, 1) <> "*" Then a.Value = "*" & a.Value End If End If Next e End If 'coded by Atul , Vij Next d ws3.Range("A1:AA1").Interior.Color = RGB(51, 102, 255) ws3.Columns("A:AA").EntireColumn.AutoFit 'finally save the new opened workbook with name of compared a cell wb2.SaveAs FileName:="D:\" & f & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False wb2.Close EmailAddr = f 'open new email Set MItem = OutlookApp.CreateItem(olMailItem) Set myAttachments = MItem.Attachments With MItem .To = EmailAddr .Subject = Subj .Display End With 'paste the attachment of new workbooks save on user desktop myAttachments.Add "D:\" & f & ".xlsx" End If Next a End If Next g 'erase the first left "*" in all the cell in T column For Each a In Workbooks(main_book).Worksheets Set ws = wb.Worksheets(a.Name) If a.Name <> "Sap Data" And a.Name <> "Automated BL Import" Then lastRow = ws.Range("B" & Rows.Count).End(xlUp).Row For Each B In ws.Range("W2:W" & lastRow) If Left(B, 1) = "*" Then B.Value = Right(B, (Len(B.Value) - 1)) End If Next B End If Next a Application.DisplayAlerts = True End Sub 

Answer 1

问题是在这一行（不知道可能是出了一份工作手册）：

 If Left(A, 1) <> "*" And A.Value <> 0 And A.Offset(0, 1).Value = 0 Then 

将该行更改为：

 If True Then 

然后改变：

 f = A.Value 

至：

 f = "newbook" 

产生以下电子邮件被popup发送：

所以，你的实际的电子邮件逻辑没有问题，只是你的工作簿parsing逻辑。

每更新评论

要自动发送消息更改：

 Set myAttachments = MItem.Attachments With MItem .To = EmailAddr .Subject = Subj .Display End With 'paste the attachment of new workbooks save on user desktop myAttachments.Add "D:\" & f & ".xlsx" 

至：

 Set myAttachments = MItem.Attachments myAttachments.Add "D:\" & f & ".xlsx" With MItem .TO = EmailAddr .Subject = Subj .Display .Send End With 

Answer 2

我觉得像这样的工作，如果你说MIem.send选项

 If GetOutlook = True Then Set mItem = mOutlookApp.CreateItem(olMailItem) mItem.Recipients.Add strRecip mItem.Subject = strSubject mItem.Body = strMsg ' This code allows for 1 attachment, but with slight ' modification, you could provide for multiple files. If Len(strAttachment) > 0 Then mItem.Attachments.Add strAttachment End If mItem.Save mItem.Send End If