Не удается отправить электронную почту Lotus Notes вручную в excel

Question

Я пытаюсь использовать макрос для отправки электронной почты Lotus Notes клиентам, я могу отправить его автоматически, но в случае, если есть что-то, что я хотел бы добавить перед отправкой, поэтому я хочу установить его как ручной режим, чтобы сначала просмотреть электронное письмо и, возможно, внести некоторые изменения перед отправкой, поэтому мой вопрос заключается в том, как мне его изменить? У меня есть несколько способов, но они не работают.

Я затем разместить весь свой код с функцией автоматической отправки:

Sub Send_Unformatted_Rangedata(i As Integer) 
Dim noSession As Object, noDatabase As Object, noDocument As Object 
Dim vaRecipient As Variant 
Dim rnBody As Range 
Dim Data As DataObject 
Dim rngGen As Range 
Dim rngApp As Range 
Dim rngspc As Range 

Dim stSubject As String 
stSubject = "E-Mail For Approval for " + (Sheets("Summary").Cells(i, "A").Value) + " for the Project " + Replace(ActiveWorkbook.Name, ".xls", "") 
'Const stMsg As String = "Data as part of the e-mail's body." 
'Const stPrompt As String = "Please select the range:" 

'This is one technique to send an e-mail to many recipients but for larger 
'number of recipients it's more convenient to read the recipient-list from 
'a range in the workbook. 
vaRecipient = VBA.Array(Sheets("Summary").Cells(i, "U").Value, Sheets("Summary").Cells(i, "V").Value) 

On Error Resume Next 
'Set rnBody = Application.InputBox(Prompt:=stPrompt, _ 
    Default:=Selection.Address, Type:=8) 
'The user canceled the operation. 
'If rnBody Is Nothing Then Exit Sub 
Set rngGen = Nothing 
Set rngApp = Nothing 
Set rngspc = Nothing 

Set rngGen = Sheets("General Overview").Range("A1:C30").SpecialCells(xlCellTypeVisible) 
Set rngApp = Sheets("Application").Range("A1:E13").SpecialCells(xlCellTypeVisible) 

Set rngspc = Sheets(Sheets("Summary").Cells(i, "P").Value).Range(Sheets("Summary").Cells(i, "Q").Value).SpecialCells(xlCellTypeVisible) 
Set rngspc = Union(rngspc, Sheets(Sheets("Summary").Cells(i, "P").Value).Range(Sheets("Summary").Cells(i, "R").Value).SpecialCells(xlCellTypeVisible)) 

    On Error GoTo 0 

    If rngGen Is Nothing And rngApp Is Nothing And rngspc 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 

'Instantiate Lotus Notes COM's objects. 
Set noSession = CreateObject("Notes.NotesSession") 
Set noDatabase = noSession.GETDATABASE("", "") 

'Make sure Lotus Notes is open and available. 
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL 

'Create the document for the e-mail. 
Set noDocument = noDatabase.CreateDocument 

'Copy the selected range into memory. 
rngGen.Copy 
rngApp.Copy 
rngspc.Copy 

'Retrieve the data from then copied range. 
Set Data = New DataObject 
Data.GetFromClipboard 

'Add data to the mainproperties of the e-mail's document. 
With noDocument 
    .Form = "Memo" 
    .SendTo = vaRecipient 
    .Subject = stSubject 
    'Retrieve the data from the clipboard. 
    .Body = Data.GetText & " " & stMsg 
    .SaveMessageOnSend = True 
End With 

'Send the e-mail. 
With noDocument 
    .PostedDate = Now() 
    .send 0, vaRecipient 
End With 

'Release objects from memory. 
Set noDocument = Nothing 
Set noDatabase = Nothing 
Set noSession = Nothing 

'Activate Excel for the user. 
'Change Microsoft Excel to Excel 
AppActivate "Excel" 

'Empty the clipboard. 
Application.CutCopyMode = False 

MsgBox "The e-mail has successfully been created and distributed.", vbInformation 

End Sub 

Sub Send_Formatted_Range_Data(i As Integer) 
Dim oWorkSpace As Object, oUIDoc As Object 
Dim rnBody As Range 
Dim lnRetVal As Long 
Dim stTo As String 
Dim stCC As String 
Dim stSubject As String 
Const stMsg As String = "An e-mail has been succesfully created and saved." 

Dim rngGen As Range 
Dim rngApp As Range 
Dim rngspc As Range 

stTo = Sheets("Summary").Cells(i, "U").Value 
stCC = Sheets("Summary").Cells(i, "V").Value 
stSubject = "E-Mail For Approval for " + (Sheets("Summary").Cells(i, "A").Value) + " for the Project " + Replace(ActiveWorkbook.Name, ".xls", "") 

'Check if Lotus Notes is open or not. 
lnRetVal = FindWindow("NOTES", vbNullString) 

If lnRetVal = 0 Then 
    MsgBox "Please make sure that Lotus Notes is open!", vbExclamation 
    Exit Sub 
End If 

Application.ScreenUpdating = False 

Set rngGen = Sheets("General Overview").Range("A1:C30").SpecialCells(xlCellTypeVisible) 
Set rngApp = Sheets("Application").Range("A1:E13").SpecialCells(xlCellTypeVisible) 

Set rngspc = Sheets(Sheets("Summary").Cells(i, "P").Value).Range(Sheets("Summary").Cells(i, "Q").Value).SpecialCells(xlCellTypeVisible) 
Set rngspc = Union(rngspc, Sheets(Sheets("Summary").Cells(i, "P").Value).Range(Sheets("Summary").Cells(i, "R").Value).SpecialCells(xlCellTypeVisible)) 
On Error GoTo 0 

If rngGen Is Nothing And rngApp Is Nothing And rngspc 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 

rngGen.Copy 
rngApp.Copy 
rngspc.Copy 

'Instantiate the Lotus Notes COM's objects. 
Set oWorkSpace = CreateObject("Notes.NotesUIWorkspace") 

On Error Resume Next 

Set oUIDoc = oWorkSpace.ComposeDocument("", "mail\xldennis.nsf", "Memo") 
On Error GoTo 0 

Set oUIDoc = oWorkSpace.CurrentDocument 

'Using LotusScript to create the e-mail. 
Call oUIDoc.FieldSetText("EnterSendTo", stTo) 
Call oUIDoc.FieldSetText("EnterCopyTo", stCC) 
Call oUIDoc.FieldSetText("Subject", stSubject) 

'If You experience any issues with the above three lines then replace it with: 
'Call oUIDoc.FieldAppendText("EnterSendTo", stTo) 
'Call oUIDoc.FieldAppendText("EnterCopyTo", stCC) 
'Call oUIDoc.FieldAppendText("Subject", stSubject) 

'The can be used if You want to add a message into the created document. 
Call oUIDoc.FieldAppendText("Body", vbNewLine & stBody) 

'Here the selected range is pasted into the body of the outgoing e-mail. 
Call oUIDoc.GoToField("Body") 
Call oUIDoc.Paste 

'Save the created document. 
Call oUIDoc.Save(True, False, False) 
'If the e-mail also should be sent then add the following line. 
'Call oUIDoc.Send(True) 

'Release objects from memory. 
Set oWorkSpace = Nothing 
Set oUIDoc = Nothing 

With Application 
    .CutCopyMode = False 
    .ScreenUpdating = True 
End With 

MsgBox stMsg, vbInformation 

'Activate Lotus Notes. 
AppActivate ("Notes") 
'Last edited Feb 11, 2015 by Peter Moncera 

End Sub 

Answer 1

код у меня есть для моего Lotus Notes для отправки или дисплея будет показано ниже, вам необходимо изменить его для вашего кода. Для меня activecell.offset (0,11) имеет либо «Отправить», либо «Дисплей», написанный на нем.

'Send the document 
If ActiveCell.Offset(0, 11).Value = "Send" Then 
    MailDoc.SAVEMESSAGEONSEND = True 
    MailDoc.PostedDate = Now() 
    Call MailDoc.Send(0, ActiveCell.Offset(0, 7).Value) 
Else 
    MailDoc.Save True, True, False 
    Set uiMemo = ws.EditDocument(True, MailDoc) 
End If 

EDIT выше код, если вы хотите, возможность отправки/дисплей на основе параметра в таблице. Для вашего конкретного вопроса, то вам нужно изменить этот код, (это может быть стоит извлекать этот код и увидеть, если электронная почта отображается в Lotus Notes):

'Send the e-mail. 
With noDocument 
    .PostedDate = Now() 
    .send 0, vaRecipient 
End With 

Если после удаления выше код, запустить его и его не отображается в Lotus Notes, замените приведенный выше код:

'Send the e-mail. 
Dim uiMemo As Object 
Dim ws As Object 
Set ws = CreateObject("Notes.NotesUIWorkspace") 
noDocument.Save True, True, False 
Set uiMemo = ws.EditDocument(True, noDocument) 

Сообщите мне, как это.