Question

尝试通过Outlook发送电子邮件，但它没有保存excel文件，因此无法执行附件。我的代码也无法弹出Outlook窗口。它以前工作但是由于网络驱动它不再有效。

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"

弹出以下电子邮件以便发送：

因此，您的实际电子邮件逻辑没有问题，只是您的工作簿解析逻辑。

每次更新评论

自动发送消息更改：

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

通过VBA发送电子邮件

2 个答案: