Я для более унифицированного подхода, хотел еще один интересный вопрос решить -это вставка подписи в отправляемое письмо. И в принципе даже нашел часть макроса по извлечению подписи из txt файла, но к сожалению мои знания не позволяют интегрировать эту часть макроса с Вашим творением, к тому же в данном макросе у меня не до конца получалось реализовать эту функцию, вместо извлеченной подписи у меня в теле письма прикладывалась информация из первого столбца отправляемого файла. Не поможете разобраться в этом вопросе, Rioran? [vba]
Код
Sub Mail_Workbook_1() Dim OutApp As Object Dim OutMail As Object Dim cell As Range
Application.ScreenUpdating = False Workbooks.OpenText "C:\Users\user11111\AppData\Roaming\Microsoft\Signatures\Aleksey.txt" For li = ActiveSheet.UsedRange.Row To ActiveSheet.UsedRange.Rows.Count sSignature = sSignature & vbCrLf & Cells(li, ActiveSheet.UsedRange.Column) Next li ActiveWorkbook.Close False
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon On Error GoTo cleanup
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next ' Change the mail address and subject in the macro before you run it. .......................... .......................... ........................... On Error GoTo 0
Set OutMail = Nothing cleanup: Set OutApp = Nothing
Application.ScreenUpdating = True End Sub
[/vba]
Я для более унифицированного подхода, хотел еще один интересный вопрос решить -это вставка подписи в отправляемое письмо. И в принципе даже нашел часть макроса по извлечению подписи из txt файла, но к сожалению мои знания не позволяют интегрировать эту часть макроса с Вашим творением, к тому же в данном макросе у меня не до конца получалось реализовать эту функцию, вместо извлеченной подписи у меня в теле письма прикладывалась информация из первого столбца отправляемого файла. Не поможете разобраться в этом вопросе, Rioran? [vba]
Код
Sub Mail_Workbook_1() Dim OutApp As Object Dim OutMail As Object Dim cell As Range
Application.ScreenUpdating = False Workbooks.OpenText "C:\Users\user11111\AppData\Roaming\Microsoft\Signatures\Aleksey.txt" For li = ActiveSheet.UsedRange.Row To ActiveSheet.UsedRange.Rows.Count sSignature = sSignature & vbCrLf & Cells(li, ActiveSheet.UsedRange.Column) Next li ActiveWorkbook.Close False
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon On Error GoTo cleanup
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next ' Change the mail address and subject in the macro before you run it. .......................... .......................... ........................... On Error GoTo 0
Set OutMail = Nothing cleanup: Set OutApp = Nothing
1). У вас есть стандартная подпись Outlook (или Вы можете её сделать и использовать). Тогда это один код. Нашёл другой, который проще Вашего. 2). Есть вариант прописать подпись в макросе - одна строка, например, имя, вторая - телефон и т.д. 3). И, из разряда извращений - можно подтягивать тексты подписи из Excel файла. Например, если для разных отправителей нужна вариативность подписи.
Что Вам лучше подойдёт? Я бы рекомендовал 1-й вариант.
[offtop]Задавая вопрос, не обязательно обращаться к кому-то персонально - на этом форуме очень много компетентных специалистов [/offtop]
Bulava81, есть несколько вариантов:
1). У вас есть стандартная подпись Outlook (или Вы можете её сделать и использовать). Тогда это один код. Нашёл другой, который проще Вашего. 2). Есть вариант прописать подпись в макросе - одна строка, например, имя, вторая - телефон и т.д. 3). И, из разряда извращений - можно подтягивать тексты подписи из Excel файла. Например, если для разных отправителей нужна вариативность подписи.
Что Вам лучше подойдёт? Я бы рекомендовал 1-й вариант.
[offtop]Задавая вопрос, не обязательно обращаться к кому-то персонально - на этом форуме очень много компетентных специалистов [/offtop]Rioran
Роман, Москва, voronov_rv@mail.ru Яндекс-Деньги: 41001312674279
Сообщение отредактировал Rioran - Понедельник, 23.06.2014, 15:59
Я просто еще раз убеждаюсь, что RIORAN ГЕНИЙ!!! Так просто и в то же время рационально решить очень интересный и важный вопрос! Спасибо Вам огромное Роман
Я просто еще раз убеждаюсь, что RIORAN ГЕНИЙ!!! Так просто и в то же время рационально решить очень интересный и важный вопрос! Спасибо Вам огромное Роман Bulava81
Коллеги, помогите разобраться с подписью в моём коде:
Есть готовый макрос для отправки письма, со следующей структурой:
1. Текст 1 (приветствие) 2. Вставленный в тело письма фрагмент excel таблицы 3. Текст 2 (к примеру, краткие пояснения к таблице)
А вот четвёртым пунктом - необходимо автоматически подгрузить подпись из Outlook. Причём подгружаться должна та подпись, которая настроена по умолчанию на данном компьютере/OutlookЕ (письмо может быть отправлено не только с моего адреса (компьютера), следовательно подпись должна меняться в зависимости от того, кто пользуется этим макросом)
Помогите, пожалуйста, понять, что нужно добавить в этот код, чтобы заработала подпись, предложенные выше варианты в данном случае увы не работают:
[vba]
Код
Sub Mail_Selection_Range_Outlook_Body() Dim rng As Range Dim OutApp As Object Dim OutMail As Object
Set rng = Nothing On Error Resume Next Set rng = Sheets(1).Range("A1:K4").SpecialCells(xlCellTypeVisible) On Error GoTo 0
If rng Is Nothing Then MsgBox "The selection is not a range or the sheet is protected. " & _ vbNewLine & "Please correct and try again.", vbOKOnly Exit Sub End If
With Application .EnableEvents = False .ScreenUpdating = False End With
Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0)
strbodyb = "ТЕКСТ 1"
Strbodya = "ТЕКСТ 2"
On Error Resume Next With OutMail .To = "test@test.ru" .CC = "" .BCC = "" .Subject = "Название письма" .HTMLBody = strbodyb & RangetoHTML(rng) & Strbodya .Display
End With On Error GoTo 0
With Application .EnableEvents = True .ScreenUpdating = True End With
Set OutMail = Nothing Set OutApp = Nothing End Sub
Function RangetoHTML(rng As Range) ' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010. Dim fso As Object Dim ts As Object Dim TempFile As String Dim TempWB As Workbook
' Copy the range and create a workbook to receive the data. rng.Copy Set TempWB = Workbooks.Add(1) With TempWB.Sheets(1) .Cells(1).PasteSpecial Paste:=8 .Cells(1).PasteSpecial xlPasteValues, , False, False .Cells(1).PasteSpecial xlPasteFormats, , False, False .Cells(1).Select Application.CutCopyMode = False On Error Resume Next .DrawingObjects.Visible = True .DrawingObjects.Delete On Error GoTo 0 End With
' Publish the sheet to an .htm file. With TempWB.PublishObjects.Add( _ SourceType:=xlSourceRange, _ Filename:=TempFile, _ Sheet:=TempWB.Sheets(1).Name, _ Source:=TempWB.Sheets(1).UsedRange.Address, _ HtmlType:=xlHtmlStatic) .Publish (True) End With
' Read all data from the .htm file into the RangetoHTML subroutine. Set fso = CreateObject("Scripting.FileSystemObject") Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2) RangetoHTML = ts.ReadAll ts.Close RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _ "align=left x:publishsource=")
' Close TempWB. TempWB.Close savechanges:=False
' Delete the htm file. Kill TempFile
Set ts = Nothing Set fso = Nothing Set TempWB = Nothing End Function
[/vba] [moder]Вас уже отсылали к Правилам форума. Эта тема закрыта. Вам замечание.
Коллеги, помогите разобраться с подписью в моём коде:
Есть готовый макрос для отправки письма, со следующей структурой:
1. Текст 1 (приветствие) 2. Вставленный в тело письма фрагмент excel таблицы 3. Текст 2 (к примеру, краткие пояснения к таблице)
А вот четвёртым пунктом - необходимо автоматически подгрузить подпись из Outlook. Причём подгружаться должна та подпись, которая настроена по умолчанию на данном компьютере/OutlookЕ (письмо может быть отправлено не только с моего адреса (компьютера), следовательно подпись должна меняться в зависимости от того, кто пользуется этим макросом)
Помогите, пожалуйста, понять, что нужно добавить в этот код, чтобы заработала подпись, предложенные выше варианты в данном случае увы не работают:
[vba]
Код
Sub Mail_Selection_Range_Outlook_Body() Dim rng As Range Dim OutApp As Object Dim OutMail As Object
Set rng = Nothing On Error Resume Next Set rng = Sheets(1).Range("A1:K4").SpecialCells(xlCellTypeVisible) On Error GoTo 0
If rng Is Nothing Then MsgBox "The selection is not a range or the sheet is protected. " & _ vbNewLine & "Please correct and try again.", vbOKOnly Exit Sub End If
With Application .EnableEvents = False .ScreenUpdating = False End With
Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0)
strbodyb = "ТЕКСТ 1"
Strbodya = "ТЕКСТ 2"
On Error Resume Next With OutMail .To = "test@test.ru" .CC = "" .BCC = "" .Subject = "Название письма" .HTMLBody = strbodyb & RangetoHTML(rng) & Strbodya .Display
End With On Error GoTo 0
With Application .EnableEvents = True .ScreenUpdating = True End With
Set OutMail = Nothing Set OutApp = Nothing End Sub
Function RangetoHTML(rng As Range) ' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010. Dim fso As Object Dim ts As Object Dim TempFile As String Dim TempWB As Workbook
' Copy the range and create a workbook to receive the data. rng.Copy Set TempWB = Workbooks.Add(1) With TempWB.Sheets(1) .Cells(1).PasteSpecial Paste:=8 .Cells(1).PasteSpecial xlPasteValues, , False, False .Cells(1).PasteSpecial xlPasteFormats, , False, False .Cells(1).Select Application.CutCopyMode = False On Error Resume Next .DrawingObjects.Visible = True .DrawingObjects.Delete On Error GoTo 0 End With
' Publish the sheet to an .htm file. With TempWB.PublishObjects.Add( _ SourceType:=xlSourceRange, _ Filename:=TempFile, _ Sheet:=TempWB.Sheets(1).Name, _ Source:=TempWB.Sheets(1).UsedRange.Address, _ HtmlType:=xlHtmlStatic) .Publish (True) End With
' Read all data from the .htm file into the RangetoHTML subroutine. Set fso = CreateObject("Scripting.FileSystemObject") Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2) RangetoHTML = ts.ReadAll ts.Close RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _ "align=left x:publishsource=")
' Close TempWB. TempWB.Close savechanges:=False
' Delete the htm file. Kill TempFile
Set ts = Nothing Set fso = Nothing Set TempWB = Nothing End Function
[/vba] [moder]Вас уже отсылали к Правилам форума. Эта тема закрыта. Вам замечание.chendex
Сообщение отредактировал _Boroda_ - Вторник, 21.07.2015, 14:22