VBA for Voting Buttons in Access

[ramez75]

Hi,

I have a form that I use in my access database. I choose the names of the individuals and hit the send button. The button has the below

DoCmd.SendObject acSendNoObject, stDocName, acFormatXLS, strEmails, , , stSubject, stText

I want to add to my vba code a voting option that's say "Review with comments and Review with NO comments. Can I do that? as I send a lot of emails from the database and have to set it manually everytime

Any guidance on this is greatly appreciated

RB

 

[ramez75]

So below is the current code I have been using

Private Sub cmdEmailNot_Click()
On Error GoTo Err_cmdEmailNot_Click
Dim stText As String
Dim stSubject As String
Dim stDocName As String
Dim i As Integer
Dim strIN As String
Dim strIN1 As String
Dim strSql As String
Dim strEmails As Variant
Dim varItem As Variant
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim varText As String
Dim varText1 As String
Dim varText2 As Date
Dim varText3 As String
Dim varText4 As Variant
Set db = CurrentDb
Set rst = db.OpenRecordset("tblEmailtrackerlogCAPA", dbOpenDynaset)
strSql = "SELECT * FROM tblSecurity"
'Build the IN string by looping through the listbox
For i = 0 To lstemails.ListCount - 1
If lstemails.Selected(i) Then
strIN = strIN & "'" & lstemails.Column(0, i) & "',"
strIN1 = strIN1 & "'" & lstemails.Column(1, i) & "',"
End If
Next i

strEmails = strIN
varText = CAPANo
If Frame16.Value = 1 Then
varText1 = "Action Required - QUALITY USE ONLY"
ElseIf Frame16.Value = 2 Then
varText1 = "Review for Closure"
ElseIf Frame16.Value = 3 Then
varText1 = "CAPA Approved / Closed - QUALITY USE ONLY"
End If
varText2 = Now
varText3 = Nz(DLookup("Nameofuserid", "tblSecurity", "[UserID]=" & Chr(34) & Me.userlogin & Chr(34)), "")
varText4 = strIN
'varText4 = strIN1
rst.AddNew
rst!CAPANo = varText
rst!notification = varText1
rst!DateTime = varText2
rst!sentby = varText3
rst!sentto = varText4
rst.Update
rst.Close
db.Close

If Frame16.Value = 1 Then
stSubject = "Action Required for " & Me.CAPANo
stText = "CAPA Champion," & Chr$(13) & Chr$(13) & _
"This email notification is being sent to you as a reminder that ::XX:: days has passed with no activity shown for " & Me.CAPANo & Chr$(13) & Chr$(13) & _
"Thank you" & Chr$(13) & Chr$(13) & "Quality Department" & Chr$(13) & "This is an automated message."
stDocName = "Empty_Report"
DoCmd.SendObject acSendNoObject, stDocName, acFormatXLS, strEmails, , , stSubject, stText

ElseIf Frame16.Value = 2 Then
stSubject = "Closure Notification for " & Me.CAPANo
stText = "8D/CAPA Reviewers," & Chr$(13) & Chr$(13) & _
Me.CAPANo & " (use link to access the folder) is ready for review. You will have till " & DateAdd("d", 14, Date) & _
" to respond with any concerns. Please use the enabled voting option on this email. " & Chr$(13) & Chr$(13) & _
"Click on the gray bar and you will be prompted with a voting options." & Chr$(13) & _
"- Reviewed with NO comments" & Chr$(13) & _
"- Reviewed with comments" & Chr$(13) & Chr$(13) & _
"NOTE: Please use the option to send comments to all reviewers and 8D/CAPA Champion with the return message if you have any concerns regarding the CAPA" & Chr$(13) & Chr$(13) & _
"Thank you" & Chr$(13) & Chr$(13) & "Quality Department." & Chr$(13) & "This is an automated message."
stDocName = "Empty_Report"
DoCmd.SendObject acSendNoObject, stDocName, acFormatXLS, strEmails, , , stSubject, stText
ElseIf Frame16.Value = 3 Then
stSubject = "Approved / Closed Notification for " & Me.CAPANo
stText = "CAPA Champion," & Chr$(13) & Chr$(13) & _
"Your CAPA has been reviewed and approved. CAPA is considered closed." & Chr$(13) & Chr$(13) & _
"Thank you" & Chr$(13) & Chr$(13) & "Quality Department." & Chr$(13) & "This is an automated message."
stDocName = "Empty_Report"
DoCmd.SendObject acSendNoObject, stDocName, acFormatXLS, strEmails, , , stSubject, stText

End If
'Clear listbox selection after emailing
For Each varItem In Me.lstemails.ItemsSelected
Me.lstemails.Selected(varItem) = False
Next varItem
Exit_cmdEmailNot_Click:
Exit Sub
Err_cmdEmailNot_Click:
If Err.Number = 5 Then
MsgBox "You must make a selection(s) from the list", , "Selection Required !"
Resume Exit_cmdEmailNot_Click
Else
'Write out the error and exit the sub
MsgBox Err.Description
Resume Exit_cmdEmailNot_Click
End If

End Sub

I want to add this code for "Frame16.Value = 2". But I cant get it to work

Public Sub CreateVotingButtons()
Dim oOutlook As Object
Dim oMailItem As Object
Dim oRecipient As Object
Dim oNameSpace As Object

Set oOutlook = CreateObject("Outlook.Application")
Set oNameSpace = oOutlook.GetNamespace("MAPI")
oNameSpace.Logon , , True
Set oMailItem = oOutlook.CreateItem(0)
With oMailItem
.VotingOptions = "Reviewed with NO comments;Reviewed with comments"
.Display
End With
End Sub

Any thoughts?

Thanks

RB