Question

我在这里略微修改了代码 - https://www.extendoffice.com/documents/excel/3560-excel-send-personalized-email.html

如果缺陷文本单元格中的文本很长，则会自动截断。（This is what my worksheet looks like）

不确定这是根本原因，但我尝试将应用程序时间值增加到0.20，但除了花费更长时间发送电子邮件之外没有做任何事情。它在同一点被截断了。

我是新手，试图学习VBA并需要今天完成这项工作。非常感谢任何帮助。

#If VBA7 And Win64 Then
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
                     ByVal hwnd As LongPtr, ByVal lpOperation As String, _
                     ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
                     ByVal nShowCmd As Long) As LongPtr
#Else
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
                     ByVal hwnd As Long, ByVal lpOperation As String, _
                     ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
                     ByVal nShowCmd As Long) As Long
#End If
Sub SendEMail()

Dim xEmail As String
Dim xSubj As String
Dim xMsg As String
Dim xURL As String
Dim i As Integer
Dim k As Double
Dim xCell As Range
Dim xRg As Range
Dim xTxt As String
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select the data range:", "navneesi", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub

For i = 1 To xRg.Rows.Count
'       Get the email address
    xEmail = xRg.Cells(i, 1)
'       Message subject
    xSubj = "Validation Assignment"
'       Compose the message
    xMsg = ""
    xMsg = xMsg & "Validation Assignment: " & vbCrLf & vbCrLf
    xMsg = xMsg & " Order ID: " & xRg.Cells(i, 2).Text & vbCrLf
    xMsg = xMsg & " Marketplace ID: " & xRg.Cells(i, 3).Text & vbCrLf
    xMsg = xMsg & " Order Day: " & xRg.Cells(i, 4).Text & vbCrLf
    xMsg = xMsg & " Seller ID: " & xRg.Cells(i, 5).Text & vbCrLf
    xMsg = xMsg & " Product Code: " & xRg.Cells(i, 6).Text & vbCrLf
    xMsg = xMsg & " Item Name: " & xRg.Cells(i, 7).Text & vbCrLf
    xMsg = xMsg & " Defect Source: " & xRg.Cells(i, 8).Text & vbCrLf
    xMsg = xMsg & " Defect Day: " & xRg.Cells(i, 9).Text & vbCrLf
    xMsg = xMsg & " Defect Text: " & xRg.Cells(i, 10).Text & vbCrLf

'       Replace spaces with %20 (hex)
    xSubj = Application.WorksheetFunction.Substitute(xSubj, " ", "%20")
    xMsg = Application.WorksheetFunction.Substitute(xMsg, " ", "%20")
'       Replace carriage returns with %0D%0A (hex)
    xMsg = Application.WorksheetFunction.Substitute(xMsg, vbCrLf, "%0D%0A")
'       Create the URL
    xURL = "mailto:" & xEmail & "?subject=" & xSubj & "&body=" & xMsg
'       Execute the URL (start the email client)
    ShellExecute 0&, vbNullString, xURL, vbNullString, vbNullString, vbNormalFocus
'       Wait two seconds before sending keystrokes
    Application.Wait (Now + TimeValue("0:00:02"))
    Application.SendKeys "%s"
Next
End Sub

Answer 1

嗯，1390似乎不像我听过的任何限制。可能是255个字符，或者是一个长达20亿（2 ^ 31）个字符的可变长度字符串，等等。你能尝试这样做吗？

Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range

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

Set sh = Sheets("Sheet1")

Set OutApp = CreateObject("Outlook.Application")

For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

    'Enter the path/file names in the C:Z column in each row
    Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")

    If cell.Value Like "?*@?*.?*" And _
       Application.WorksheetFunction.CountA(rng) > 0 Then
        Set OutMail = OutApp.CreateItem(0)

        With OutMail
            .to = cell.Value
            .Subject = "Testfile"
            .Body = "Hi " & cell.Offset(0, -1).Value

            For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                If Trim(FileCell) <> "" Then
                    If Dir(FileCell.Value) <> "" Then
                        .Attachments.Add FileCell.Value
                    End If
                End If
            Next FileCell

            .Send  'Or use .Display
        End With

        Set OutMail = Nothing
    End If
Next cell

Set OutApp = Nothing
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With
End Sub

注：

在Sheets（“Sheet1”）中创建一个列表：

在A栏：人物的姓名

在B栏：电子邮件地址

在C列中：Z：像这样的文件名C：\ Data \ Book2.xls（不必是Excel文件）

宏将遍历“Sheet1”中的每一行，如果B列中有电子邮件地址和C列中的文件名：Z它将创建一个包含此信息的邮件并发送。

最相关的网址：

https://www.rondebruin.nl/win/s1/outlook/amail6.htm

父网址：

https://www.rondebruin.nl/win/s1/outlook/mail.htm

Answer 2

找到了修复方法。而不是使用Cells(i, 5).Text使用Cells(i, 5).Value。这样可以确保将单元格内容按原样发送到Outlook，而不是先将其转换为文本，从而导致出现问题。（问题中的代码也无法呈现中文文本。）

此外，我没有执行邮件到url，而是包含outlook的对象库，并为outlook应用程序和邮件项目声明了对象。 Dim olApp作为Outlook.Application Dim olMail作为Outlook.MailItem

Excel VBA发送Outlook邮件：无法发送超过1390个字符

2 个答案: