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

我試圖通過CDO和gmail將活動工作表發送給在發送它們的過程中在某些文本框中輸入的所有人。我使用以下代碼：未在Excel/VBA中使用Gmail和CDO發送的附件

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") = "[email protected]" 
    .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"" <[email protected]>" 
       .ReplyTo = "[email protected]" 
       .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。兩者都有相同的結果。

我仔細檢查文件名是否正確，看起來好。有沒有人有一個想法，爲什麼我發送空的電子郵件？我嘗試發送活動工作簿（打開並激活它）時會發生問題嗎？

來源

2015-06-05 Moritz Schmitz v. Hülst

我會假設沒有附件。我看到你有一個外部的「與Destwb」，你附加到郵件「Destwb.fullname」。不幸的是，人們無法看到Destwb是什麼類型，但這就像你發送了一些廢話。我的建議是：不要使用「with」，寫出長表格，然後你得到一個錯誤信息 –

'Dim Destwb As Workbook'。將其更改爲您的建議 - 儘管如此，沒有錯誤消息， –

對於協議：我的代碼確實創建了文件，並且據我所知，它有正確的名稱和路徑。它只是沒有附加到郵件。或者它被Google阻止。 –

解決辦法是擺脫With Destwb和End with的。

我刪除它們並添加兩行而不是：

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

其次是發送代碼。它現在有效！

來源

2015-06-17 11:53:34

以下是我過去所做的事情：複製活動工作表，然後通過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 = "[email protected]" 
     .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

來源

2015-06-05 15:32:13 FruitUser

我很樂意這樣做，但我無法使用Outlook。該文件可能在沒有Outlook的PC上使用（至少未設置）。 –

我發現這段視頻：https://www.youtube.com/watch?v=pFl7W8d7d4M – FruitUser

修復以下行

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

，或者嘗試

.AddAttachment TempFilePath & "\" & TempFileName & FileExtStr

來源

2015-06-05 16:26:36 0m3r

正如我寫的，我用這兩個符號。爲什麼這會改變什麼？ –

@MoritzSchmitzv.Hülst嘗試添加文件的完整路徑。 – 0m3r

但是，它不是通用的了。我在我的問題中添加了更多代碼。 –

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

回答

相關問題