Sending Email through VBA - vba

Question

Trying to send email through outlook but it is not saving the excel file and so it's not able to do attachment. Also my code is not able to pop up outlook window. It was working before but due to network drive it no longer works.
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

The problem is on this line (don't know what it could be with out a copy of the workbook):
If Left(A, 1) <> "*" And A.Value <> 0 And A.Offset(0, 1).Value = 0 Then
Changing that line to:
If True Then
And then changing:
f = A.Value
To:
f = "newbook"
Yields the following email being popped up for sending:
So there is no problem with your actual e-mail logic, just your workbook parsing logic.
Per updated comments
To automatically send the message change:
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"
to:
Set myAttachments = MItem.Attachments
myAttachments.Add "D:\" & f & ".xlsx"
With MItem
.TO = EmailAddr
.Subject = Subj
.Display
.Send
End With

Answer 2

I think something like this work if you say MIem.send option
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