Необходимо автоматически подгрузить подпись из Outlook. Причём подгружаться должна та подпись, которая настроена по умолчанию на данном компьютере/OutlookЕ (письмо может быть отправлено не только с моего адреса (компьютера), следовательно подпись должна меняться в зависимости от того, кто пользуется этим макросом)
Помогите, пожалуйста, понять, что нужно добавить в мой макрос, чтобы заработала подпись. Нашла макрос с добавлением подписи в письмо, но не знаю как и что добавить из него в мой макрос, чтобы добавлялась подпись.
Мой Макрос для отправки письма: [vba]
Код
Sub Уведомление()
Dim OutApp As Object Dim OutMail As Object Dim rng As Range
With Application .EnableEvents = False .ScreenUpdating = False End With
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row Set rng = Nothing Set rng = ActiveSheet.Range(Cells(1, 1), Cells(iLastRow, 7))
Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0)
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 On Error GoTo 0 End With
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
Set ts = Nothing Set fso = Nothing Set TempWB = Nothing End Function
[/vba] Найденный макрос с добавлением подписи:
[vba]
Код
Sub подпись()
Dim OutApp As Object, OutMail As Object, Strbody As String, r As Date Set OutApp = CreateObject("Outlook.Application") OutApp.Session.Logon: Set OutMail = OutApp.CreateItem(0) On Error Resume Next r = Format(Now(), "dd mmmm yyyy") 'формат даты With OutMail .To = "primer@mail.ru": .CC = "": .BCC = "": .Subject = "Тема " & r & " продолжение темы": 'вставка даты .Attachments.Add ("C:\Test.xls") .Body = Activedocument.Content 'в этом случае открывается письмо с подписью той которая по умолчанию в Outlooke .Display 'or use .send End With On Error GoTo 0: Set OutMail = Nothing: Set OutApp = Nothing End Sub
[/vba] [moder]Для оформления кодов макросов используйте кнопку #. Сделал за Вас на первый раз.
Добрый день!
Есть готовый макрос для отправки письма.
Необходимо автоматически подгрузить подпись из Outlook. Причём подгружаться должна та подпись, которая настроена по умолчанию на данном компьютере/OutlookЕ (письмо может быть отправлено не только с моего адреса (компьютера), следовательно подпись должна меняться в зависимости от того, кто пользуется этим макросом)
Помогите, пожалуйста, понять, что нужно добавить в мой макрос, чтобы заработала подпись. Нашла макрос с добавлением подписи в письмо, но не знаю как и что добавить из него в мой макрос, чтобы добавлялась подпись.
Мой Макрос для отправки письма: [vba]
Код
Sub Уведомление()
Dim OutApp As Object Dim OutMail As Object Dim rng As Range
With Application .EnableEvents = False .ScreenUpdating = False End With
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row Set rng = Nothing Set rng = ActiveSheet.Range(Cells(1, 1), Cells(iLastRow, 7))
Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0)
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 On Error GoTo 0 End With
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
Set ts = Nothing Set fso = Nothing Set TempWB = Nothing End Function
[/vba] Найденный макрос с добавлением подписи:
[vba]
Код
Sub подпись()
Dim OutApp As Object, OutMail As Object, Strbody As String, r As Date Set OutApp = CreateObject("Outlook.Application") OutApp.Session.Logon: Set OutMail = OutApp.CreateItem(0) On Error Resume Next r = Format(Now(), "dd mmmm yyyy") 'формат даты With OutMail .To = "primer@mail.ru": .CC = "": .BCC = "": .Subject = "Тема " & r & " продолжение темы": 'вставка даты .Attachments.Add ("C:\Test.xls") .Body = Activedocument.Content 'в этом случае открывается письмо с подписью той которая по умолчанию в Outlooke .Display 'or use .send End With On Error GoTo 0: Set OutMail = Nothing: Set OutApp = Nothing End Sub
[/vba] [moder]Для оформления кодов макросов используйте кнопку #. Сделал за Вас на первый раз.InesVolero
Сообщение отредактировал _Boroda_ - Пятница, 04.09.2015, 15:56