Question

无法调试下面的代码。

我尝试自动化宏以根据命名范围发送多个附件。

Sub Test()

 Dim objol As New Outlook.Application, objMail As MailItem
 Dim MyArr As Variant, i As Long

 Set objol = New Outlook.Application
 Set objMail = objol.CreateItem(olMailItem)

 With objMail
 MyArr = Sheets("Sheet1").Range("A2:A9").Value
 .To = ("test@test.com")
 .Subject = "Test"
 .Body = ""
 .NoAging = True
 For i = LBound(MyArr) To UBound(MyArr)
 If Dir(MyArr(i, 1), vbNormal) <> "" Then .Attachments.Add MyArr(i, 1)
 Next i
 .Display
 End With

 End Sub

在我测试的示例中，我只在该范围内有两个输入（＆＃34; Sheet2＆＃34;和＆＃34; Sheet3＆＃34;分别在单元格A2和amp; A3中）。似乎代码在i=3处起作用，其中行是空白的。但我需要那个没问题。当它所引用的列被设置（A2：A9）时，用户输入他们想要在工作簿中找到的电子邮件的工作表的名称。有时，用户可以输入2个名称或3个名称 - 任何金额最多为A9。如果范围内有空白，我只需要代码来结束循环，并发送已在该范围内定义的附件。

截至目前，它一直给我一个类型不匹配的错误？（类型不匹配发生在If Dir(MyArr(i, 1), vbNormal) <> "" Then .Attachments.Add MyArr(i, 1)

编辑 - 由于Dir也可能是一个问题 - 范围内的值是工作表名称，因此Sheet1，Sheet2

Answer 1

这就是你想要的

Sub Mail_ActiveSheet()
    Dim OutApp As Object
    Dim OutMail As Object

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Dim Sourcewb As Workbook
    Set Sourcewb = ActiveWorkbook

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        .To = "test@test.com"
        .CC = ""
        .BCC = ""
        .Subject = "Test"
        .Body = "Body"

        AddAttachments ActiveWorkbook, OutMail

        .Display
    End With


    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

以下子程序将从A2循环到A9，然后调用SheetExists()以查看单元格值是否与现有工作表名称匹配。如果是，则将工作表复制到新工作簿中，将其作为文件保存在临时文件夹中，将其附加到电子邮件中，然后删除该文件。

Sub AddAttachments(wb As Workbook, mail As Object)
    'Copy sheets
    For i = 2 To 9
        Dim sheetName As String
        sheetName = wb.Sheets("Sheet1").Range("A" & i).Value

        If SheetExists(sheetName, wb) = True Then
            wb.Sheets(sheetName).Copy

            Dim Destwb As Workbook
            Set Destwb = ActiveWorkbook

            Dim FileExtStr As String
            Dim FileFormatNum As Long

            'Determine the Excel version and file extension/format
            With Destwb
                If Val(Application.Version) < 12 Then
                    'You use Excel 97-2003
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    'You use Excel 2007-2016
                    Select Case wb.FileFormat
                        Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                        Case 52:
                            If .HasVBProject Then
                                FileExtStr = ".xlsm": FileFormatNum = 52
                            Else
                                FileExtStr = ".xlsx": FileFormatNum = 51
                            End If
                        Case 56: FileExtStr = ".xls": FileFormatNum = 56
                        Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                    End Select
                End If

                'Save the new workbook/Mail it/Delete it
                Dim TempFilePath As String
                Dim TempFileName As String

                TempFilePath = Environ$("temp") & "\"
                TempFileName = wb.Name & " " & sheetName & " " & Format(Now, "yymmdd h-mm-ss")

                .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum

                .Close savechanges:=False

                mail.Attachments.Add TempFilePath & TempFileName & FileExtStr

                'Delete the file you have send
                Kill TempFilePath & TempFileName & FileExtStr
            End With
        End If
    Next i
End Sub


 Function SheetExists(shtName As String, Optional wb As Workbook) As Boolean
    Dim sht As Worksheet

     If wb Is Nothing Then Set wb = ThisWorkbook
     On Error Resume Next
     Set sht = wb.Sheets(shtName)
     On Error GoTo 0
     SheetExists = Not sht Is Nothing
 End Function

这是一个快速的解决方案。注意我没有检查错误，即我没有检查文件是否已创建，或者我没有检查同一张纸是否被多次列出，这可能会给你带来不良后果。

额外的努力取决于你

根据命名范围通过电子邮件发送多个附件

1 个答案: