Question

我正在尝试通过CDO和gmail将活动工作表发送给在发送过程中输入某些文本框的所有人。我使用以下代码：

Sub CommandButton1_Click()

'Working in Excel 2000-2013
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm

Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim ProjectName As String
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim Flds As Variant
Dim recipientsArray(1 To 10) As String
Dim i As Long
Dim qScore As String

recipientsArray(1) = TextBox1.Value
recipientsArray(2) = TextBox2.Value
recipientsArray(3) = TextBox3.Value
recipientsArray(4) = TextBox4.Value
recipientsArray(5) = TextBox5.Value
recipientsArray(6) = TextBox6.Value
recipientsArray(7) = TextBox7.Value
recipientsArray(8) = TextBox8.Value
recipientsArray(9) = TextBox11.Value
recipientsArray(10) = TextBox10.Value

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

Set Sourcewb = ThisWorkbook

'Copy the ActiveSheet to a new workbook
ThisWorkbook.ActiveSheet.Copy
Set Destwb = ActiveWorkbook

'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-2013
        Select Case Sourcewb.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
End With

'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
If Sourcewb.Worksheets("Final Review Feedback").Range("B4").Value = "" Then
    TempFileName = "No project name"
Else
    TempFileName = Sourcewb.Worksheets("Final Review Feedback").Range("B2").Value & " " & Sourcewb.Worksheets("Final Review Feedback").Range("D4").Value
End If

If Sourcewb.Worksheets("Extraction").Range("C1").Value = "" Then
    ProjectName = "N/A"
Else
    ProjectName = Sourcewb.Worksheets("Extraction").Range("C1").Value
End If

If Sourcewb.Worksheets("Final Review Feedback").Range("D4").Value = 0 Then
    qScore = "QScore: N/A"
Else
    qScore = "QScore: " & Sourcewb.Worksheets("Final Review Feedback").Range("D4").Value
End If

Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1    ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "mlsfinalreview@gmail.com"
    .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "*******************"
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
    .Update
End With

With Destwb
    .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
    On Error Resume Next
    For i = LBound(recipientsArray) To UBound(recipientsArray)
        If Not recipientsArray(i) = "" Then
            Set iMsg = CreateObject("CDO.Message")
            With iMsg
                Set .Configuration = iConf
                .To = recipientsArray(i)
                .CC = ""
                .BCC = ""
                .Subject = "Final Review Feedback: " & ProjectName & " " & qScore
                .TextBody = "Dear All," & Chr(10) & Chr(10) & "attached you will find the Final Review Feedback for " & ProjectName & "." _
                    & Chr(10) & Chr(10) & "Yours sincerely," & Chr(10) & Environ("Username")
                .from = """Final Review"" <mlsfinalreview@gmail.com>"
                .ReplyTo = "hr@marketlogicsoftware.com"
                .AddAttachment (TempFilePath & TempFileName & FileExtStr)
                .Send
            End With
        End If
    Next i
    On Error GoTo 0
    .Close SaveChanges:=False
End With

'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr

Set iMsg = Nothing
Set iConf = Nothing

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

Me.Hide

Sheet9.Range("N2").Value = "Awaiting Upload"

End Sub

除附件外，一切正常（文字，收件人，主题等）。它们不包含在电子邮件中。作为代码，我尝试了.Attachments.Add和.AddAttachments。两者都有相同的结果。

我仔细检查了文件名是否正确，似乎没问题。有谁知道我为什么发送空电子邮件？我尝试发送活动工作簿（在打开并激活时）会出现问题吗？

Answer 1

这是我过去做过的事情：复制活动工作表，然后通过outlook发送。

Sub SendQuoteForm()
Dim Send As Integer
Dim oApp As Object
Dim oMail As Object
Dim LWorkbook As Workbook
Dim LFileName As String

Send = MsgBox("Please be sure that you are logged into Microsoft Outlook before sending your finsihed quote. Would you like to continue?", vbYesNo, "Send Finished Quote?")
'I'm not sure if the whole gmail thing will work here, but it's a start
If Send = vbYes Then
    Application.ScreenUpdating = False
    ActiveSheet.Copy

    Set LWorkbook = ActiveWorkbook
    LFileName = LWorkbook.Worksheets(1).Name
    On Error Resume Next
        Kill LFileName
    On Error GoTo 0
        LWorkbook.SaveAs Filename:=LFileName

    Set oApp = CreateObject("Outlook.Application")
    Set oMail = oApp.CreateItem(0)

    With oMail
        .To = "someone@something.com"
        .Subject = "Subject"
        .body = "blah blah blah"
        .Attachments.Add LWorkbook.FullName
        .Display
    End With

    LWorkbook.ChangeFileAccess Mode:=xlReadOnly
    Kill LWorkbook.FullName
    LWorkbook.Close SaveChanges:=False

    Application.ScreenUpdating = True
    Set oMail = Nothing
    Set oApp = Nothing
Else
    Exit Sub
End If

End Sub

Answer 2

修正以下行

 .AddAttachment "C:\Temp\Filename.xlsx"

或尝试

 .AddAttachment TempFilePath & "\" & TempFileName & FileExtStr

Answer 3

解决方案是摆脱With Destwb和End with。

我删除了它们并添加了两行代码：

Destwb.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
Destwb.Close SaveChanges:=True

其次是发送代码。它现在有效！

未在Excel / VBA中使用Gmail和CDO发送附件

3 个答案: