Отправка данных из Excel средствами Outlook

@bboyRALF · Регистрация: 09.07.2012

Студворк — интернет-сервис помощи студентам

Доброго дня.
Необходимо сделать макрос для отправки писем.
Проблема: на листе 3 существует несколько "фирм" по столбцу D указан е-мэйл (он может находится случайно в любой строке столбца D) Ниже приведен код. но проблема в том что он не переносит выделенный текст

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Sub SendMail()
 
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    On Error GoTo cleanup
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
 
    With OutMail
       
        .To = Range(Sheets(Ëèñò3).[D1]).Value
        .Subject = "äîáðîãî äíÿ"
        
        .Body = ActiveDocument.Selection(.Sheets(Ëèñò3))
   .Attachments.Add TempDocPath
       
        .Display
    End With
 
    On Error GoTo 0
    Set OutMail = Nothing
  
cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

И еще есть ли возможность не выделять текст, если это можно избежать то как ?.
Лист 3 во вложении

@mc-black · 31.07.2012, 13:23

1. Лист3 надо заключать в кавычки, когда обращаешься к коллекции листов (строки 16, 19)
2. Если надо обращаться к адресам в столбце D, надо переделать строку 16 примерно таким образом:

Visual Basic
1
.To = Sheets("Лист3").Cells(i, 4).Value

причем основной код надо прокрутить в цикле по i, проверяя в цикле, что в столбце D непустое значение (а лучше регуляркой проверить валидность e-mail адресов).
3. Неясно, откуда ты собираешься взять текст письма (строка 19)?

@bboyRALF · 31.07.2012, 14:32 **[ТС]**

текст будет браться с листа 3 начиная с A 2 по J и в низ

Добавлено через 25 минут

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
Sub SendMail()
 
    Dim OutApp As Object, CStart As Range
        Dim OutMail As Object
    Dim cell As Range
    
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    On Error GoTo cleanup
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
 With ThisWorkbook.Sheets("Лист3")
    With OutMail
       Set CStart = .[D1] 
        For i = 1 To .UsedRange.End(xlDown).Row + 100
            If Val(Right(.Cells(4 + i, 1), 19)) > 1 Then
        .To = Sheets("Лист3").Cells(i, 4).Value
         End If
        .Subject = "Добрый день"
        
        .Body = ActiveDocument.Selection(.Sheets("Лист3"))
   .Attachments.Add TempDocPath
       
        .Display
       
    
Next
    On Error GoTo 0
    Set OutMail = Nothing
  
cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
   
    
    End With
    End With
End Sub

.Body = ActiveDocument.Selection(.Sheets("Лист3" )) - не переносит выделенный текст в тело письма.
С емэйлом не разобрался, т.к. в столбце D находятся значения отличные от e-mail.

@mc-black · 31.07.2012, 14:56

Сообщение от bboyRALF

.Body = ActiveDocument.Selection(.Sheets("Лист3" )) - не переносит выделенный текст в тело письма.

И не должен: Объекта ActiveDocument нет в Excel, коллекции .Sheets нет в Outlook. Стрка 13 With ThisWorkbook.Sheets("Лист3") не действует, её можно смело убрать вместе с парной End With. Большинство таких замечаний выдаст компилятор при попытке запустить макрос. Сначала пробуй то, что не работет, анализируй полученные сообщения об ошибках, делай выводы и правь код, чтобы этих ошибок не возникало.

В выделениях ячеех Excel есть диапазоны, а не текст. Чтобы получить нужный текст, надо диапазон перевести в строку по каким-то правилам. Выложи фрагмент листа Excel и образец текста, который хочешь из него получить (через Расширенный режим - Управление файлами).

@bboyRALF · 31.07.2012, 15:10 **[ТС]**

Сообщение от mc-black

И не должен: Объекта ActiveDocument нет в Excel, коллекции .Sheets нет в Outlook. Стрка 13 With ThisWorkbook.Sheets("Лист3") не действует, её можно смело убрать вместе с парной End With. Большинство таких замечаний выдаст компилятор при попытке запустить макрос. Сначала пробуй то, что не работет, анализируй полученные сообщения об ошибках, делай выводы и правь код, чтобы этих ошибок не возникало.

В выделениях ячеех Excel есть диапазоны, а не текст. Чтобы получить нужный текст, надо диапазон перевести в строку по каким-то правилам. Выложи фрагмент листа Excel и образец текста, который хочешь из него получить (через Расширенный режим - Управление файлами).

Прикладываю, лист 1 это таблица, лист 2 пример письма из outlook

@bboyRALF · 02.08.2012, 09:26 **[ТС]**

Попробывал указать именно установленный диапазон.

Visual Basic
1
 .Body = Range("A1:J21").Value

Он не выводит его в письмо, а если

Visual Basic
1
 .Body = Range("A1").Value

тогда именно выводит ячейку А1..

Добавлено через 18 часов 30 минут
Кому интересно, функция перевода диапазона ячеек в строку

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
Function Range_To_text(MyRange As Range) As String
    Dim i&, j&, MyText$
    Const Razdelitel = " " ' Åñëè íàäî îòäåëÿòü çíà÷åíèÿ ïðîáåëàìè
    With MyRange
        For i = 1 To .Rows.Count
            For j = 1 To .Columns.Count
                MyText = MyText & CStr(.Cells(i, j))
                If j < .Columns.Count Then MyText = MyText & Razdelitel
            Next
            MyText = MyText & vbCrLf
        Next
    End With
    Range_To_text = MyText
End Function

@аналитика · 02.08.2012, 13:56

Сообщение от bboyRALF

Попробывал указать именно установленный диапазон.

Visual Basic
1
.Body = Range("A1:J21").Value

попробуй так:

Visual Basic
1
.htmlBody = sGetHtmlFromRange(Range("A1:J21"))

собст-но, сам фарш:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
Public Function sGetHtmlFromRange(rngIn As Range) As String
    Dim sTemp As String: sTemp = "<html>" & vbCrLf
    sTemp = sTemp & "<body>" & vbCrLf
 
    Dim rngArea As Range
    For Each rngArea In rngIn.Areas
        sTemp = sTemp & sGetHtmlFromSingleRange(rngArea) & vbCrLf
        sTemp = sTemp & "<br>" & vbCrLf & vbCrLf
    Next rngArea
 
    sTemp = sTemp & "</body>" & vbCrLf
    sTemp = sTemp & "</html>"
 
    sGetHtmlFromRange = sTemp
End Function
 
'_______________________________________________________________________________________
 
Private Function sGetHtmlFromSingleRange(rngIn As Range) As String
    If rngIn.Areas.Count > 1 Then
        MsgBox "Для несвязанного диапазона используйте функцию sGetHtmlFromRange", vbCritical
        sGetHtmlFromSingleRange = ""
        Exit Function
    End If
    '========================================================================================
 
    Dim sTemp As String: sTemp = "<table border=1 cellpadding=5 >" & vbCrLf
 
    Dim r As Integer, c As Integer
    For r = 1 To rngIn.Rows.Count
        sTemp = sTemp & "<tr>" & vbCrLf
        For c = 1 To rngIn.Columns.Count
            Dim v: v = rngIn(r, c).Value
            TransformValue v
            sTemp = sTemp & vbTab & "<td>" & v & "</td>" & vbCrLf
            'Debug.Print rngIn(r, c).Address,
        Next c
        sTemp = sTemp & "</tr>" & vbCrLf
        'Debug.Print
    Next r
    sTemp = sTemp & "</table>" & vbCrLf
 
    sGetHtmlFromSingleRange = sTemp
End Function
 
Private Sub TransformValue(ByRef vIn)
' здесь любые преобразования пропишешь, если нужно...
    Select Case TypeName(vIn)
        Case "String"
 
        Case "Integer"
 
        Case "Long"
 
        Case "Single"
 
        Case "Double"
            vIn = Format$(vIn, "0.00000")
 
    End Select
End Sub

@bboyRALF · 02.08.2012, 15:04 **[ТС]**

а как отформатировать так чтобы первые 2 ячейки. к примеру А1, А2 он в таблицу не вводил ?

@аналитика · 02.08.2012, 15:19

замени строки 33, 34 этим:

Visual Basic
1
2
3
4
with rngIn(r, c) 
   Dim v: v = .Value
   TransformValue v, .address
end with

измени процедуру:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
Private Sub TransformValue(ByRef vIn, sAddr as string)
if sAddr="$A$1" or sAddr="$A$2" then
   vIn=""
   exit sub
end if
 
' здесь любые преобразования пропишешь, если нужно...
    Select Case TypeName(vIn)
        Case "String"
 
        ...
End Sub

@bboyRALF · 15.08.2012, 09:47 **[ТС]**

А как сделать так, чтобы диапазон текста сообщения был не заданным, т.к. диапазон текста может быть случайным.
И еще вопрос. У меня возникли проблемы с емэйлами. т.к. их может быть несколько на столбцу D.
и необходимо чтобы открывалось несколько окон для отправки в outlook (на каждый емэй отдельно).

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
 With OutMail
           Set CStart = [D1] 'е-мэйлы с листа № 3 (ячейка D1)
For i = 1 To .UsedRange.End(xlDown).Row + 1
  If Worksheets("Лист 3").Cells(i, 3).Value Then
 
Worksheets("Лист3").Cells(3 + i, 4).Value
 
 
        .To = Sheets("Лист3").Cells(i, 4).Value
  
        .Subject = "Доброго дня"
        With Sheets("Лист3")
   Set oRange = .Range(.Cells(i, j), .Cells(k, l))
   Set CStart = .[A1] 'для фирм (ячейка А1)
        For i = 1 To .UsedRange.End(xlDown).Row + 100
 
         
            If Val(Right(.Cells(3 + i, 1), 19)) > 1 Then
 
.htmlBody =  sGetHtmlFromRange(Range("A4:J21")) 
 
        'End If
 
        .Display
 'Next i
    
'End With

Новые блоги и статьи Все статьи Все блоги /
Символьное дифференцирование igorrr37 13.02.2026 / * Логарифм записывается как: (x-2)log(x^2+2) - означает логарифм (x^2+2) по основанию (x-2). Унарный минус обозначается как ! */ #include <iostream> #include <stack> #include <cctype>. . .	Камера Toupcam IUA500KMA Eddy_Em 12.02.2026 Т. к. у всяких "хикроботов" слишком уж мелкий пиксель, для подсмотра в ESPriF они вообще плохо годятся: уже 14 величину можно рассмотреть еле-еле лишь на экспозициях под 3 секунды (а то и больше),. . .	И ясному Солнцу zbw 12.02.2026 И ясному Солнцу, и светлой Луне. В мире покоя нет и люди не могут жить в тишине. А жить им немного лет.	«Знание-Сила» zbw 12.02.2026 «Знание-Сила» «Время-Деньги» «Деньги -Пуля»
SDL3 для Web (WebAssembly): Подключение Box2D v3, физика и отрисовка коллайдеров 8Observer8 12.02.2026 Содержание блога Box2D - это библиотека для 2D физики для анимаций и игр. С её помощью можно определять были ли коллизии между конкретными объектами и вызывать обработчики событий столкновения. . . .	SDL3 для Web (WebAssembly): Загрузка PNG с прозрачным фоном с помощью SDL_LoadPNG (без SDL3_image) 8Observer8 11.02.2026 Содержание блога Библиотека SDL3 содержит встроенные инструменты для базовой работы с изображениями - без использования библиотеки SDL3_image. Пошагово создадим проект для загрузки изображения. . .	SDL3 для Web (WebAssembly): Загрузка PNG с прозрачным фоном с помощью SDL3_image 8Observer8 10.02.2026 Содержание блога Библиотека SDL3_image содержит инструменты для расширенной работы с изображениями. Пошагово создадим проект для загрузки изображения формата PNG с альфа-каналом (с прозрачным. . .	Установка Qt-версии Lazarus IDE в Debian Trixie Xfce volvo 10.02.2026 В общем, достали меня глюки IDE Лазаруса, собранной с использованием набора виджетов Gtk2 (конкретно: если набирать текст в редакторе и вызвать подсказку через Ctrl+Space, то после закрытия окошка. . .

@bboyRALF 0 / 0 / 0 Регистрация: 09.07.2012 Сообщений: 110 Записей в блоге: 2
	02.08.2012, 15:04 [ТС]
	а как отформатировать так чтобы первые 2 ячейки. к примеру А1, А2 он в таблицу не вводил ? 0

Отправка данных из Excel средствами Outlook

Решение