I have a set of records in Microsoft Access that I am trying to send in an Email. The email feature works great. Except a warning message pops up every time a message is ready to send, and the user has to click "Allow" or "Deny" for every email sent. I looked up a workaround, and have been following the tutorial for it:
http://www.everythingaccess.com/tutorials.asp?ID=Outlook-Send-E-mail-Without-Security-Warning.
My problem is that when I put my message in the function it always returns false, and the message fails. Any help would be appreciated.
Dim sendMail As Boolean
Dim strMessage As String
strMessage = Some Message
sendMail = FnSafeSendEmail(![Email Id], "Subject", strMessage)
The entire "FnSafeSendEmail" function can be found in the link provided. These are the parameters though.
Public Function FnSendMailSafe(strTo As String, _
strCC As String, _
strBCC As String, _
strSubject As String, _
strMessageBody As String, _
Optional strAttachments As String) As Boolean
The error, "Object doesn't support this property or method", is thrown on this line of the function.
Dim blnSuccessful As Boolean
blnSuccessful = objOutlook.FnSendMailSafe(strTo, strCC, strBCC, _
strSubject, strMessageBody, _
strAttachmentPaths)
Resolved. I had to disable security checks for macros in Microsoft Outlook's trust center.
Related
I had a file (Theme file) that is stored on Sharepoint and first needed to be downloaded into the temp directory before being loaded applied to word. This worked for a while, but recently I am getting an "access denied error".
I looked around and tested other libraries CreateObject("MSXML2.ServerXMLHTTP.6.0") instead of CreateObject("Microsoft.XMLHTTP").
Interestingly, I don't get the access error message with CreateObject("MSXML2.ServerXMLHTTP.6.0"), but instead it dowloads a page with this error:
[![Screenshot of error message][1]][1]
We can't sign you in
Your browser is currently set to block cookies. You need to allow cookies to use this service.
Cookies are small text files stored on your computer that tell us when you're signed in. To learn how to allow cookies, check the online help in your web browser.
I hope someone has an idea about why this error occurs and how to solve it
Here is the code I use.
Public Sub Download(ByVal URL As String, ByVal FilePath As String, Optional ByVal Overwrite As Boolean = True)
Dim iOverwrite, oStrm
If (IsNull(Overwrite) Or Overwrite) Then
iOverwrite = 2
Else
iOverwrite = 1
End If
Dim HttpReq As Object
'NOTE: There are some issues downloading if not properly logged in! May need to loggin sharepoint again
' https://www.codeproject.com/Questions/1101499/Download-files-from-API-using-vbscript-cmd-prompt
' Based on https://stackoverflow.com/questions/22938194/xmlhttp-request-is-raising-an-access-denied-error
'Set HttpReq = CreateObject("MSXML2.ServerXMLHTTP.6.0")
Set HttpReq = CreateObject("Microsoft.XMLHTTP")
'Set HttpReq = CreateObject("MSXML2.ServerXMLHTTP.3.0")
HttpReq.Open "GET", URL, False, "username", "password"
On Error GoTo ErrorHandler
HttpReq.send
On Error GoTo 0
If HttpReq.Status = 200 Then
Set oStrm = CreateObject("ADODB.Stream")
oStrm.Open
oStrm.Type = 1
oStrm.Write HttpReq.responseBody
oStrm.SaveToFile FilePath, iOverwrite ' 1 = no overwrite, 2 = overwrite
oStrm.Close
End If
Exit Sub
ErrorHandler:
MsgBox "The file could not be downloaded. Verify that you are logged in SharePoint with word and browser.", vbCritical, "Download error"
Debug.Print "Download - Error Downloading file will not be downloaded - Error #: '" & Err.Number & "'. Error description: " & Err.description
End Sub```
[1]: https://i.stack.imgur.com/pdH6v.png
I use import function specifically designed for this. I use Sharepoint Teams site (no user/password can be sent for auth).
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Function downloadSP(ByVal url As String, ByVal nm As String) As Long
DownloadFileFromWeb = URLDownloadToFile(0, url, nm, 0, 0) ' nm includes filename
End Function
In addition. I have to first use an ADO query to the sharepoint library directly before. This ADO connection handles authentication and allows subsequent downloads to location. There probably is another method for sending Teams authentication, but this works just fine. (it's also a great way to get data from SP List/Libraries or even within Excel files)
If testConnected Then downloadSP url, nm
Function testConnected() As Boolean
Dim cn As Object
Dim rs As Object
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.RecordSet")
listGUID = "B3657D15-5F5C-468E-B1C2-784B930FE2E6"
siteURL = "https://azuresite.sharepoint.com/sites/test/"
spSql = "Select * from ['https://azuresite.sharepoint.com/sites/test/SL%20Template/Forms/AllItems.aspx']"
cnStr = "Provider=Microsoft.ACE.OLEDB.16.0;WSS;IMEX=2;RetrieveIds=No;DATABASE=" & siteURL & "; LIST=" & listGUID & ";"
cn.ConnectionString = cnStr
On Error GoTo NotConnected
cn.Open
rs.Open spSql, cn, 1, 2
testConnected = True
cn.Close
Exit Function
NotConnected:
testConnected = False
Exit Function
End Function
So I managed to solve this issue after:
enabling accepting cookies from: https://login.microsoftonline.com/ and our SharePoint sites (also added them in trusted websites)
Clearing the cookies from the history
Use the "Microsoft.XMLHTTP" library which works (other libraries do not seem to work properly still)
I have a button on an Access form that queues up an email and is linked to several fields on the form. Yesterday and this morning the button was working without issue. I have not changed the underlying code or any of the fields in the form, but suddenly the button is returning a Run-time error '2293': Microsoft Access can't send this e-mail message error message when I click it. An example of the code is as follows:
Private Sub cmd_Button_Click()
Dim toaddress As String
Dim ccaddress As String
Dim subject As String
Dim message As String
toaddress = AddMailAddress(toaddress, Nz(Me.cmb_ProjectLead.Column(1), ""))
toaddress = AddMailAddress(toaddress, Nz(Me.cmb_ProjectLead2.Column(1), ""))
ccaddress = AddMailAddress(ccaddress, Nz(Me.cmb_OtherPOC.Column(1), ""))
ccaddress = AddMailAddress(ccaddress, Nz(Me.cmb_OtherPOC2.Column(1), ""))
subject = "text" & me.txb_ProjectName
message = "text" & me.txb_ProjectName & vbnewline & me.txb_ProjectLocation & vbnewline & me.txb_ProjectDescription
DoCmd.SendObject acSendNoObject, , , toaddress, ccaddress, , subject, message, True
End Sub
When I click "debug" on the error message, the line DoCmd.SendObject acSendNoObject, , , toaddress, ccaddress, , subject, message, True is highlighted yellow with a yellow arrow pointed to it.
A few notes that may be helpful:
I'm working on a work issued computer and I have no Admin rights, so changing certain properties are not possible.
I have to use a VPN which has pretty strict security standards.
To reiterate, this worked up until today. In fact for the same record, it worked one moment, and then 30 seconds later did not work.
*Update: the command worked when I stripped everything except the sendobject line and replaced the values with text, i.e.
Private Sub cmd_Button_Click()
DoCmd.SendObject acSendNoObject, , , "toaddress", "ccaddress", , "subject", "message", True
End Sub
When I added just the toaddress and ccaddress back in, I got the 2293 error message.
*Additional info that may help: This form has several "Email To" buttons as well as some "Send Outlook Apppointment To" buttons. They all also worked fine up until this morning, but are now generating various error messages when clicked. They all use the same toaddress, ccaddress, subject, message, etc format as my example here.
The public function that is also linked to these commands is as follows:
Public Function AddMailAddress(address As String, newaddress As String)
If (address = "") And (newaddress = "") Then
Exit Function
End If
If address = "" Then
address = newaddress
Else
If Not newaddress = "" Then
If VBA.Right(address, 1) = ";" Then
address = address & newaddress
Else
address = address & ";" & newaddress
End If
End If
End If
AddMailAddress = address
End Function
Anytime i get this error, it has nothing to do with the the database or the code, it is simply due to the fact that i have an outlook item open that is currently gettin edited that i have forgotten about.
Access cannot create a new Outlook item while there is currently an Outlook item open in edit mode.
Close down any Outlook items open in edit mode and try again.
The email buttons now work after closing out the database and re-opening it. Still no clue why it gave me run-time errors before. If it happens again, I'll be back to add more insight.
I have some VBA code that takes the various email parts as inputs and creates an email message in Lotus Notes, and sends it from a group mailbox. It sends the email out to a recipient and CC recipients, and then leaves a copy of the message in the "Sent" box of a group email account. I think the sent message in that box is sort of a dummy, as it is perhaps not the exact message as it was sent.
This works, and sends the message to the SendTo, and to the first CC address. However, if I have a second CC address, it turns the ending of the second address into gibberish. For example, if the SendTo is "mike#someemail.com", and the CC is "john#someemail.com, jim#someemail.com"... in the Sent box it appears to have sent it to mike#someemail.com, and CC to john#someemail.com and jim#someemail.com. However, the actual mail is only received by john, and the CC looks like this: "john#someemail.com, jim#pps.rte_to_v" and jim never gets the message.
On another message, the second CC ends up being jim#vwall11.com. I haven't found a pattern to the gibberish it puts at the end of the CC line instead of the correct address. It took us awhile to learn about the problem since it looks correct in the Sent mailbox.
Here's the code I'm using. I'm changing the server names, etc, but all relevant code is intact.
Private Sub TestEmail()
Call EmailFromADT("mike#somemail.com", "john#somemail.com, jim#somemail.com", "test subject", "test message", _
"", "", "", "")
End Sub
Function EmailFromADT(strSendTo As String, strCopy As String, strSubject As String, _
strText1 As String, strText2 As String, strText3 As String, _
strText4 As String, strText5 As String)
Dim notesdb As Object
Dim notesdoc As Object
Dim notesrtf As Object
Dim notessession As Object
Dim i As Integer
Set notessession = CreateObject("Notes.Notessession")
''''''''Group Mailbox'''''''''''''''''''''''''''''''''''''''''''''''''
Set notesdb = notessession.GetDatabase("servername", "mailin\notesaddr.nsf")
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Open the mail database in notes
If notesdb.IsOpen = True Then
'Already open for mail
Else
notesdb.OPENMAIL
End If
Set notesdoc = notesdb.CreateDocument
Call notesdoc.ReplaceItemValue("Subject", strSubject)
Set notesrtf = notesdoc.CreateRichTextItem("body")
Call notesrtf.AppendText(strText1 & vbCrLf & strText2 & vbCrLf & strText3 & vbCrLf & strText4 & vbCrLf & strText5)
notesdoc.SendTo = strSendTo
notesdoc.CopyTo = strCopy
notesdoc.from = UserName()
''''''''Group Mailbox'''''''''''''''''''''''''''''''''''''''''''''''''
notesdoc.principal = "Group Team"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
notesdoc.BlindCopyTo = strBCC
Call notesdoc.Save(True, False)
notesdoc.SaveMessageOnSend = True
Call notesdoc.Send(False, strSendTo)
Set notessession = Nothing
End Function
To have multiple values in an item in a Document, you need to use an array.
Try this:
dim varCopyTo as Variant
varCopyTo = Split( strCopyTo, "," )
call notesDoc.Replaceitemvalue( "CopyTo", varCopyTo )
You could also write notesDoc.CopyTo=varCopyTo, but it is better (more secure, slightly better performance) to use ReplaceItemValue.
In addition you should add Call notesDoc.ReplaceItemValue("Form", "Memo" ) after creating the document, so that the server/client does not have to "guess" what kind of document you are creating.
notesdoc.CopyTo wants an array, not a comma-delimted string on the right hand side of the assignment. Each element in the array should be an individual address. By passing in a comma-delimited string, you're essentially passing in a single invalid address as far as Notes and Domino are concerned. I'm not entirely sure why that's being transformed in the peculiarly random way that it is, but I am sure it's definitely not going to be right that way.
And better than using the shorthand form (notesdoc.CopyTo = ...) for this code, you should probably be using Call notesdoc.ReplaceItemValue, like you do with the Subject, but passing in an array there.
I have a an Access App that requires the user to enter their Windows domain user and password to enter. I have used the following VBA code to accomplish this:
Function WindowsLogin(ByVal strUserName As String, ByVal strpassword As String, ByVal strDomain As String) As Boolean
'Authenticates user and password entered with Active Directory.
On Error GoTo IncorrectPassword
Dim oADsObject, oADsNamespace As Object
Dim strADsPath As String
strADsPath = "WinNT://" & strDomain
Set oADsObject = GetObject(strADsPath)
Set oADsNamespace = GetObject("WinNT:")
Set oADsObject = oADsNamespace.OpenDSObject(strADsPath, strDomain & "\" & strUserName, strpassword, 0)
WindowsLogin = True 'ACCESS GRANTED
ExitSub:
Exit Function
IncorrectPassword:
WindowsLogin = False 'ACCESS DENIED
Resume ExitSub
End Function
I notice that sometimes when the information is entered correctly, access is denied. I tried to debug once and it gave the error: "The network path was not found.
" on the Set oADsObject = oADsNamespace.OpenDSObject) line.
Not sure why this occurs sometimes. Is it better to convert to LDAP instead? I have tried but can't construct the LDAP URL correctly.
If the user is already authenticated via their Windows login, why make them enter the details again?
If you need to know which user is logged in, you can get the username very easily by the following function:
Declare Function IGetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal sBuffer As String, lSize As Long) As Long
Function GetUserName() As String
On Error Resume Next
Dim sBuffer As String
Dim lSize As Long
Dim x As Long
sBuffer = Space$(32)
lSize = Len(sBuffer)
x = IGetUserName(sBuffer, lSize)
GetUserName = left$(sBuffer, lSize - 1)
End Function
In GxP environment it is additionally needed to enter at least password. It doesn't matter if You are logged to Windows, You need to confirm it again.
I have a VBA function that initializes a lotus notes session, creates a document and mails it. It also accepts as an optional parameter a NotesRichTextItem which I append to the body of the email.
However, I am getting the error message "All objects must be from the same session". How do I 'import' this NotesRichTextItem into my session?
Edit-Code added
Sub SendLotusMail(SubjTxt As String, _
BodyTxt As String, _
EmailTo As String, _
EmailCC As String, _
AutoSend As Boolean, _
Attach As String, _
ReportTitle As String, _
Optional AppendToBody As NotesRichTextItem = Null)
On Error GoTo EH
NtSession.Initialize
OpenMailDb ReportTitle
Set NtDoc = Ntdb.CreateDocument
NtDoc.AppendItemValue "Form", "Memo"
NtDoc.AppendItemValue "SendTo", EmailTo
NtDoc.AppendItemValue "CopyTo", EmailCC
NtDoc.AppendItemValue "Subject", SubjTxt
Set NtBodyRT = NtDoc.CreateRichTextItem("Body")
NtDoc.AppendItemValue "Body", NtBodyRT
If Attach <> "" Then NtBodyRT.EmbedObject EMBED_ATTACHMENT, "", Attach, "Attachment"
NtBodyRT.AppendText BodyTxt
'This next line throws the error "All objects must be from the same session"
NtBodyRT.AppendRTItem AppendToBody
Edit-Solution found
I don't like it very much, but I got around all these issues by passing the RichTextItem object, it's parent NotesDocument, and it's parent's parent NotesSession to this function. So, now I'm calling this procedure with 3 optional objects instead of 1. Hooray.
Edit-New Solution found
Well, the previous solution was causing me problems, so until I find (or someone suggests) a workaround, I'll just use some custom email procedures for the reports that require it. It does duplicate some code, but not significantly.
The issue may be the fact that the NtSession object is being re-initialized in your sub. If the calling routine sends in a rich text item, I am assuming it must have created and initialized a NotesSession as well. If that's the case, you would want your code to re-use that same session. It looks like NtSession is a global - if that's the case, you could:
Enforce that the calling routing always have initialized that global session;
Optionally pass in a NtSession object as an argument (and your code can check if that object is null before creating and initializing its own session); or
Before calling Initialize, check if NtSession already is initialized - to do that, you may be able to check an attribute and see if the object throws on error (non-tested code):
function isNotesSessionInitialized (ns)
on error goto err
dim sUser
sUser = ""
sUser = ns.commonUserName
err:
if (sUser = "") then
return false
else
return true
end if
end function
It would help to see some code here. I'll make a guess at what is happening, though.
In your VBA function, you'll need to create a new NotesRichTextItem object within your email. For instance:
Dim docMail as New NotesDocument(db)
Dim rtBody as New NotesRichTextItem(docMail, "Body")
Call rtBody.AppendRTItem(myRTparameter)
I imagine that should work without an error.
(I'm writing this to close out my question)
I've gotten around this issue by just having separate email procs for the reports that require custom setups. Yes, there is some duplication of code, but it's far better than the behemoth I was about to make.