Hi,
One user of my database is getting the error below when clicking a save button.
The code behind the button sends an email and I wondered whether this was because the button had been clicked twice which would have caused the code to try running when it already was. However, I have tried to replicate the error and when I click the button twice it still worked for me. The code also works for other users and research so far online suggests this is an outlook issue but I have been unable to find a fix. The code behind the button is below and I have redacted file paths and email addresses.
Any help would be appreciated.
One user of my database is getting the error below when clicking a save button.
The code behind the button sends an email and I wondered whether this was because the button had been clicked twice which would have caused the code to try running when it already was. However, I have tried to replicate the error and when I click the button twice it still worked for me. The code also works for other users and research so far online suggests this is an outlook issue but I have been unable to find a fix. The code behind the button is below and I have redacted file paths and email addresses.
Any help would be appreciated.
Code:
Private Sub SaveFinalAuth_Click()
On Error GoTo ErrorHandler
' Declare variables
Dim olApp As Object
Dim olNameSpace As Object
Dim olMail As Object
Dim SafeItem As Object
Dim Redemption As Object
Const olFormatHTML As Long = 2 ' HTML format constant
Set Redemption = CreateObject("Redemption.RDOSession")
Dim OrgURN As String
Dim GrtURN As String
Dim strFolder As String
Dim strGrantFolder As String
Dim strFile As String
Dim strSaveAs As String
' Declare file path and attachment
Const strParent =
OrgURN = "Org URN " & Me.OrganisationURN
GrtURN = "Grant URN " & Me.GrantURN
strFolder = strParent & OrgURN
strGrantFolder = strFolder & "\" & GrtURN
strFile = strGrantFolder & "\" & "Bank Statement.pdf"
strSaveAs = strGrantFolder & "\" & "Payment ready to pay.msg"
' Ensure the save directory exists; create if necessary
If Dir(strGrantFolder, vbDirectory) = "" Then
MkDir strGrantFolder
End If
' Check if the bank statement file exists
If Dir(strFile) = "" Then
MsgBox "Bank statement does not exist, please check the file", vbOKOnly + vbCritical
Exit Sub
End If
' If final authorisation date is not completed, show a message box
If IsNull(Me.FinalAuthorisationDate) Then
MsgBox "Please add the date", vbOKOnly
Else
' Email message text
Dim msg As String
msg = "Organisation Name: " & Me.OrganisationName & "<p>" _
& "Grant URN " & Me.GrantURN & "<p>" _
& "Payment of " & Format(CCur(Me.PaymentAmount), "Currency") & " was authorised on " _
& Me.FinalAuthorisationDate & " by " & Me.FinalAuthorisation & " and is ready to pay." & "<p>" _
& "Sort Code: " & Me.SortCode & "<p>" _
& "Account No: " & Me.AccountNumber
' Create Outlook session
Set olApp = CreateObject("Outlook.Application")
Set olNameSpace = olApp.GetNamespace("MAPI")
' Create a new mail item
Set olMail = olApp.CreateItem(0) ' 0 = olMailItem
Set SafeItem = CreateObject("Redemption.SafeMailItem")
SafeItem.Item = olMail
' Set sender address, body format, recipient, subject, attach file, and save to file
SafeItem.BodyFormat = olFormatHTML
SafeItem.HTMLBody = msg
SafeItem.To =
SafeItem.Subject = "Payment authorised and ready to pay"
SafeItem.Attachments.Add strFile
SafeItem.Send
SafeItem.SaveAs strSaveAs, 3 ' Save as .msg file
' Disable final authorisation date and set payment status
Me.FinalAuthorisationDate.Enabled = False
Me.PaymentStatus = "Awaiting payment"
' Disable final authorisation save
Me.SaveFinalAuth.Enabled = False
Me.SaveGrant.Enabled = True
' Confirmation message and close
MsgBox "Payment authorised"
Me.Dirty = False
DoCmd.Close
' Clean up
Set SafeItem = Nothing
Set olMail = Nothing
Set olNameSpace = Nothing
Set olApp = Nothing
End If
Exit Sub
ErrorHandler:
Dim ErrMsg As String
ErrMsg = Err.Number & ":" & Err.Description
MsgBox ErrMsg
End Sub