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

我试图通过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

子命令按钮1\u单击（）
“使用Excel 2000-2013
“有关提示，请参阅：http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim FileExtStr作为字符串
Dim FileFormatNum尽可能长
将Sourcewb设置为工作簿
将项目名称设置为字符串
将WB设置为工作簿
Dim TempFilePath作为字符串
将文件名设置为字符串
作为对象的Dim iMsg
作为对象的Dim-iConf
像弦一样暗的链子
作为变型的Dim FLD
调暗接收器光线（1到10）为字符串
我想我会坚持多久
作为字符串的核心
recipientsArray（1）=TextBox1.值
recipientsArray（2）=TextBox2.值
recipientsArray（3）=TextBox3.值
recipientsArray（4）=TextBox4.值
recipientsArray（5）=文本框5.值
recipientsArray（6）=TextBox6.值
recipientsArray（7）=TextBox7.值
recipientsArray（8）=TextBox8.值
recipientsArray（9）=文本框11.值
recipientsArray（10）=TextBox10.值
应用
.ScreenUpdate=False
.EnableEvents=False
以
设置Sourcewb=ThisWorkbook
'将活动工作表复制到新工作簿
ThisWorkbook.ActiveSheet.Copy
设置Destwb=ActiveWorkbook
'确定Excel版本和文件扩展名/格式
用Destwb
如果Val（Application.Version）<12，则
“您使用的是Excel 97-2003
FileExtStr=“.xls”：FileFormatNum=-4143
其他的
“您使用的是Excel 2007-2013
选择Case Sourcewb.FileFormat
案例51:FileExtStr=“.xlsx”：FileFormatNum=51
案例52：
如果.hasvb项目
FileExtStr=“.xlsm”：FileFormatNum=52
其他的
FileExtStr=“.xlsx”：FileFormatNum=51
如果结束
案例56:FileExtStr=“.xls”：FileFormatNum=56
其他情况：FileExtStr=“.xlsb”：FileFormatNum=50
结束选择
如果结束
以
'保存新工作簿/发送/删除它
TempFilePath=Environ$（“temp”）和“\”
如果Sourcewb.工作表（“最终审查反馈”）.范围（“B4”）.值=“那么
TempFileName=“无项目名称”
其他的
TempFileName=Sourcewb.Worksheets（“最终审查反馈”）.Range（“B2”）.Value&&Sourcewb.Worksheets（“最终审查反馈”）.Range（“D4”）.Value
如果结束
如果Sourcewb.工作表（“提取”）.Range（“C1”）.Value=”“，则
ProjectName=“不适用”
其他的
ProjectName=Sourcewb.Worksheets（“提取”）.Range（“C1”）.Value
如果结束
如果Sourcewb.工作表（“最终审查反馈”）.Range（“D4”）.Value=0，则
qScore=“qScore:不适用”
其他的
qScore=“qScore:&Sourcewb.工作表（“最终审查反馈”）.范围（“D4”）.值
如果结束
设置iConf=CreateObject（“CDO.Configuration”）
加载-1'CDO源默认值
设置Flds=iConf.Fields
使用FLD
.项目（”http://schemas.microsoft.com/cdo/configuration/smtpusessl“”=真
.项目（”http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.项目（”http://schemas.microsoft.com/cdo/configuration/sendusername") = "mlsfinalreview@gmail.com"
.项目（”http://schemas.microsoft.com/cdo/configuration/sendpassword") = "*******************"
.项目（”http://schemas.microsoft.com/cdo/configuration/smtpserver“”=“smtp.gmail.com”
.项目（”http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.项目（”http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.更新
以
用Destwb
.SaveAs TempFilePath&TempFileName&FileExtStr，FileFormat:=FileFormatNum
出错时继续下一步
对于i=LBound（recipientsArray）到UBound（recipientsArray）
如果不是接受者，那么
设置iMsg=CreateObject（“CDO.Message”）
与iMsg
Set.Configuration=iConf
.To=接收者（i）
.CC=“”
.BCC=“”
.Subject=“最终审查反馈：”&ProjectName&“&qScore
.TextBody=“亲爱的所有人，&Chr（10）&Chr（10）&”随信附上“&ProjectName&”的最终评审反馈_
&Chr（10）和Chr（10）以及“您诚挚的”，以及Chr（10）和环境（“用户名”）
.from=“”最终审查“”
.ReplyTo=”hr@marketlogicsoftware.com"
.AddAttachment（TempFilePath&TempFileName&FileExtStr）
.发送
以
如果结束
接下来我
错误转到0
.Close SaveChanges:=False
以
'删除已发送的文件
终止TempFilePath&TempFileName&FileExtStr
设置iMsg=无
设置iConf=Nothing
应用
.ScreenUpdate=True
.EnableEvents=True
以
我，藏起来
表9.范围（“N2”）.Value=“等待上传”
端接头

除附件外，所有内容（文本、收件人、主题等）都正常工作。电子邮件中不包含这些内容。作为代码，我尝试了

.Attachments.Add

和

.AddAttachments

。两者的结果相同

---

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

我过去做过一些事情：复制活动工作表，然后通过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

修正下面的行

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

或尝试

 .AddAttachment TempFilePath & "\" & TempFileName & FileExtStr

---

解决方案是用Destwb去除

，用
结束

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

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

然后是发送代码。现在可以了
 我很想这样做，但我不能使用Outlook。该文件可能在没有Outlook的PC上使用（至少没有设置）。我假设没有附件。我看到您有一个外部“with Destwb”，并将其附加到邮件“Destwb.fullname”。不幸的是，我们看不到Destwb是什么类型的，但这就像你发送了一些废话。我的建议是：不要使用“with”，编写长的表单，然后您可能会收到一条错误消息
Dim Destwb As