My company has a database that was built for us,and suddenly the module we were using to send emails isnt working anymore. I'm told that security measures have changed, so I'm trying to figure out how to update the settings and make this work again. Unfortunately, I don't really know how half these functions work. Any ideas?
Option Compare Database
Option Explicit
Public Function EmailReceiptByGeneric( _
ByVal strReceipt As String, _
ByVal Recipient As String, _
ByVal ToAdd As String, _
ByVal strProgram As String, _
ByVal Attachment As String, _
ByVal strSubject As String, _
ByVal strMessage As String, _
ByVal strEmailFROM As String, _
ByVal strEmailPWD As String, _
Optional ByVal CC As String) As Boolean
Dim cdoConfig As Object
Dim msgOne As Object
On Error GoTo errHandler
EmailReceiptByGeneric = False
Set cdoConfig = CreateObject("CDO.Configuration")
With cdoConfig.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465 '587 '
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = strEmailFROM
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = strEmailPWD
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
.Update
End With
Set msgOne = CreateObject("CDO.Message")
Set msgOne.Configuration = cdoConfig
msgOne.To = ToAdd
msgOne.FROM = strEmailFROM
msgOne.Subject = strSubject
msgOne.htmlBody = strMessage & "<br/>" & "<br/>" & "<br/>" & "<br/>" & _
strReceipt
msgOne.send
EmailReceiptByGeneric = True
Cleanup:
On Error GoTo 0
On Error Resume Next
exitProc:
Exit Function
errHandler:
EmailReceiptByGeneric = False
MsgBox prompt:="There was an error in the attempt to send email through " & strEmailFROM & "." & vbCrLf & vbCrLf, _
buttons:=vbCritical + vbOKOnly, title:="Unable to Send Email through " & strEmailFROM
Resume Cleanup
Resume
End Function
Public Function ValidateEmailAddress(ByVal strEmailAddress As String) As Boolean
Dim objRegExp As Object
Dim blnIsValidEmail As Boolean
On Error GoTo errHandler
strEmailAddress = Trim(strEmailAddress)
Set objRegExp = CreateObject("VBScript.RegExp")
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "^([a-zA-Z0-9_\-\.]+)@[a-z0-9-]+(\.[a-z0-9-]+)*(\.[a-z]{2,3})$"
blnIsValidEmail = objRegExp.Test(Trim(strEmailAddress))
ValidateEmailAddress = blnIsValidEmail
Cleanup:
On Error GoTo 0
On Error Resume Next
exitProc:
Exit Function
errHandler:
ValidateEmailAddress = False
MsgBox prompt:=Err & ": " & Err.description, buttons:=vbCritical + vbOKOnly, title:="Unable to Validate Email"
Resume Cleanup
Resume
End Function
Public Function ValidateEmailAddress(ByVal strEmailAddress As String) As Boolean
Dim objRegExp As Object
Dim blnIsValidEmail As Boolean
On Error GoTo errHandler
strEmailAddress = Trim(strEmailAddress)
Set objRegExp = CreateObject("VBScript.RegExp")
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "^([a-zA-Z0-9_\-\.]+)@[a-z0-9-]+(\.[a-z0-9-]+)*(\.[a-z]{2,3})$"
blnIsValidEmail = objRegExp.Test(Trim(strEmailAddress))
ValidateEmailAddress = blnIsValidEmail
Cleanup:
On Error GoTo 0
On Error Resume Next
exitProc:
Exit Function
errHandler:
ValidateEmailAddress = False
MsgBox prompt:=Err & ": " & Err.description, buttons:=vbCritical + vbOKOnly, title:="Unable to Validate Email"
Resume Cleanup
Resume
End Function
Public Function ValidatePMT(ByVal dblPmtAmt As Double, ByVal dtPmtDate As Date) As Boolean
On Error GoTo errHandler
If dblPmtAmt = 0 Then
ValidatePMT = False
MsgBox prompt:="Payment amount is required for emailed receipt.", buttons:=vbExclamation + vbOKOnly, title:="Missing Required Payment Amount"
GoTo Cleanup
ElseIf dtPmtDate = #1/31/2099# Then
ValidatePMT = False
MsgBox prompt:="Payment date is required for emailed receipt.", buttons:=vbExclamation + vbOKOnly, title:="Missing Required Payment Date"
GoTo Cleanup
End If
ValidatePMT = True
Cleanup:
On Error GoTo 0
On Error Resume Next
exitProc:
Exit Function
errHandler:
MsgBox prompt:="Unexpected error " & Err.Number & ", " & Err.description, buttons:=vbExclamation + vbOKOnly, title:="Error"
Resume Cleanup
Resume
End Function
Sounds like you upgraded to new Windows...
Microsoft stopped including CDO with Windows, if I'm not mistaken, some 10 years ago.
You can solve this by obtaining the dll file
preferably from your previous Windows system, from the following folder.
Copy the dll to the same location on your new system.
Then you must register the dll on your new system. Open a COMMAND window and navigate to your C:\Windows\System32 folder and run the following command.