Excel VBA для отправки почты Outlook: невозможно отправить более 1390 символов - PullRequest
Новая
       28

Excel VBA для отправки почты Outlook: невозможно отправить более 1390 символов

0 голосов
/ 17 мая 2018

Я немного изменил код здесь - https://www.extendoffice.com/documents/excel/3560-excel-send-personalized-email.html

Если текст в ячейке с дефектом длинный, он автоматически обрезается. ( Вот так выглядит мой лист )

Не уверен, что это является основной причиной, но я попытался увеличить значение времени приложения до 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

Ответы [ 2 ]

0 голосов
/ 22 мая 2018

Нашли исправление.Вместо использования Cells(i, 5).Text используйте Cells(i, 5).Value.Это гарантирует, что содержимое ячейки отправляется в внешний вид как есть, вместо того, чтобы сначала преобразовывать его в текст, что вызывает проблемы.(Код в вопросе также не смог отобразить китайский текст.)

Кроме того, вместо того, чтобы выполнить отправку письма по URL, я включил библиотеку объектов для outlook и объявил объект для приложения outlook и для элемента mail.Dim olApp As Outlook.Application Dim olMail As Outlook.MailItem

0 голосов
/ 17 мая 2018

Ну, 1390 не похоже ни на какое ограничение, о котором я когда-либо слышал.Может быть, 255 символов или строка переменной длины длиной примерно до 2 миллиардов (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», и если в E-mail указан адрес электронной почты.В столбце B и именах файлов в столбце C: Z он создаст письмо с этой информацией и отправит его.

Наиболее релевантный URL:

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

Родительский URL:

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

...