Sending Email through 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

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

Answer 2

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