Удаление подписи в сообщении Outlook 2010, созданном с помощью макроса Excel VBA

Я пытался и читал, но не могу найти решение этой проблемы. У меня есть файл Excel, где, когда пользователь нажимает кнопку:

А) диапазон выбирается и копируется в буфер обмена

Б) Новое сообщение Outlook открывается на основе шаблона

В) Электронная почта будет отправлена ​​«от имени» вместо имени / учетной записи пользователя.

Затем пользователь должен добавить дату в электронное письмо и вставить скопированный диапазон в определенную часть шаблона. Это все нормально и работает НО !!! Outlook автоматически добавляет подпись пользователей в конец электронного письма, и это нежелательно.

Это код, который я сейчас использую:

Sub SelectArea()
Application.ScreenUpdating = False

lastCol = ActiveSheet.Range("a1").End(xlToRight).Column - 2
lastRow = ActiveSheet.Cells(500, lastCol).End(xlUp).Row
ActiveSheet.Range("a1", ActiveSheet.Cells(lastRow, lastCol)).Copy

Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItemFromTemplate("\\network\path\to\the\MailTemplate.oft")

With OutMail
    .SentOnBehalfOfName = """DepartmentX"" <[email protected]>"
    .Display
End With

Application.ScreenUpdating = True
End Sub

В настоящее время нет подписки на удаление подписи, потому что я не мог заставить ее работать. Раньше был внутри "с OutMail", но сам саб не работал. Я даже протестировал пример с сайта Microsoft 1: 1, но все равно не смог заставить его работать.

Код от Microsoft выглядит следующим образом:

Sub TestDeleteSig()
    Dim objOL As Outlook.Application
    Dim objMsg As Outlook.MailItem
    Set objOL = CreateObject("Outlook.Application")
    Set objMsg = objOL.CreateItem(olMailItem)
    objMsg.Display
    Call DeleteSig(objMsg)
    Set objMsg = Nothing
End Sub

Sub DeleteSig(msg As Outlook.MailItem)
    Dim objDoc As Word.Document
    Dim objBkm As Word.Bookmark
    On Error Resume Next
    Set objDoc = msg.GetInspector.WordEditor
    Set objBkm = objDoc.Bookmarks("_MailAutoSig")
    If Not objBkm Is Nothing Then
        objBkm.Select
        objDoc.Windows(1).Selection.Delete
    End If
    Set objDoc = Nothing
    Set objBkm = Nothing
End Sub

Он открывает новое электронное сообщение (с подписью) и выдает ошибку компиляции. «Пользовательский тип не определен». Он помечает «Sub DeleteSig (msg As Outlook.MailItem)» желтым цветом и выделяет «objDoc As Word.Documen» синим цветом. ... и вот где он меня теряет :(

Может ли кто-нибудь здесь пролить свет на это? Это будет высоко ценится.

С уважением.


email outlook excel vba signature
person user2890690    schedule 08.09.2015    source источник

Ответы (3)


arrow_upward
2
arrow_downward

Это удалит подпись из шаблона электронного письма.

Последний Sub поместит выбранный диапазон из Excel в тело шаблона.

Option Explicit

Public Sub TestDeleteSig()
    Dim olApp As Object, olMsg As Object

    Set olApp = CreateObject("Outlook.Application")
    Set olMsg = olApp.CreateItem(0)
    olMsg.Display

    DeleteSig olMsg
    InsertRng olMsg

    Set olMsg = Nothing
End Sub

Private Sub DeleteSig(msg As Object)
    Dim wrdDoc As Object, wrdBkm As Object
    On Error Resume Next
    Set wrdDoc = msg.GetInspector.WordEditor
    Set wrdBkm = wrdDoc.Bookmarks("_MailAutoSig")
    If Not wrdBkm Is Nothing Then wrdBkm.Range.Delete
    Set wrdDoc = Nothing
    Set wrdBkm = Nothing
End Sub

Private Sub InsertRng(msg As Object)
    Dim rng As Range
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    If Not rng Is Nothing Then
        If rng.Rows.Count = 1 And rng.Columns.Count = 1 Then
            If Len(rng) = 0 Then Set rng = ActiveSheet.UsedRange.Cells(1)
        End If
        rng.Copy
        msg.GetInspector.WordEditor.Content.PasteSpecial xlPasteAll
        Application.CutCopyMode = False
    End If
End Sub

Если выбрана только одна ячейка и она пуста, будет вставлена ​​первая ячейка с данными из ActiveSheet.

person paul bica    schedule 08.09.2015
comment
Сначала сравнил те, которые у меня были, с теми, которые вы написали, пытаясь понять, что / где / как, но не смог. Потом протестировал ваш: заработало. Отредактировал ваш, чтобы он соответствовал моим потребностям: немного неудобно, но у меня он тоже работает. Теперь все работает! Я пропустил Option Explicit, потому что каким-то образом часть диапазона выбора больше не работала ... В любом случае, сейчас все, похоже, не работает. Спасибо! - person user2890690; 09.09.2015
comment
Я рад, что это помогло. Если ответ касается проблемы, примите его как ссылку для других (щелкните галочку под стрелкой вниз). Подпрограммы от Microsoft также будут работать, но для их использования вам нужно добавить 2 ссылки в редакторе VBA: перейдите в меню Инструменты - ›Ссылки, прокрутите список вниз и выберите 1) Библиотека объектов Microsoft Outlook (любой из них, если у вас несколько библиотек), также выберите 2) _Microsoft Word Object Library (любую из них). - person paul bica; 09.09.2015
comment
Я хотел бы расширить это, если возможно, следующим образом, но не могу понять, как именно (и да, я прочитал образцы / коды Рона де Брюина): в открываемом почтовом шаблоне есть конкретный строка, которую следует заменить скопированным диапазоном. Можно ли сделать это автоматически (заменить эту строку в шаблоне электронной почты скопированным диапазоном)? - person user2890690; 06.10.2015
comment
Я добавил новую подписку, которая скопирует и вставит выбранный диапазон из ActiveSheet в тело пустого шаблона. Его можно модифицировать для соответствия другим требованиям. - person paul bica; 06.10.2015
comment
У меня работает, что он либо копирует / вставляет выделение в новое письмо, либо открывает новое письмо из шаблона. В шаблоне есть HTML и изображения. Я попытаюсь опубликовать здесь текущий VBA, но я не уверен, как это сделать здесь .... - person user2890690; 13.10.2015
comment
Сообщите мне, если вам нужна помощь в публикации (отправьте VBA как code и, возможно, снимок экрана как изображение) - person paul bica; 14.10.2015

arrow_upward
0
arrow_downward

Итак, это текущий код VBA. Он выбирает диапазон, копирует его в пустое электронное письмо, вставляет его туда и удаляет подпись пользователей.

«Проблема» в том, что он должен открыть новое письмо на основе существующего шаблона (.oft) и вставить его туда, где написано «‹ вставить таблицу / обзор ›». У oft есть заголовок изображения и некоторый (html / форматированный) текст в нем.

Я начинаю задаваться вопросом, возможно ли то, что я пытаюсь достичь.

Sub DeleteSig()
   Dim olApp As Object, olMsg As Object
   Set olApp = CreateObject("Outlook.Application")
   Set olMsg = olApp.CreateItemFromTemplate("\\myserver\my_template.oft")
   olMsg.Display
   DeleteSig_action olMsg
   InsertRng olMsg
   Set olMsg = Nothing
End Sub

Sub DeleteSig_action(msg As Object)
   Dim wrdDoc As Object, wrdBkm As Object 
   On Error Resume Next    
   Set wrdDoc = msg.GetInspector.WordEditor
   Set wrdBkm = wrdDoc.Bookmarks("_MailAutoSig")
   If Not wrdBkm Is Nothing Then wrdBkm.Range.Delete
   Set wrdDoc = Nothing
   Set wrdBkm = Nothing
End Sub

Sub InsertRng(msg As Object)
   Dim rng As Range 
   lastCol = ActiveSheet.Range("a1").End(xlToRight).Column - 2
   lastRow = ActiveSheet.Cells(500, lastCol).End(xlUp).Row
   Set rng = ActiveSheet.Range("a1", ActiveSheet.Cells(lastRow, lastCol))
   rng.Copy        
   msg.GetInspector.WordEditor.Content.PasteSpecial xlPasteAll
   Application.CutCopyMode = False
End Sub
person user2890690    schedule 13.10.2015

arrow_upward
0
arrow_downward

Это полный рабочий код, удаляющий подпись из почтового шаблона.

Option Explicit

Sub openEmail()

Dim cfgFromEmail As String
Dim cfgNotice As String
Dim cfgTemplate As String
Dim appOutlook As Outlook.Application
Dim newEmail As Outlook.MailItem

Dim rownum As Integer
Dim colnum As Integer

rownum = 6

cfgFromEmail = Sheets("Email").Range("O5").Value
cfgNotice = Sheets("Email").Cells(rownum, 10) '10 = column J
cfgTemplate = Sheets("Email").Cells(rownum, 11) '11 = column K

Set appOutlook = CreateObject("Outlook.Application")
Set newEmail = appOutlook.CreateItemFromTemplate(ThisWorkbook.Path & "\" & cfgTemplate & ".oft")
'Set template = mailApp.CreateItem(olMailItem) 'Creates a blank email

If cfgNotice <> "null" Then 'If is not blank
    MsgBox cfgNotice, vbInformation, "Before you send the email"
End If


    Dim objDoc As Word.Document
    Dim objBkm As Word.Bookmark
    On Error Resume Next
    Set objDoc = newEmail.GetInspector.WordEditor
    Set objBkm = objDoc.Bookmarks("_MailAutoSig")
    If Not objBkm Is Nothing Then
        objBkm.Select
        objDoc.Windows(1).Selection.Delete
    End If
    Set objDoc = Nothing
    Set objBkm = Nothing

With newEmail
    .SentOnBehalfOfName = cfgFromEmail
    .Display 'Show the email


End With

Set newEmail = Nothing
Set appOutlook = Nothing

End Sub
person Durgaprasad    schedule 10.08.2018