I am trying to run the code below and I see the error: "Could not execute code stage: Parameter count mismatch.". I know that it means that somewhere the parameter is missing but I am really unable to localize the line. Can anyone help me with that ?
Dim SaveIt As Boolean
Dim Maildb As Object
Dim UserName As String
Dim MailDoc As Object
Dim AttachME As Object
Dim Session As Object
Dim EmbedObj As Object
Dim DataBaseName As Object
Dim ServerName As Object
Dim DataBase As Object
Session = CreateObject("Notes.NotesSession")
UserName = Session.UserName
DataBaseName = ""
ServerName = ""
Maildb = Session.GetDataBase(ServerName, DataBaseName)
If Maildb.ISOPEN = True Then
'Already open for mail
Else
Maildb.OPENMAIL
End If
'Set up the new mail document
MailDoc = Maildb.CREATEDOCUMENT
MailDoc.Form ("Memo")
MailDoc.SendTo = Recipient
MailDoc.Subject = Subject
MailDoc.Body = Body
MailDoc.Save(True, True)
'MailDoc.SAVEMESSAGEONSEND = True
If Attachment <> "" Then
AttachME = MailDoc.CREATERICHTEXTITEM("Attachment")
EmbedObj = AttachME.EMBEDOBJECT(1454, "", Attachment, "Attachment")
MailDoc.CREATERICHTEXTITEM ("Attachment")
End If
'Send the document
MailDoc.PostedDate=Now()
MailDoc.SEND(False, Recipient)
'Clean Up
Maildb = Nothing
MailDoc = Nothing
AttachME = Nothing
Session = Nothing
EmbedObj = Nothing
Related
I have a script that the company has been using for a while and no issues.
We switched from Outlook 2010 to Outlook 2016.
The script fills in the right information but when clicking on the send button, it bounces back to the email user's inbox saying "undelivered" and
"This message could not be sent. You do not have the permission to send the message on behalf of the specified user."
I have verified that the user has full access to that user mailbox.
Sub ForwardA()
Dim objMail As Outlook.MailItem
Dim GetSMTPAddress As String, s As String, piece As String, i As Long, j As Long
Dim olkSnd As Outlook.AddressEntry, olkExu As Outlook.ExchangeUser
Dim olNS As Outlook.NameSpace
Set olNS = Application.GetNamespace("MAPI")
Set objITEM = GetCurrentItem()
Set olkSnd = objITEM.Sender
If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
Set olkExu = olkSnd.GetExchangeUser
GetSMTPAddress = olkExu.PrimarySmtpAddress
Else
GetSMTPAddress = objITEM.SenderEmailAddress
End If
Set olkSnd = Nothing
Set olkExu = Nothing
s = GetSMTPAddress
i = InStr(s, "#")
j = InStrRev(s, ".")
piece = UCase(Mid(s, i + 1, j - i - 1))
If piece = "--------" Then
piece = InputBox("----- - Enter New Company name")
End If
'MsgBox piece
Set objMail = objITEM.Forward
objMail.SentOnBehalfOfName = "orders#------.com"
objMail.To = ""
objMail.Subject = piece & ": CONFIRMATION RECEIPT OF "
objMail.BCC = ""
objMail.SendUsingAccount = olNS.Accounts.Item(1)
objMail.Display
Set objITEM = Nothing
Set objMail = Nothing
MoveToCustomerPO
Is there a way to get the attachment to appear with the correct icon when you add it through the macro inside body of email?. My issue is that when attaching a .pdf or .xlsx through my lotus notes macro it appears as a generic grey icon rather than the .pdf or .xlsx icon. I tried only saving a draft of the email and it shows the .pdf or .xlsx icon but when I switched my macro to display the email it shows a generic grey one.
Private Maildb As Object ' The Mail Database
Private Username As String ' The current users notes name
Private MailDbName As String ' The Current Users Notes mail database name
Private MailDoc As Object 'the mail document itself
Private AttachME As Object ' The attachement richtextfile object
Private session As Object ' The Notes Seesion
Private EmbedObj As Object ' The Embedded Object (attachment)
Private ws As Object 'Lotus Workspace
Private objProfile As Object
Private rtiSig As Object, rtitem As Object, rtiNew As Object
Private uiMemo As Object
Public strToArray() As String, strCCArray() As String, strBccArray() As String
'
Public Function f_SendNotesEmail(strAtask As String, strTo As String, strCC As String, strBcc As String, _
strObject As String, strBody As String, blnSaveIt As Boolean) As Boolean
Dim strSignText As String, strMemoUNID As String
Dim intSignOption As Integer
Set session = CreateObject("Notes.NotesSession")
Set ws = CreateObject("Notes.NotesUIWorkspace")
Username = session.Username
MailDbName = Left$(Username, 1) & Right$(Username, (Len(Username) - InStr(1, Username, " "))) & ".nsf"
On Error GoTo err_send
Set Maildb = session.GETDATABASE("", MailDbName)
If Maildb.IsOpen = False Then Maildb.OPENMAIL
Set MailDoc = Maildb.CREATEDOCUMENT
MailDoc.Form = "Memo"
MailDoc.SendTo = strTo
MailDoc.CopyTo = strCC
'MailDoc.BlindCopyTo = strBcc
MailDoc.subject = strObject
MailDoc.SAVEMESSAGEONSEND = blnSaveIt
Set objProfile = Maildb.GetProfileDocument("CalendarProfile")
intSignOption = objProfile.GetItemValue("SignatureOption")(0)
strSignText = objProfile.GetItemValue("Signature")(0)
'Signature or not
If intSignOption = 0 Then
MailDoc.body = strBody
Else
'Insert a Signature
Select Case intSignOption
Case 1: 'Plain text Signature
Set rtitem = MailDoc.CreateRichTextItem("Body")
Call rtitem.AppendText(strBody)
Call rtitem.AppendText(Chr(10)): Call rtitem.AppendText(Chr(10))
Call rtitem.AppendText(strSignText)
Case 2, 3: 'Document or Rich text
'Open memo in ui
Set uiMemo = ws.EditDocument(True, MailDoc)
Call uiMemo.GotoField("Body")
'Check if the signature is automatically inserted
If objProfile.GetItemValue("EnableSignature")(0) <> 1 Then
If intSignOption = 2 Then
Call uiMemo.Import(f_strSignatureType(strSignText), strSignText)
Else
Call uiMemo.ImportItem(objProfile, "Signature_Rich")
End If
End If
Call uiMemo.GotoField("Body")
'Save the mail doc
strMemoUNID = uiMemo.Document.UniversalID
uiMemo.Document.MailOptions = "0"
Call uiMemo.Save
uiMemo.Document.SaveOptions = "0"
Call uiMemo.Close
Set uiMemo = Nothing
Set MailDoc = Nothing
'Get the text and the signature
Set MailDoc = Maildb.GetDocumentByUNID(strMemoUNID)
Set rtiSig = MailDoc.GetFirstItem("Body")
Set rtiNew = MailDoc.CreateRichTextItem("rtiTemp")
Call rtiNew.AppendText(strBody)
Call rtiNew.AppendText(Chr(10)): Call rtiNew.AppendText(Chr(10))
strFile = Dir(strPath & "*.xlsx")
Do While Len(strFile) > 0
'.AppendText ("hiui")
'Set AttachME = MailDoc.CreateRichTextItem("ATTACHMENT" & strFile) 'attaching as attachments not inside body
Call rtiNew.embedobject(1454, "", strPath & strFile, "ATTACHMENT")
'.AddNewLine (1)
strFile = Dir
Loop
Call rtiNew.AppendRTItem(rtiSig)
'Remove actual body to replace it with the new one
Call MailDoc.RemoveItem("Body")
Set rtitem = MailDoc.CreateRichTextItem("Body")
Call rtitem.AppendRTItem(rtiNew)
End Select
End If
MailDoc.Save False, False
Set uiMemo = ws.EditDocument(True, MailDoc)
f_SendNotesEmail = True
label_end:
Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set session = Nothing
Set EmbedObj = Nothing
Set rtitem = Nothing
Set uiMemo = Nothing
Set rtiSig = Nothing
Set rtiNew = Nothing
Set ws = Nothing
Exit Function
err_send:
f_SendNotesEmail = False
GoTo label_end
End Function
Showing the correct icon only works when done in the frontend. Whenever you use LotusScript to attach something in the backend, the symbol will always be the default one. There are workarounds with XML- Export / Import, but usually they are not feasible.
Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 5 years ago.
Improve this question
So I've been trying to come up with a macro to send a emails with a attachment through a spread sheet.
For example:
mailto:emailadress#email.com?subject=Sample12345
If I use the above string in excel it will prompt my default email client to create the email with the example email address and sample subject line.
I've used it for a while and it might be simple string but, its super helpful when I can manipulate it in excel.
Example of string manipulating in a cell : =HYPERLINK(A1&A2&A3&A4&A5&A6)
I would like to morph the same concept but ,in a macro so I can send it to multiple people with a different email address.
The problems :
I have Lotus Notes Social Edition Home as default email client - Release 9.0.1
Example of what I would like to accomplish :
Mailto: sampleemailadress#email.com (from a specific cell value in excel "=Sheet1!A1")
CC:( from a specific cell value in excel "=Sheet1!A2" )
Body: ( from a specific Range in excel "=Sheet2!A1:B24" )
Attachment : (from a specific cell value in excel "=Sheet1!A1") ....Value in Cell - " C:\Users\User1\Downloads\sampleexcelsheet.xlsm "
Let me know your thoughts.
Thank you!.
This is a more bare-bones way to send an email. It works for me, I have Lotus Notes 9 so hopefully it also works for your version.
Sub Send_Email_via_Lotus()
'Send an e-mail & attachment using Lotus Not(s)
'Original Code by Nate Oliver (NateO)
'Declare Variables for file and macro setup
'Dim AVal As Variant
Dim UserName As String, MailDbName As String, ccRecipient As String, Recipient As String
Dim Maildb As Object, MailDoc As Object, Session As Object
Dim email As String, bodyText As String, clientRef As String, bodyRng As Range, emailBody As String
Dim notesUIDoc As Object
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' Open and locate current LOTUS NOTES User
Set Session = CreateObject("Notes.NotesSession")
UserName = Session.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set Maildb = Session.GETDATABASE("", MailDbName)
If Maildb.IsOpen = True Then
Else
Call Maildb.OPENMAIL
End If
Recipient = Sheets("Sheet1").Range("A1").Value
ccRecipient = Sheets("Sheet1").Range("A2").Value
Set bodyRng = Sheets("Sheet2").Range("A1:B24")
Dim cel As Range
For Each cel In bodyRng
emailBody = emailBody & " " & cel.Value
Next cel
' Create New Mail and Address Title Handlers
Set MailDoc = Maildb.CreateDocument
MailDoc.Form = "Memo"
MailDoc.sendTo = Recipient
MailDoc.CopyTo = ccRecipient
MailDoc.Subject = "SUBJECT HERE"
'Displays email message without sending; user needs to click Send
Set workspace = CreateObject("Notes.NotesUIWorkspace")
Set notesUIDoc = workspace.EditDocument(True, MailDoc)
'Call notesUIDoc.FieldClear("Body") '' This line will clear the ENTIRE body, including signature.
Call notesUIDoc.gotofield("Body") 'This should just Go to the body, keeping your signature.
Call notesUIDoc.FieldAppendText("Body", emailBody)
Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set Session = Nothing
Set EmbedObj1 = Nothing
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
'End If
Exit Sub
errorhandler1:
Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set Session = Nothing
Set EmbedObj1 = Nothing
Application.EnableEvents = True
End Sub
Note that the Attachment part is lacking, I'll keep searching for that but this should get you started, and see how you can use the variables to set the body, recipients, etc. (There may be unnecessary variables too, I didn't quite check those).
NOTE: Please review the For Each cel in bodyRng loop, as I don't quite know how you want the body set up.
Sub NotesEmailrun()
Dim UserName As String, MailDbName As String, ccRecipient As String, attachment1 As String
Dim Maildb As Object, MailDoc As Object, AttachME As Object, Session As Object
Dim EmbedObj1 As Object
With Application
.ScreenUpdating = False
.DisplayAlerts = False
Set Session = CreateObject("Notes.NotesSession")
UserName = Session.UserName
MailDbName = _
Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set Maildb = Session.GETDATABASE("", "")
If Maildb.IsOpen = True Then
Else
Maildb.OpenMail
End If
Set MailDoc = Maildb.CreateDocument
MailDoc.Form = "Memo"
MailDoc.Sendto = Sheets("Sheet1").Range("A1").Value
MailDoc.CopyTo = Sheets("Sheet1").Range("A2").Value
MailDoc.Subject = Sheets("Sheet1").Range("A5").Value
MailDoc.body = Sheets("Sheet2").Range("A1:H24")
MailDoc.SaveMessageOnSend = True
attachment1 = "C:\Users\Username\Desktop\folder1\time.txt"
If attachment1 <> "" Then
On Error Resume Next
Set AttachME = MailDoc.CREATERICHTEXTITEM("attachment1")
Set EmbedObj1 = AttachME.EmbedObject(1454, "", attachment1)
On Error Resume Next
End If
attachment2 = "C:\Users\username\Desktop\folder2\time2.txt"
If attachment2 <> "" Then
On Error Resume Next
Set AttachME = MailDoc.CREATERICHTEXTITEM("attachment2")
Set EmbedObj1 = AttachME.EmbedObject(1454, "", attachment2)
On Error Resume Next
End If
Set workspace = CreateObject("Notes.NotesUIWorkspace")
Call workspace.EditDocument(True, MailDoc).GOTOFIELD("Body")
Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set Session = Nothing
Set EmbedObj1 = Nothing
.ScreenUpdating = True
.DisplayAlerts = True
End With
errorhandler1:
Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set Session = Nothing
Set EmbedObj1 = Nothing
End Sub
Im trying to download attachment from certain Lotus Notes e-mails. The code below works but it goes in infinite loop (code execution never ends after the procedure) after saving all required files. Something is wrong with Do until command I guess. Would appreaciate some help in fixing this issue.
Sub Test2Dobre()
Dim sess As Object
Dim db As Object
Dim view As Object
Dim doc As Object
Dim docNext As Object
Dim mailServer As String
Dim mailFile As String
Dim fld1 As String
Dim strSQL As String
Const stPath As String = "C:\Users\kuckam\Desktop\test notes\"
Const EMBED_ATTACHMENT As Long = 1454
Const RICHTEXT As Long = 1
Dim vaItem As Variant
Dim vaAttachment As Variant
Set sess = CreateObject("Notes.NotesSession")
'Call sess.Initialize(Password)
Dim objADOConnection As Object
Set objADOConnection = CreateObject("ADODB.Connection")
'to get your mail db:
mailServer = sess.GetEnvironmentString("MailServer", True)
mailFile = sess.GetEnvironmentString("MailFile", True)
Set db = sess.GetDatabase(mailServer, mailFile)
'Get Inbox folder:
Set view = db.GetView("($Inbox)")
'Loop through all documents in Inbox:
Set doc = view.GetFirstDocument
Do Until doc Is Nothing
Set docNext = view.GetNextDocument(doc)
If doc.HasEmbedded And doc.GetItemValue("From")(0) = "<Protokoly.warszawa#linde-mh.pl>" Then
MsgBox doc.GetItemValue("subject")(0)
'MsgBox doc.GetItemValue("From")(0)
'Check if the document has an attachment or not.
Set vaItem = doc.GetFirstItem("Body")
If vaItem.Type = RICHTEXT Then
For Each vaAttachment In vaItem.EmbeddedObjects
If vaAttachment.Type = EMBED_ATTACHMENT Then
'Save the attached file into the new folder and remove it from the e-mail.
With vaAttachment
.ExtractFile stPath & vaAttachment.Name
' .Remove
End With
End If
Next vaAttachment
End If
End If
Set doc = docNext
Loop
End Sub
EDIT:
Posting working code:
Function ADOExecSQL(strSQL As String)
ADOExecSQL = 1
On Error GoTo ERROR_FUNCTION
If ADODbConnect() = 0 Then GoTo ERROR_FUNCTION
cnConn.Execute strSQL
EXIT_FUNCTION:
Exit Function
ERROR_FUNCTION:
ADOExecSQL = 0
GoTo EXIT_FUNCTION
End Function
Sub Test2Dobre()
Dim sess As Object
Dim db As Object
Dim view As Object
Dim doc As Object
Dim docNext As Object
Dim mailServer As String
Dim mailFile As String
Dim fld1 As String
Dim strSQL As String
Const stPath As String = "C:\Users\kuckam\Desktop\test notes\"
Const EMBED_ATTACHMENT As Long = 1454
Const RICHTEXT As Long = 1
Dim vaItem As Variant
Dim vaAttachment As Variant
Set sess = CreateObject("Notes.NotesSession")
'Call sess.Initialize(Password)
Dim objADOConnection As Object
Set objADOConnection = CreateObject("ADODB.Connection")
'to get your mail db:
mailServer = sess.GetEnvironmentString("MailServer", True)
mailFile = sess.GetEnvironmentString("MailFile", True)
Set db = sess.GetDatabase(mailServer, mailFile)
'Get Inbox folder:
Set view = db.GetView("($Inbox)")
view.AutoUpdate = False
'Loop through all documents in Inbox:
Set doc = view.GetFirstDocument
Do Until doc Is Nothing
Set docNext = view.GetNextDocument(doc)
'If doc.HasEmbedded And doc.GetItemValue("From")(0) = "<Protokoly.warszawa#linde-mh.pl>" Then
'If doc.GetItemValue("From")(0) = "<Protokoly.warszawa#linde-mh.pl>" Then
'MsgBox doc.GetItemValue("subject")(0)
'MsgBox doc.GetItemValue("From")(0)
'Check if the document has an attachment or not.
Set vaItem = doc.GetFirstItem("Body")
On Error GoTo Line1
If vaItem.Type = RICHTEXT And doc.GetItemValue("From")(0) = "<Protokoly.warszawa#linde-mh.pl>" Then
For Each vaAttachment In vaItem.EmbeddedObjects
If vaAttachment.Type = EMBED_ATTACHMENT Then
'Save the attached file into the new folder and remove it from the e-mail.
With vaAttachment
.ExtractFile stPath & vaAttachment.Name
' .Remove
End With
End If
'Save the e-mail in order to reflect the deleting of the attached file.
'(A more sophisticated approach may be considered if several e-mails have
'several attachments in order to avoid a repeately saving of one e-mail.)
doc.Save True, False
Next vaAttachment
End If
'End If
'Call Attachment.ExtractFile("C:\Users\kuckam\Desktop\test notes")
'Call doc.PutInFolder("C:\Users\kuckam\Desktop\test notes")
Set doc = docNext
Loop
'Release objects from memory.
Set docNext = Nothing
Set doc = Nothing
Set view = Nothing
Set sess = Nothing
Set db = Nothing
Set objADOConnection = Nothing
Set vaItem = Nothing
Line1:
End Sub
I have a list of email ids in an excel sheet and I would like to fetch their names from Outlook Contact List using VBA script. I have searched online but did not find something which is working for me?
How this can be done?
The following works. The code below fetches the name corresponding to "abc#xyz.com"
You could use an array and compare I think. Not sure if there is a better way.
Public Sub getName()
Dim contact As Object
Dim AL As Object
Dim outApp As Object
Set outApp = CreateObject("Outlook.Application")
'Logon
outApp.Session.Logon
'Get contact from Outlook
Set AL = outApp.Session.GetDefaultFolder(10)
For Each contact In AL.Items
'iterate through each contact and compare
If contact.Email1Address = "abc#xyz.com" Then
Debug.Print (contact.FullName)
End If
Next contact
outApp.Session.Logoff
outApp.Quit
'cleanup
Set outApp = Nothing
Set GAL = Nothing
End Sub
Will the code below help?
It's worked on: My Name <My.Name#MyCompany.co.uk>, My Name, MyName#Gmail.Com
Sub Test()
Dim rEmails As Range
Dim rEmail As Range
Dim oOL As Object
Set oOL = CreateObject("Outlook.Application")
Set rEmails = Sheet1.Range("A1:A3")
For Each rEmail In rEmails
rEmail.Offset(, 1) = ResolveDisplayNameToSMTP(rEmail.Value, oOL)
Next rEmail
End Sub
' Author: Sue Mosher - updated by D.Bartrup-Cook to work in Excel late binding.
Public Function ResolveDisplayNameToSMTP(sFromName, OLApp As Object) As String
Select Case Val(OLApp.Version)
Case 11 'Outlook 2003
Dim oSess As Object
Dim oCon As Object
Dim sKey As String
Dim sRet As String
Set oCon = OLApp.CreateItem(2) 'olContactItem
Set oSess = OLApp.GetNameSpace("MAPI")
oSess.Logon "", "", False, False
oCon.Email1Address = sFromName
sKey = "_" & Replace(Rnd * 100000 & Format(Now, "DDMMYYYYHmmss"), ".", "")
oCon.FullName = sKey
oCon.Save
sRet = Trim(Replace(Replace(Replace(oCon.email1displayname, "(", ""), ")", ""), sKey, ""))
oCon.Delete
Set oCon = Nothing
Set oCon = oSess.GetDefaultFolder(3).Items.Find("[Subject]=" & sKey) '3 = 'olFolderDeletedItems
If Not oCon Is Nothing Then oCon.Delete
ResolveDisplayNameToSMTP = sRet
Case 14 'Outlook 2010
Dim oRecip As Object 'Outlook.Recipient
Dim oEU As Object 'Outlook.ExchangeUser
Dim oEDL As Object 'Outlook.ExchangeDistributionList
Set oRecip = OLApp.Session.CreateRecipient(sFromName)
oRecip.Resolve
If oRecip.Resolved Then
Select Case oRecip.AddressEntry.AddressEntryUserType
Case 0, 5 'olExchangeUserAddressEntry & olExchangeRemoteUserAddressEntry
Set oEU = oRecip.AddressEntry.GetExchangeUser
If Not (oEU Is Nothing) Then
ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
End If
Case 10, 30 'olOutlookContactAddressEntry & 'olSmtpAddressEntry
ResolveDisplayNameToSMTP = oRecip.AddressEntry.Address
End Select
Else
ResolveDisplayNameToSMTP = sFromName
End If
Case Else
'Name not resolved so return sFromName.
ResolveDisplayNameToSMTP = sFromName
End Select
End Function