Adding a CC to email code!

B

Bob Vance

Is it possible for me to add an extra email address to this code as it
would then send the same email to someone else as well
The email would be at:
strMail = Nz(DLookup("EmailCC", "tblOwnerInfo", "OwnerID = " & lngID), "")


Private Sub Report_Activate()

On Error GoTo Error_Handler

Dim lngID As Long, strMail As String, strBodyMsg As String, _
blEditMail As Boolean, dtInvDate As Date, varInvNum As Variant, _
idHorse As Long, strHorse As String

Dim msgPmt As String, msgBtns As Integer, msgTitle As String, msgResp
As Integer

If CurrentProject.AllForms("frmModify").IsLoaded = True Then
lngID = DLookup("OwnerID", "tblInvoice", "InvoiceID = " _
& Form_frmModify.lstModify.Column(0))
ElseIf CurrentProject.AllForms("frmModifyInvoiceClient").IsLoaded = True
Then
lngID = DLookup("OwnerID", "tblInvoice", "InvoiceID = " _
& Form_frmModifyInvoiceClient.lstModify.value)
Else
Exit Sub
End If


strMail = Nz(DLookup("Email", "tblOwnerInfo", "OwnerID = " & lngID), "")


If Not IsEmailOn Or Not IsOwnerWithEmail(lngID) Then
Exit Sub
End If

CurrentDb.Execute "UPDATE tblOwnerInfo " & _
"SET Emaildate = Now() " & _
"WHERE OwnerID = " & lngID, dbFailOnError



dtInvDate = Me.tbInvoiceDate
varInvNum = Me.tbInvoiceNumber
idHorse = Nz(Me.tbHorseID, 0)
If idHorse <> 0 Then
strHorse = Nz(DLookup("[Name]", "qryHorseNameAll", "[HorseID]=" &
idHorse), "")
Else
strHorse = ""
End If

strBodyMsg = "Dear "
strBodyMsg = strBodyMsg & Nz(DLookup("[ClientTitle]", "tblOwnerInfo",
"[OwnerID]=" & lngID), " ") & " "
strBodyMsg = strBodyMsg & Nz(DLookup("[OwnerLastName]", "tblOwnerInfo",
"[OwnerID]=" & lngID), " Owner")
strBodyMsg = strBodyMsg & "," & Chr(10) & Chr(10) & Chr(13) _
& "Attached is your " & varInvNum & " Dated " & Format(dtInvDate,
"d-mmm-yyyy") _
& IIf(Len(strHorse) > 0, " for " & strHorse, "") & "." _
& eMailSignature("Best Regards", True) & Chr(10) & Chr(10) & Chr(13) _
& DownloadMessage("snp")




If strMail = "Null" Or Len(strMail) = 0 Or _
DLookup("[MailFlag]", "tblAdminSetup") = False Then
Exit Sub
End If


msgTitle = "E-Mail Sender"
msgBtns = vbYes + vbQuestion + vbDefaultButton2 + vbApplicationModal
msgPmt = " Create E-Mail ? "
msgResp = MsgBox(msgPmt, msgBtns, msgTitle)
If msgResp = vbCancel Then
Exit Sub
Else
blEditMail = IIf(msgResp = vbYes, False, True)
End If

DoCmd.SendObject acSendReport, Me.Name, acFormatSNP, strMail, , , "Your
Invoice " & IIf(Len(strHorse) > 0, " / " & strHorse, ""), _
strBodyMsg, blEditMail



Exit Sub

If MsgBox("Do you want to send Email??", vbYesNo + vbDefaultButton2)
= vbYes Then

DoCmd.SendObject acSendReport, Me.Name, acFormatRTF,
strMail, , , _
"Your Invoice", strBodyMsg, True '
DoCmd.Close acReport, "rptInvoiceModifyEmail", acSaveNo


End If


Exit Sub

Error_Handler:
Select Case Err.Number
Case 2501
Exit Sub
Case 2487
Resume Next
Case Else

End Select
End Sub
 
G

Graham Mandeno

Hi Bob

SendObject can send to multiple "To" addresses by separating them with a
semicolon.

Also, the two arguments between To and Subject are Cc and Bcc respectively:
DoCmd.SendObject acSendReport, Me.Name, acFormatSNP, strMail, *** Cc
here ***, *** Bcc here ***, "Your Invoice " & IIf(Len(strHorse) > 0, " / "
& strHorse, ""), _
strBodyMsg, blEditMail
Click to expand...

--
Good Luck :)

Graham Mandeno [Access MVP]
Auckland, New Zealand

Bob Vance said:
Is it possible for me to add an extra email address to this code as it
would then send the same email to someone else as well
The email would be at:
strMail = Nz(DLookup("EmailCC", "tblOwnerInfo", "OwnerID = " & lngID), "")


Private Sub Report_Activate()

On Error GoTo Error_Handler

Dim lngID As Long, strMail As String, strBodyMsg As String, _
blEditMail As Boolean, dtInvDate As Date, varInvNum As Variant, _
idHorse As Long, strHorse As String

Dim msgPmt As String, msgBtns As Integer, msgTitle As String,
msgResp As Integer

If CurrentProject.AllForms("frmModify").IsLoaded = True Then
lngID = DLookup("OwnerID", "tblInvoice", "InvoiceID = " _
& Form_frmModify.lstModify.Column(0))
ElseIf CurrentProject.AllForms("frmModifyInvoiceClient").IsLoaded =
True Then
lngID = DLookup("OwnerID", "tblInvoice", "InvoiceID = " _
& Form_frmModifyInvoiceClient.lstModify.value)
Else
Exit Sub
End If


strMail = Nz(DLookup("Email", "tblOwnerInfo", "OwnerID = " & lngID),
"")


If Not IsEmailOn Or Not IsOwnerWithEmail(lngID) Then
Exit Sub
End If

CurrentDb.Execute "UPDATE tblOwnerInfo " & _
"SET Emaildate = Now() " & _
"WHERE OwnerID = " & lngID, dbFailOnError



dtInvDate = Me.tbInvoiceDate
varInvNum = Me.tbInvoiceNumber
idHorse = Nz(Me.tbHorseID, 0)
If idHorse <> 0 Then
strHorse = Nz(DLookup("[Name]", "qryHorseNameAll", "[HorseID]=" &
idHorse), "")
Else
strHorse = ""
End If

strBodyMsg = "Dear "
strBodyMsg = strBodyMsg & Nz(DLookup("[ClientTitle]", "tblOwnerInfo",
"[OwnerID]=" & lngID), " ") & " "
strBodyMsg = strBodyMsg & Nz(DLookup("[OwnerLastName]", "tblOwnerInfo",
"[OwnerID]=" & lngID), " Owner")
strBodyMsg = strBodyMsg & "," & Chr(10) & Chr(10) & Chr(13) _
& "Attached is your " & varInvNum & " Dated " & Format(dtInvDate,
"d-mmm-yyyy") _
& IIf(Len(strHorse) > 0, " for " & strHorse, "") & "." _
& eMailSignature("Best Regards", True) & Chr(10) & Chr(10) & Chr(13) _
& DownloadMessage("snp")




If strMail = "Null" Or Len(strMail) = 0 Or _
DLookup("[MailFlag]", "tblAdminSetup") = False Then
Exit Sub
End If


msgTitle = "E-Mail Sender"
msgBtns = vbYes + vbQuestion + vbDefaultButton2 + vbApplicationModal
msgPmt = " Create E-Mail ? "
msgResp = MsgBox(msgPmt, msgBtns, msgTitle)
If msgResp = vbCancel Then
Exit Sub
Else
blEditMail = IIf(msgResp = vbYes, False, True)
End If

DoCmd.SendObject acSendReport, Me.Name, acFormatSNP, strMail, , , "Your
Invoice " & IIf(Len(strHorse) > 0, " / " & strHorse, ""), _
strBodyMsg, blEditMail



Exit Sub

If MsgBox("Do you want to send Email??", vbYesNo +
vbDefaultButton2) = vbYes Then

DoCmd.SendObject acSendReport, Me.Name, acFormatRTF,
strMail, , , _
"Your Invoice", strBodyMsg, True '
DoCmd.Close acReport, "rptInvoiceModifyEmail", acSaveNo


End If


Exit Sub

Error_Handler:
Select Case Err.Number
Case 2501
Exit Sub
Case 2487
Resume Next
Case Else

End Select
End Sub
Click to expand...
 
B

Bob Vance

Thanks Graham that is producing my CC now but I have lost all my
"Dear Mr Smith" "Your Invoice No"
DoCmd.SendObject acSendReport, Me.Name, acFormatSNP, strMail,
(DLookup("EmailCC", "tblOwnerInfo", "OwnerID = " & lngID)), "Your Invoice "
& IIf(Len(strHorse) > 0, " / " & strHorse, ""), strBodyMsg, blEditMail
Regards Bob

Graham Mandeno said:
Hi Bob

SendObject can send to multiple "To" addresses by separating them with a
semicolon.

Also, the two arguments between To and Subject are Cc and Bcc
respectively:
DoCmd.SendObject acSendReport, Me.Name, acFormatSNP, strMail, *** Cc
here ***, *** Bcc here ***, "Your Invoice " & IIf(Len(strHorse) > 0, " /
" & strHorse, ""), _
strBodyMsg, blEditMail
Click to expand...

--
Good Luck :)

Graham Mandeno [Access MVP]
Auckland, New Zealand

Bob Vance said:
Is it possible for me to add an extra email address to this code as it
would then send the same email to someone else as well
The email would be at:
strMail = Nz(DLookup("EmailCC", "tblOwnerInfo", "OwnerID = " & lngID),
"")


Private Sub Report_Activate()

On Error GoTo Error_Handler

Dim lngID As Long, strMail As String, strBodyMsg As String, _
blEditMail As Boolean, dtInvDate As Date, varInvNum As Variant, _
idHorse As Long, strHorse As String

Dim msgPmt As String, msgBtns As Integer, msgTitle As String,
msgResp As Integer

If CurrentProject.AllForms("frmModify").IsLoaded = True Then
lngID = DLookup("OwnerID", "tblInvoice", "InvoiceID = " _
& Form_frmModify.lstModify.Column(0))
ElseIf CurrentProject.AllForms("frmModifyInvoiceClient").IsLoaded =
True Then
lngID = DLookup("OwnerID", "tblInvoice", "InvoiceID = " _
& Form_frmModifyInvoiceClient.lstModify.value)
Else
Exit Sub
End If


strMail = Nz(DLookup("Email", "tblOwnerInfo", "OwnerID = " & lngID),
"")


If Not IsEmailOn Or Not IsOwnerWithEmail(lngID) Then
Exit Sub
End If

CurrentDb.Execute "UPDATE tblOwnerInfo " & _
"SET Emaildate = Now() " & _
"WHERE OwnerID = " & lngID, dbFailOnError



dtInvDate = Me.tbInvoiceDate
varInvNum = Me.tbInvoiceNumber
idHorse = Nz(Me.tbHorseID, 0)
If idHorse <> 0 Then
strHorse = Nz(DLookup("[Name]", "qryHorseNameAll", "[HorseID]=" &
idHorse), "")
Else
strHorse = ""
End If

strBodyMsg = "Dear "
strBodyMsg = strBodyMsg & Nz(DLookup("[ClientTitle]", "tblOwnerInfo",
"[OwnerID]=" & lngID), " ") & " "
strBodyMsg = strBodyMsg & Nz(DLookup("[OwnerLastName]",
"tblOwnerInfo", "[OwnerID]=" & lngID), " Owner")
strBodyMsg = strBodyMsg & "," & Chr(10) & Chr(10) & Chr(13) _
& "Attached is your " & varInvNum & " Dated " & Format(dtInvDate,
"d-mmm-yyyy") _
& IIf(Len(strHorse) > 0, " for " & strHorse, "") & "." _
& eMailSignature("Best Regards", True) & Chr(10) & Chr(10) & Chr(13) _
& DownloadMessage("snp")




If strMail = "Null" Or Len(strMail) = 0 Or _
DLookup("[MailFlag]", "tblAdminSetup") = False Then
Exit Sub
End If


msgTitle = "E-Mail Sender"
msgBtns = vbYes + vbQuestion + vbDefaultButton2 + vbApplicationModal
msgPmt = " Create E-Mail ? "
msgResp = MsgBox(msgPmt, msgBtns, msgTitle)
If msgResp = vbCancel Then
Exit Sub
Else
blEditMail = IIf(msgResp = vbYes, False, True)
End If

DoCmd.SendObject acSendReport, Me.Name, acFormatSNP, strMail, , ,
"Your Invoice " & IIf(Len(strHorse) > 0, " / " & strHorse, ""), _
strBodyMsg, blEditMail



Exit Sub

If MsgBox("Do you want to send Email??", vbYesNo +
vbDefaultButton2) = vbYes Then

DoCmd.SendObject acSendReport, Me.Name, acFormatRTF,
strMail, , , _
"Your Invoice", strBodyMsg, True '
DoCmd.Close acReport, "rptInvoiceModifyEmail", acSaveNo


End If


Exit Sub

Error_Handler:
Select Case Err.Number
Case 2501
Exit Sub
Case 2487
Resume Next
Case Else

End Select
End Sub
Click to expand...
Click to expand...
 
B

Bob Vance

Acually Now the subject line is saying Dear Mr Smith instead of Your Invoice
/ Horse Name..............Regards Bob Vance
And nothing in the Main Email Box below

Bob Vance said:
Thanks Graham that is producing my CC now but I have lost all my
"Dear Mr Smith" "Your Invoice No"
DoCmd.SendObject acSendReport, Me.Name, acFormatSNP, strMail,
(DLookup("EmailCC", "tblOwnerInfo", "OwnerID = " & lngID)), "Your Invoice
" & IIf(Len(strHorse) > 0, " / " & strHorse, ""), strBodyMsg, blEditMail
Regards Bob

Graham Mandeno said:
Hi Bob

SendObject can send to multiple "To" addresses by separating them with a
semicolon.

Also, the two arguments between To and Subject are Cc and Bcc
respectively:
DoCmd.SendObject acSendReport, Me.Name, acFormatSNP, strMail, *** Cc
here ***, *** Bcc here ***, "Your Invoice " & IIf(Len(strHorse) > 0, " /
" & strHorse, ""), _
strBodyMsg, blEditMail
Click to expand...

--
Good Luck :)

Graham Mandeno [Access MVP]
Auckland, New Zealand

Bob Vance said:
Is it possible for me to add an extra email address to this code as it
would then send the same email to someone else as well
The email would be at:
strMail = Nz(DLookup("EmailCC", "tblOwnerInfo", "OwnerID = " & lngID),
"")


Private Sub Report_Activate()

On Error GoTo Error_Handler

Dim lngID As Long, strMail As String, strBodyMsg As String, _
blEditMail As Boolean, dtInvDate As Date, varInvNum As Variant, _
idHorse As Long, strHorse As String

Dim msgPmt As String, msgBtns As Integer, msgTitle As String,
msgResp As Integer

If CurrentProject.AllForms("frmModify").IsLoaded = True Then
lngID = DLookup("OwnerID", "tblInvoice", "InvoiceID = " _
& Form_frmModify.lstModify.Column(0))
ElseIf CurrentProject.AllForms("frmModifyInvoiceClient").IsLoaded =
True Then
lngID = DLookup("OwnerID", "tblInvoice", "InvoiceID = " _
& Form_frmModifyInvoiceClient.lstModify.value)
Else
Exit Sub
End If


strMail = Nz(DLookup("Email", "tblOwnerInfo", "OwnerID = " & lngID),
"")


If Not IsEmailOn Or Not IsOwnerWithEmail(lngID) Then
Exit Sub
End If

CurrentDb.Execute "UPDATE tblOwnerInfo " & _
"SET Emaildate = Now() " & _
"WHERE OwnerID = " & lngID, dbFailOnError



dtInvDate = Me.tbInvoiceDate
varInvNum = Me.tbInvoiceNumber
idHorse = Nz(Me.tbHorseID, 0)
If idHorse <> 0 Then
strHorse = Nz(DLookup("[Name]", "qryHorseNameAll", "[HorseID]=" &
idHorse), "")
Else
strHorse = ""
End If

strBodyMsg = "Dear "
strBodyMsg = strBodyMsg & Nz(DLookup("[ClientTitle]", "tblOwnerInfo",
"[OwnerID]=" & lngID), " ") & " "
strBodyMsg = strBodyMsg & Nz(DLookup("[OwnerLastName]",
"tblOwnerInfo", "[OwnerID]=" & lngID), " Owner")
strBodyMsg = strBodyMsg & "," & Chr(10) & Chr(10) & Chr(13) _
& "Attached is your " & varInvNum & " Dated " & Format(dtInvDate,
"d-mmm-yyyy") _
& IIf(Len(strHorse) > 0, " for " & strHorse, "") & "." _
& eMailSignature("Best Regards", True) & Chr(10) & Chr(10) & Chr(13)
_
& DownloadMessage("snp")




If strMail = "Null" Or Len(strMail) = 0 Or _
DLookup("[MailFlag]", "tblAdminSetup") = False Then
Exit Sub
End If


msgTitle = "E-Mail Sender"
msgBtns = vbYes + vbQuestion + vbDefaultButton2 + vbApplicationModal
msgPmt = " Create E-Mail ? "
msgResp = MsgBox(msgPmt, msgBtns, msgTitle)
If msgResp = vbCancel Then
Exit Sub
Else
blEditMail = IIf(msgResp = vbYes, False, True)
End If

DoCmd.SendObject acSendReport, Me.Name, acFormatSNP, strMail, , ,
"Your Invoice " & IIf(Len(strHorse) > 0, " / " & strHorse, ""), _
strBodyMsg, blEditMail



Exit Sub

If MsgBox("Do you want to send Email??", vbYesNo +
vbDefaultButton2) = vbYes Then

DoCmd.SendObject acSendReport, Me.Name, acFormatRTF,
strMail, , , _
"Your Invoice", strBodyMsg, True '
DoCmd.Close acReport, "rptInvoiceModifyEmail", acSaveNo


End If


Exit Sub

Error_Handler:
Select Case Err.Number
Case 2501
Exit Sub
Case 2487
Resume Next
Case Else

End Select
End Sub
Click to expand...
Click to expand...
Click to expand...
 
G

Graham Mandeno

Hi Bob

You are missing a comma. I think you'll find your subject line is ending up
as the Bcc address!

When using a method like SendObject or OpenForm that has a large number of
optional arguments, I think it is often better to use named arguments:

DoCmd.SendObject acSendReport, Me.Name, acFormatSNP, _
To:=strMail, _
Cc:=DLookup("EmailCC", "tblOwnerInfo", "OwnerID = " & lngID), _
Subject:="Your Invoice" & IIf(Len(strHorse) > 0, " / " & strHorse, ""),
_
MessageText:=strBodyMsg, _
EditMessage:=blEditMail

It removes the possibility of errors arising from miscounting commas.

Bob Vance said:
Acually Now the subject line is saying Dear Mr Smith instead of Your
Invoice / Horse Name..............Regards Bob Vance
And nothing in the Main Email Box below

Bob Vance said:
Thanks Graham that is producing my CC now but I have lost all my
"Dear Mr Smith" "Your Invoice No"
DoCmd.SendObject acSendReport, Me.Name, acFormatSNP, strMail,
(DLookup("EmailCC", "tblOwnerInfo", "OwnerID = " & lngID)), "Your Invoice
" & IIf(Len(strHorse) > 0, " / " & strHorse, ""), strBodyMsg, blEditMail
Regards Bob

Graham Mandeno said:
Hi Bob

SendObject can send to multiple "To" addresses by separating them with a
semicolon.

Also, the two arguments between To and Subject are Cc and Bcc
respectively:

DoCmd.SendObject acSendReport, Me.Name, acFormatSNP, strMail, *** Cc
here ***, *** Bcc here ***, "Your Invoice " & IIf(Len(strHorse) > 0, "
/ " & strHorse, ""), _
strBodyMsg, blEditMail

--
Good Luck :)

Graham Mandeno [Access MVP]
Auckland, New Zealand



Is it possible for me to add an extra email address to this code as it
would then send the same email to someone else as well
The email would be at:
strMail = Nz(DLookup("EmailCC", "tblOwnerInfo", "OwnerID = " & lngID),
"")


Private Sub Report_Activate()

On Error GoTo Error_Handler

Dim lngID As Long, strMail As String, strBodyMsg As String, _
blEditMail As Boolean, dtInvDate As Date, varInvNum As Variant, _
idHorse As Long, strHorse As String

Dim msgPmt As String, msgBtns As Integer, msgTitle As String,
msgResp As Integer

If CurrentProject.AllForms("frmModify").IsLoaded = True Then
lngID = DLookup("OwnerID", "tblInvoice", "InvoiceID = " _
& Form_frmModify.lstModify.Column(0))
ElseIf CurrentProject.AllForms("frmModifyInvoiceClient").IsLoaded =
True Then
lngID = DLookup("OwnerID", "tblInvoice", "InvoiceID = " _
& Form_frmModifyInvoiceClient.lstModify.value)
Else
Exit Sub
End If


strMail = Nz(DLookup("Email", "tblOwnerInfo", "OwnerID = " & lngID),
"")


If Not IsEmailOn Or Not IsOwnerWithEmail(lngID) Then
Exit Sub
End If

CurrentDb.Execute "UPDATE tblOwnerInfo " & _
"SET Emaildate = Now() " & _
"WHERE OwnerID = " & lngID, dbFailOnError



dtInvDate = Me.tbInvoiceDate
varInvNum = Me.tbInvoiceNumber
idHorse = Nz(Me.tbHorseID, 0)
If idHorse <> 0 Then
strHorse = Nz(DLookup("[Name]", "qryHorseNameAll", "[HorseID]="
& idHorse), "")
Else
strHorse = ""
End If

strBodyMsg = "Dear "
strBodyMsg = strBodyMsg & Nz(DLookup("[ClientTitle]",
"tblOwnerInfo", "[OwnerID]=" & lngID), " ") & " "
strBodyMsg = strBodyMsg & Nz(DLookup("[OwnerLastName]",
"tblOwnerInfo", "[OwnerID]=" & lngID), " Owner")
strBodyMsg = strBodyMsg & "," & Chr(10) & Chr(10) & Chr(13) _
& "Attached is your " & varInvNum & " Dated " & Format(dtInvDate,
"d-mmm-yyyy") _
& IIf(Len(strHorse) > 0, " for " & strHorse, "") & "." _
& eMailSignature("Best Regards", True) & Chr(10) & Chr(10) & Chr(13)
_
& DownloadMessage("snp")




If strMail = "Null" Or Len(strMail) = 0 Or _
DLookup("[MailFlag]", "tblAdminSetup") = False Then
Exit Sub
End If


msgTitle = "E-Mail Sender"
msgBtns = vbYes + vbQuestion + vbDefaultButton2 + vbApplicationModal
msgPmt = " Create E-Mail ? "
msgResp = MsgBox(msgPmt, msgBtns, msgTitle)
If msgResp = vbCancel Then
Exit Sub
Else
blEditMail = IIf(msgResp = vbYes, False, True)
End If

DoCmd.SendObject acSendReport, Me.Name, acFormatSNP, strMail, , ,
"Your Invoice " & IIf(Len(strHorse) > 0, " / " & strHorse, ""), _
strBodyMsg, blEditMail



Exit Sub

If MsgBox("Do you want to send Email??", vbYesNo +
vbDefaultButton2) = vbYes Then

DoCmd.SendObject acSendReport, Me.Name, acFormatRTF,
strMail, , , _
"Your Invoice", strBodyMsg, True '
DoCmd.Close acReport, "rptInvoiceModifyEmail", acSaveNo


End If


Exit Sub

Error_Handler:
Select Case Err.Number
Case 2501
Exit Sub
Case 2487
Resume Next
Case Else

End Select
End Sub
Click to expand...
Click to expand...
Click to expand...
 
B

Bob Vance

Thanks Graham, Worked perfectly :)
One thing I can only have one email recipent in my tbEmailCC as I have a
Function IsValidEmail, That wont let me seperate email address's with a
colon ;
Regards Bob Vance

Public Function IsValidEmail(emailAddress As String) As Boolean
'Check if e-mail address is a valid address
' Requires "tblCountryCodes", "tblDomain Suffix"



Dim Pos As Long, iveLth As Integer, I As Integer, isOkMail As Boolean, _
iveStr As String, chrOK(66) As String, chrFound As Boolean, iveIdStr As
String, _
iveDomStr As String, idTmp As Variant, iveSfx As String, strChrDesc

Dim ivePmt As String, iveBtns As Integer, iveTitle As String, iveResp As
Integer
iveTitle = "e-Mail address verification"
iveBtns = vbExclamation

isOkMail = True
iveStr = Trim(emailAddress)
iveLth = Len(iveStr)
'Checking for illegal characters

'Permitted 45-46 (-.), 48-57 (digits); 64 @, 65-90 (Ucase alpha); 97-122
(Lcase alpha)
' 95 (_)

chrOK(1) = Chr(45)
chrOK(2) = Chr(46)
For I = 48 To 57
chrOK(I - 45) = Chr(I)
Next I

For I = 64 To 90
chrOK(I - 51) = Chr(I)
Next I
chrOK(40) = Chr(95)
For I = 97 To 122
chrOK(I - 56) = Chr(I)
Next I

For Pos = 1 To iveLth
chrFound = False
For I = 1 To 66
If Mid(iveStr, Pos, 1) = chrOK(I) Then
chrFound = True
Exit For
End If
Next I
If Not chrFound Then

strChrDesc = Mid(iveStr, Pos, 1)
Select Case strChrDesc
Case " "
strChrDesc = "(space)"
Case Chr(34)
strChrDesc = "(qoutation mark)"
Case "'"
strChrDesc = "(Apostrophe)"
Case Else
strChrDesc = "'" & strChrDesc & "'"
End Select
IsValidEmail = False

MsgBox "Ilegal character " & strChrDesc & " Found in Position "
& Pos _
& Chr(13) & "Adresss: " & iveStr & " Character: " & strChrDesc
_
& " = Chr(" & Asc(Mid(iveStr, Pos, 1)) & ") ", iveBtns,
iveTitle



Exit Function
End If

Next Pos

' Test for @
Pos = InStr(1, iveStr, "@")

If Pos = 1 Or Pos > iveLth - 4 Then
IsValidEmail = False
MsgBox "@ charcter is in wrong position", iveBtns, iveTitle
Exit Function
ElseIf Pos = 0 Or IsNull(Pos) Then
IsValidEmail = False
MsgBox "No @ character found", iveBtns, iveTitle
Exit Function

End If

iveIdStr = Left(iveStr, Pos - 1)
iveDomStr = Right(iveStr, Len(iveStr) - Pos)

If Len(iveDomStr) > 67 Then
MsgBox "Domain name is too long - maximum is 67 characters ",
iveBtns, iveTitle
IsValidEmail = False
Exit Function
End If


Pos = InStr(1, iveDomStr, "@")

If Pos > 0 Then
IsValidEmail = False
MsgBox "@ character found more then one time", iveBtns, iveTitle
Exit Function

End If

'checking for last dot

Pos = InStrRev(iveDomStr, ".")
'If Pos < Len(iveDomStr) - 3 Or Pos > Len(iveDomStr) - 2 Then
If Pos < Len(iveDomStr) - 4 Or Pos > Len(iveDomStr) - 2 Then

IsValidEmail = False
MsgBox "Last dot (.) is in wrong position or missing", iveBtns,
iveTitle
Exit Function

End If

'check for 2 consec dots

Pos = InStr(1, iveStr, "..")
If Pos > 0 Then
IsValidEmail = False
MsgBox "2 consecutive dots (..) found", iveBtns, iveTitle
Exit Function

End If

'Test for valid domain suffix

Pos = InStrRev(iveDomStr, ".")
If Pos = Len(iveDomStr) - 2 Then
iveSfx = Right(iveDomStr, 2)
idTmp = DLookup("[Country_ID]", "tblCountryCodes", "[Country
Code]='" & iveSfx & "'")
If IsNull(idTmp) Then
iveBtns = vbOKCancel + vbQuestion
ivePmt = "Domain suffix '." & iveSfx & "' not found " &
Chr(13) & Chr(13) _
& "Use '" & iveSfx & "' anyway? "
iveResp = MsgBox(ivePmt, iveBtns, iveTitle)
If iveResp = vbCancel Then
IsValidEmail = False
Exit Function
End If
End If

Else
iveSfx = Right(iveDomStr, Len(iveDomStr) - Pos)
idTmp = DLookup("[DomSuffix_ID]", "tblDomain Suffix", "[Suffix]='" &
iveSfx & "'")
If IsNull(idTmp) Then
iveBtns = vbExclamation
ivePmt = "Invalid domain suffix '." & iveSfx & "'"
MsgBox ivePmt, iveBtns, iveTitle
IsValidEmail = False
Exit Function

End If
End If

IsValidEmail = True


End Function
Graham Mandeno said:
Hi Bob

You are missing a comma. I think you'll find your subject line is ending
up as the Bcc address!

When using a method like SendObject or OpenForm that has a large number of
optional arguments, I think it is often better to use named arguments:

DoCmd.SendObject acSendReport, Me.Name, acFormatSNP, _
To:=strMail, _
Cc:=DLookup("EmailCC", "tblOwnerInfo", "OwnerID = " & lngID), _
Subject:="Your Invoice" & IIf(Len(strHorse) > 0, " / " & strHorse, ""),
_
MessageText:=strBodyMsg, _
EditMessage:=blEditMail

It removes the possibility of errors arising from miscounting commas.

Bob Vance said:
Acually Now the subject line is saying Dear Mr Smith instead of Your
Invoice / Horse Name..............Regards Bob Vance
And nothing in the Main Email Box below

Bob Vance said:
Thanks Graham that is producing my CC now but I have lost all my
"Dear Mr Smith" "Your Invoice No"
DoCmd.SendObject acSendReport, Me.Name, acFormatSNP, strMail,
(DLookup("EmailCC", "tblOwnerInfo", "OwnerID = " & lngID)), "Your
Invoice " & IIf(Len(strHorse) > 0, " / " & strHorse, ""), strBodyMsg,
blEditMail
Regards Bob

Hi Bob

SendObject can send to multiple "To" addresses by separating them with
a semicolon.

Also, the two arguments between To and Subject are Cc and Bcc
respectively:

DoCmd.SendObject acSendReport, Me.Name, acFormatSNP, strMail, ***
Cc here ***, *** Bcc here ***, "Your Invoice " & IIf(Len(strHorse) >
0, " / " & strHorse, ""), _
strBodyMsg, blEditMail

--
Good Luck :)

Graham Mandeno [Access MVP]
Auckland, New Zealand



Is it possible for me to add an extra email address to this code as
it would then send the same email to someone else as well
The email would be at:
strMail = Nz(DLookup("EmailCC", "tblOwnerInfo", "OwnerID = " & lngID),
"")


Private Sub Report_Activate()

On Error GoTo Error_Handler

Dim lngID As Long, strMail As String, strBodyMsg As String, _
blEditMail As Boolean, dtInvDate As Date, varInvNum As Variant, _
idHorse As Long, strHorse As String

Dim msgPmt As String, msgBtns As Integer, msgTitle As String,
msgResp As Integer

If CurrentProject.AllForms("frmModify").IsLoaded = True Then
lngID = DLookup("OwnerID", "tblInvoice", "InvoiceID = " _
& Form_frmModify.lstModify.Column(0))
ElseIf CurrentProject.AllForms("frmModifyInvoiceClient").IsLoaded =
True Then
lngID = DLookup("OwnerID", "tblInvoice", "InvoiceID = " _
& Form_frmModifyInvoiceClient.lstModify.value)
Else
Exit Sub
End If


strMail = Nz(DLookup("Email", "tblOwnerInfo", "OwnerID = " &
lngID), "")


If Not IsEmailOn Or Not IsOwnerWithEmail(lngID) Then
Exit Sub
End If

CurrentDb.Execute "UPDATE tblOwnerInfo " & _
"SET Emaildate = Now() " & _
"WHERE OwnerID = " & lngID, dbFailOnError



dtInvDate = Me.tbInvoiceDate
varInvNum = Me.tbInvoiceNumber
idHorse = Nz(Me.tbHorseID, 0)
If idHorse <> 0 Then
strHorse = Nz(DLookup("[Name]", "qryHorseNameAll", "[HorseID]="
& idHorse), "")
Else
strHorse = ""
End If

strBodyMsg = "Dear "
strBodyMsg = strBodyMsg & Nz(DLookup("[ClientTitle]",
"tblOwnerInfo", "[OwnerID]=" & lngID), " ") & " "
strBodyMsg = strBodyMsg & Nz(DLookup("[OwnerLastName]",
"tblOwnerInfo", "[OwnerID]=" & lngID), " Owner")
strBodyMsg = strBodyMsg & "," & Chr(10) & Chr(10) & Chr(13) _
& "Attached is your " & varInvNum & " Dated " & Format(dtInvDate,
"d-mmm-yyyy") _
& IIf(Len(strHorse) > 0, " for " & strHorse, "") & "." _
& eMailSignature("Best Regards", True) & Chr(10) & Chr(10) &
Chr(13) _
& DownloadMessage("snp")




If strMail = "Null" Or Len(strMail) = 0 Or _
DLookup("[MailFlag]", "tblAdminSetup") = False Then
Exit Sub
End If


msgTitle = "E-Mail Sender"
msgBtns = vbYes + vbQuestion + vbDefaultButton2 +
vbApplicationModal
msgPmt = " Create E-Mail ? "
msgResp = MsgBox(msgPmt, msgBtns, msgTitle)
If msgResp = vbCancel Then
Exit Sub
Else
blEditMail = IIf(msgResp = vbYes, False, True)
End If

DoCmd.SendObject acSendReport, Me.Name, acFormatSNP, strMail, , ,
"Your Invoice " & IIf(Len(strHorse) > 0, " / " & strHorse, ""), _
strBodyMsg, blEditMail



Exit Sub

If MsgBox("Do you want to send Email??", vbYesNo +
vbDefaultButton2) = vbYes Then

DoCmd.SendObject acSendReport, Me.Name, acFormatRTF,
strMail, , , _
"Your Invoice", strBodyMsg, True '
DoCmd.Close acReport, "rptInvoiceModifyEmail", acSaveNo


End If


Exit Sub

Error_Handler:
Select Case Err.Number
Case 2501
Exit Sub
Case 2487
Resume Next
Case Else

End Select
End Sub
Click to expand...
Click to expand...
Click to expand...
 
B

Bob Vance

Huh Its working perfect Now! letting me email multiple clients :)
I also changed my statement email so as it was the same as my invoices it
also working fine , except now I have an Microsoft Outlook warning box
appearing asking to allow or deny instead of my email opening to select send
like I did before!
Regards Bob
****** Old Code Commered Out***********

Private Sub SendMailButton_Click()

On Error GoTo ErrorHandler

Dim lngID As Long, strMail As String, strBodyMsg As String, _
blEditMail As Boolean, sndReport As String, strCompany As String
'*****JK: Added 17/10/06
Dim msgPmt As String, msgBtns As Integer, msgTitle As String, msgResp As
Integer

Select Case Me.OpenArgs

Case "OwnerStatement"

sndReport = "rptOwnerPaymentMethod"


lngID = Nz(Me.cbOwnerName.Column(0), 0)
strMail = OwnerEmailAddress(lngID)


strBodyMsg = "Dear "
strBodyMsg = strBodyMsg & Nz(DLookup("[ClientTitle]",
"tblOwnerInfo", _
"[OwnerID]=" & lngID), " ") & " "
strBodyMsg = strBodyMsg & Nz(DLookup("[OwnerLastName]",
"tblOwnerInfo", _
"[OwnerID]=" & lngID), " Owner")
strBodyMsg = strBodyMsg & "," & Chr(10) & Chr(10) & Chr(13) _
& "Attached is your Statement " & eMailSignature("Best
Regards", True) & Chr(10) & Chr(10) _
& DownloadMessage("snp")


CurrentDb.Execute "UPDATE tblOwnerInfo " & _
"SET EmailDateState = Now() " & _
"WHERE OwnerID = " & lngID, dbFailOnError
*********'DoCmd.SendObject acSendReport, sndReport, acFormatSNP, strMail,
, , "Your Statement" & " " & "/" & " " & Nz(DLookup("[CompanyName]",
"tblCompanyInfo")), strBodyMsg, True**********
DoCmd.SendObject acSendReport, sndReport, acFormatSNP,
To:=strMail, Cc:=DLookup("EmailCC", "tblOwnerInfo", "OwnerID = " & lngID), _
Subject:="Your Statement" & Nz(DLookup("[CompanyName]",
"tblCompanyInfo")), MessageText:=strBodyMsg, EditMessage:=blEditMail

cbOwnerName.SetFocus

Case Else
Exit Sub

End Select
Exit Sub

ErrorHandler:

msgTitle = "Untrapped Error"
msgBtns = vbExclamation
If Err.Number = 2501 Then
Err.Clear
Exit Sub
End If
MsgBox "Error Number: " & Err.Number & Chr(13) _
& "Description: " & Err.Description & Chr(13) & Chr(13) _
& "(frmBillStatement SendMailButton_Click)", msgBtns, msgTitle


End Sub


Bob Vance said:
Thanks Graham, Worked perfectly :)
One thing I can only have one email recipent in my tbEmailCC as I have a
Function IsValidEmail, That wont let me seperate email address's with a
colon ;
Regards Bob Vance

Public Function IsValidEmail(emailAddress As String) As Boolean
'Check if e-mail address is a valid address
' Requires "tblCountryCodes", "tblDomain Suffix"



Dim Pos As Long, iveLth As Integer, I As Integer, isOkMail As Boolean,
_
iveStr As String, chrOK(66) As String, chrFound As Boolean, iveIdStr As
String, _
iveDomStr As String, idTmp As Variant, iveSfx As String, strChrDesc

Dim ivePmt As String, iveBtns As Integer, iveTitle As String, iveResp
As Integer
iveTitle = "e-Mail address verification"
iveBtns = vbExclamation

isOkMail = True
iveStr = Trim(emailAddress)
iveLth = Len(iveStr)
'Checking for illegal characters

'Permitted 45-46 (-.), 48-57 (digits); 64 @, 65-90 (Ucase alpha);
97-122 (Lcase alpha)
' 95 (_)

chrOK(1) = Chr(45)
chrOK(2) = Chr(46)
For I = 48 To 57
chrOK(I - 45) = Chr(I)
Next I

For I = 64 To 90
chrOK(I - 51) = Chr(I)
Next I
chrOK(40) = Chr(95)
For I = 97 To 122
chrOK(I - 56) = Chr(I)
Next I

For Pos = 1 To iveLth
chrFound = False
For I = 1 To 66
If Mid(iveStr, Pos, 1) = chrOK(I) Then
chrFound = True
Exit For
End If
Next I
If Not chrFound Then

strChrDesc = Mid(iveStr, Pos, 1)
Select Case strChrDesc
Case " "
strChrDesc = "(space)"
Case Chr(34)
strChrDesc = "(qoutation mark)"
Case "'"
strChrDesc = "(Apostrophe)"
Case Else
strChrDesc = "'" & strChrDesc & "'"
End Select
IsValidEmail = False

MsgBox "Ilegal character " & strChrDesc & " Found in Position
" & Pos _
& Chr(13) & "Adresss: " & iveStr & " Character: " & strChrDesc
_
& " = Chr(" & Asc(Mid(iveStr, Pos, 1)) & ") ", iveBtns,
iveTitle



Exit Function
End If

Next Pos

' Test for @
Pos = InStr(1, iveStr, "@")

If Pos = 1 Or Pos > iveLth - 4 Then
IsValidEmail = False
MsgBox "@ charcter is in wrong position", iveBtns, iveTitle
Exit Function
ElseIf Pos = 0 Or IsNull(Pos) Then
IsValidEmail = False
MsgBox "No @ character found", iveBtns, iveTitle
Exit Function

End If

iveIdStr = Left(iveStr, Pos - 1)
iveDomStr = Right(iveStr, Len(iveStr) - Pos)

If Len(iveDomStr) > 67 Then
MsgBox "Domain name is too long - maximum is 67 characters ",
iveBtns, iveTitle
IsValidEmail = False
Exit Function
End If


Pos = InStr(1, iveDomStr, "@")

If Pos > 0 Then
IsValidEmail = False
MsgBox "@ character found more then one time", iveBtns, iveTitle
Exit Function

End If

'checking for last dot

Pos = InStrRev(iveDomStr, ".")
'If Pos < Len(iveDomStr) - 3 Or Pos > Len(iveDomStr) - 2 Then
If Pos < Len(iveDomStr) - 4 Or Pos > Len(iveDomStr) - 2 Then

IsValidEmail = False
MsgBox "Last dot (.) is in wrong position or missing", iveBtns,
iveTitle
Exit Function

End If

'check for 2 consec dots

Pos = InStr(1, iveStr, "..")
If Pos > 0 Then
IsValidEmail = False
MsgBox "2 consecutive dots (..) found", iveBtns, iveTitle
Exit Function

End If

'Test for valid domain suffix

Pos = InStrRev(iveDomStr, ".")
If Pos = Len(iveDomStr) - 2 Then
iveSfx = Right(iveDomStr, 2)
idTmp = DLookup("[Country_ID]", "tblCountryCodes", "[Country
Code]='" & iveSfx & "'")
If IsNull(idTmp) Then
iveBtns = vbOKCancel + vbQuestion
ivePmt = "Domain suffix '." & iveSfx & "' not found " &
Chr(13) & Chr(13) _
& "Use '" & iveSfx & "' anyway? "
iveResp = MsgBox(ivePmt, iveBtns, iveTitle)
If iveResp = vbCancel Then
IsValidEmail = False
Exit Function
End If
End If

Else
iveSfx = Right(iveDomStr, Len(iveDomStr) - Pos)
idTmp = DLookup("[DomSuffix_ID]", "tblDomain Suffix", "[Suffix]='"
& iveSfx & "'")
If IsNull(idTmp) Then
iveBtns = vbExclamation
ivePmt = "Invalid domain suffix '." & iveSfx & "'"
MsgBox ivePmt, iveBtns, iveTitle
IsValidEmail = False
Exit Function

End If
End If

IsValidEmail = True


End Function
Graham Mandeno said:
Hi Bob

You are missing a comma. I think you'll find your subject line is ending
up as the Bcc address!

When using a method like SendObject or OpenForm that has a large number
of optional arguments, I think it is often better to use named arguments:

DoCmd.SendObject acSendReport, Me.Name, acFormatSNP, _
To:=strMail, _
Cc:=DLookup("EmailCC", "tblOwnerInfo", "OwnerID = " & lngID), _
Subject:="Your Invoice" & IIf(Len(strHorse) > 0, " / " & strHorse,
""), _
MessageText:=strBodyMsg, _
EditMessage:=blEditMail

It removes the possibility of errors arising from miscounting commas.

Bob Vance said:
Acually Now the subject line is saying Dear Mr Smith instead of Your
Invoice / Horse Name..............Regards Bob Vance
And nothing in the Main Email Box below

Thanks Graham that is producing my CC now but I have lost all my
"Dear Mr Smith" "Your Invoice No"
DoCmd.SendObject acSendReport, Me.Name, acFormatSNP, strMail,
(DLookup("EmailCC", "tblOwnerInfo", "OwnerID = " & lngID)), "Your
Invoice " & IIf(Len(strHorse) > 0, " / " & strHorse, ""), strBodyMsg,
blEditMail
Regards Bob

Hi Bob

SendObject can send to multiple "To" addresses by separating them with
a semicolon.

Also, the two arguments between To and Subject are Cc and Bcc
respectively:

DoCmd.SendObject acSendReport, Me.Name, acFormatSNP, strMail, ***
Cc here ***, *** Bcc here ***, "Your Invoice " & IIf(Len(strHorse) >
0, " / " & strHorse, ""), _
strBodyMsg, blEditMail

--
Good Luck :)

Graham Mandeno [Access MVP]
Auckland, New Zealand



Is it possible for me to add an extra email address to this code as
it would then send the same email to someone else as well
The email would be at:
strMail = Nz(DLookup("EmailCC", "tblOwnerInfo", "OwnerID = " &
lngID), "")


Private Sub Report_Activate()

On Error GoTo Error_Handler

Dim lngID As Long, strMail As String, strBodyMsg As String, _
blEditMail As Boolean, dtInvDate As Date, varInvNum As Variant, _
idHorse As Long, strHorse As String

Dim msgPmt As String, msgBtns As Integer, msgTitle As String,
msgResp As Integer

If CurrentProject.AllForms("frmModify").IsLoaded = True Then
lngID = DLookup("OwnerID", "tblInvoice", "InvoiceID = " _
& Form_frmModify.lstModify.Column(0))
ElseIf CurrentProject.AllForms("frmModifyInvoiceClient").IsLoaded
= True Then
lngID = DLookup("OwnerID", "tblInvoice", "InvoiceID = " _
& Form_frmModifyInvoiceClient.lstModify.value)
Else
Exit Sub
End If


strMail = Nz(DLookup("Email", "tblOwnerInfo", "OwnerID = " &
lngID), "")


If Not IsEmailOn Or Not IsOwnerWithEmail(lngID) Then
Exit Sub
End If

CurrentDb.Execute "UPDATE tblOwnerInfo " & _
"SET Emaildate = Now() " & _
"WHERE OwnerID = " & lngID, dbFailOnError



dtInvDate = Me.tbInvoiceDate
varInvNum = Me.tbInvoiceNumber
idHorse = Nz(Me.tbHorseID, 0)
If idHorse <> 0 Then
strHorse = Nz(DLookup("[Name]", "qryHorseNameAll",
"[HorseID]=" & idHorse), "")
Else
strHorse = ""
End If

strBodyMsg = "Dear "
strBodyMsg = strBodyMsg & Nz(DLookup("[ClientTitle]",
"tblOwnerInfo", "[OwnerID]=" & lngID), " ") & " "
strBodyMsg = strBodyMsg & Nz(DLookup("[OwnerLastName]",
"tblOwnerInfo", "[OwnerID]=" & lngID), " Owner")
strBodyMsg = strBodyMsg & "," & Chr(10) & Chr(10) & Chr(13) _
& "Attached is your " & varInvNum & " Dated " & Format(dtInvDate,
"d-mmm-yyyy") _
& IIf(Len(strHorse) > 0, " for " & strHorse, "") & "." _
& eMailSignature("Best Regards", True) & Chr(10) & Chr(10) &
Chr(13) _
& DownloadMessage("snp")




If strMail = "Null" Or Len(strMail) = 0 Or _
DLookup("[MailFlag]", "tblAdminSetup") = False Then
Exit Sub
End If


msgTitle = "E-Mail Sender"
msgBtns = vbYes + vbQuestion + vbDefaultButton2 +
vbApplicationModal
msgPmt = " Create E-Mail ? "
msgResp = MsgBox(msgPmt, msgBtns, msgTitle)
If msgResp = vbCancel Then
Exit Sub
Else
blEditMail = IIf(msgResp = vbYes, False, True)
End If

DoCmd.SendObject acSendReport, Me.Name, acFormatSNP, strMail, , ,
"Your Invoice " & IIf(Len(strHorse) > 0, " / " & strHorse, ""), _
strBodyMsg, blEditMail



Exit Sub

If MsgBox("Do you want to send Email??", vbYesNo +
vbDefaultButton2) = vbYes Then

DoCmd.SendObject acSendReport, Me.Name, acFormatRTF,
strMail, , , _
"Your Invoice", strBodyMsg, True '
DoCmd.Close acReport, "rptInvoiceModifyEmail",
acSaveNo


End If


Exit Sub

Error_Handler:
Select Case Err.Number
Case 2501
Exit Sub
Case 2487
Resume Next
Case Else

End Select
End Sub
Click to expand...
Click to expand...
Click to expand...
 
G

Graham Mandeno

Hi Bob

You could always Split your email address string first and then validate
each one:

Dim aEmails as Variant, i as integer
aEmails = Split ( <your string of emails>, ";" )
For i = 0 to UBound(aEmails)
If not IsValidEmail(aEmails(i)) then
MsgBox "Bad email address - " & aEmails(i)
End If
Next


--
Good Luck :)

Graham Mandeno [Access MVP]
Auckland, New Zealand

Bob Vance said:
Thanks Graham, Worked perfectly :)
One thing I can only have one email recipent in my tbEmailCC as I have a
Function IsValidEmail, That wont let me seperate email address's with a
colon ;
Regards Bob Vance

Public Function IsValidEmail(emailAddress As String) As Boolean
'Check if e-mail address is a valid address
' Requires "tblCountryCodes", "tblDomain Suffix"



Dim Pos As Long, iveLth As Integer, I As Integer, isOkMail As Boolean,
_
iveStr As String, chrOK(66) As String, chrFound As Boolean, iveIdStr As
String, _
iveDomStr As String, idTmp As Variant, iveSfx As String, strChrDesc

Dim ivePmt As String, iveBtns As Integer, iveTitle As String, iveResp
As Integer
iveTitle = "e-Mail address verification"
iveBtns = vbExclamation

isOkMail = True
iveStr = Trim(emailAddress)
iveLth = Len(iveStr)
'Checking for illegal characters

'Permitted 45-46 (-.), 48-57 (digits); 64 @, 65-90 (Ucase alpha);
97-122 (Lcase alpha)
' 95 (_)

chrOK(1) = Chr(45)
chrOK(2) = Chr(46)
For I = 48 To 57
chrOK(I - 45) = Chr(I)
Next I

For I = 64 To 90
chrOK(I - 51) = Chr(I)
Next I
chrOK(40) = Chr(95)
For I = 97 To 122
chrOK(I - 56) = Chr(I)
Next I

For Pos = 1 To iveLth
chrFound = False
For I = 1 To 66
If Mid(iveStr, Pos, 1) = chrOK(I) Then
chrFound = True
Exit For
End If
Next I
If Not chrFound Then

strChrDesc = Mid(iveStr, Pos, 1)
Select Case strChrDesc
Case " "
strChrDesc = "(space)"
Case Chr(34)
strChrDesc = "(qoutation mark)"
Case "'"
strChrDesc = "(Apostrophe)"
Case Else
strChrDesc = "'" & strChrDesc & "'"
End Select
IsValidEmail = False

MsgBox "Ilegal character " & strChrDesc & " Found in Position
" & Pos _
& Chr(13) & "Adresss: " & iveStr & " Character: " & strChrDesc
_
& " = Chr(" & Asc(Mid(iveStr, Pos, 1)) & ") ", iveBtns,
iveTitle



Exit Function
End If

Next Pos

' Test for @
Pos = InStr(1, iveStr, "@")

If Pos = 1 Or Pos > iveLth - 4 Then
IsValidEmail = False
MsgBox "@ charcter is in wrong position", iveBtns, iveTitle
Exit Function
ElseIf Pos = 0 Or IsNull(Pos) Then
IsValidEmail = False
MsgBox "No @ character found", iveBtns, iveTitle
Exit Function

End If

iveIdStr = Left(iveStr, Pos - 1)
iveDomStr = Right(iveStr, Len(iveStr) - Pos)

If Len(iveDomStr) > 67 Then
MsgBox "Domain name is too long - maximum is 67 characters ",
iveBtns, iveTitle
IsValidEmail = False
Exit Function
End If


Pos = InStr(1, iveDomStr, "@")

If Pos > 0 Then
IsValidEmail = False
MsgBox "@ character found more then one time", iveBtns, iveTitle
Exit Function

End If

'checking for last dot

Pos = InStrRev(iveDomStr, ".")
'If Pos < Len(iveDomStr) - 3 Or Pos > Len(iveDomStr) - 2 Then
If Pos < Len(iveDomStr) - 4 Or Pos > Len(iveDomStr) - 2 Then

IsValidEmail = False
MsgBox "Last dot (.) is in wrong position or missing", iveBtns,
iveTitle
Exit Function

End If

'check for 2 consec dots

Pos = InStr(1, iveStr, "..")
If Pos > 0 Then
IsValidEmail = False
MsgBox "2 consecutive dots (..) found", iveBtns, iveTitle
Exit Function

End If

'Test for valid domain suffix

Pos = InStrRev(iveDomStr, ".")
If Pos = Len(iveDomStr) - 2 Then
iveSfx = Right(iveDomStr, 2)
idTmp = DLookup("[Country_ID]", "tblCountryCodes", "[Country
Code]='" & iveSfx & "'")
If IsNull(idTmp) Then
iveBtns = vbOKCancel + vbQuestion
ivePmt = "Domain suffix '." & iveSfx & "' not found " &
Chr(13) & Chr(13) _
& "Use '" & iveSfx & "' anyway? "
iveResp = MsgBox(ivePmt, iveBtns, iveTitle)
If iveResp = vbCancel Then
IsValidEmail = False
Exit Function
End If
End If

Else
iveSfx = Right(iveDomStr, Len(iveDomStr) - Pos)
idTmp = DLookup("[DomSuffix_ID]", "tblDomain Suffix", "[Suffix]='"
& iveSfx & "'")
If IsNull(idTmp) Then
iveBtns = vbExclamation
ivePmt = "Invalid domain suffix '." & iveSfx & "'"
MsgBox ivePmt, iveBtns, iveTitle
IsValidEmail = False
Exit Function

End If
End If

IsValidEmail = True


End Function
Graham Mandeno said:
Hi Bob

You are missing a comma. I think you'll find your subject line is ending
up as the Bcc address!

When using a method like SendObject or OpenForm that has a large number
of optional arguments, I think it is often better to use named arguments:

DoCmd.SendObject acSendReport, Me.Name, acFormatSNP, _
To:=strMail, _
Cc:=DLookup("EmailCC", "tblOwnerInfo", "OwnerID = " & lngID), _
Subject:="Your Invoice" & IIf(Len(strHorse) > 0, " / " & strHorse,
""), _
MessageText:=strBodyMsg, _
EditMessage:=blEditMail

It removes the possibility of errors arising from miscounting commas.

Bob Vance said:
Acually Now the subject line is saying Dear Mr Smith instead of Your
Invoice / Horse Name..............Regards Bob Vance
And nothing in the Main Email Box below

Thanks Graham that is producing my CC now but I have lost all my
"Dear Mr Smith" "Your Invoice No"
DoCmd.SendObject acSendReport, Me.Name, acFormatSNP, strMail,
(DLookup("EmailCC", "tblOwnerInfo", "OwnerID = " & lngID)), "Your
Invoice " & IIf(Len(strHorse) > 0, " / " & strHorse, ""), strBodyMsg,
blEditMail
Regards Bob

Hi Bob

SendObject can send to multiple "To" addresses by separating them with
a semicolon.

Also, the two arguments between To and Subject are Cc and Bcc
respectively:

DoCmd.SendObject acSendReport, Me.Name, acFormatSNP, strMail, ***
Cc here ***, *** Bcc here ***, "Your Invoice " & IIf(Len(strHorse) >
0, " / " & strHorse, ""), _
strBodyMsg, blEditMail

--
Good Luck :)

Graham Mandeno [Access MVP]
Auckland, New Zealand



Is it possible for me to add an extra email address to this code as
it would then send the same email to someone else as well
The email would be at:
strMail = Nz(DLookup("EmailCC", "tblOwnerInfo", "OwnerID = " &
lngID), "")


Private Sub Report_Activate()

On Error GoTo Error_Handler

Dim lngID As Long, strMail As String, strBodyMsg As String, _
blEditMail As Boolean, dtInvDate As Date, varInvNum As Variant, _
idHorse As Long, strHorse As String

Dim msgPmt As String, msgBtns As Integer, msgTitle As String,
msgResp As Integer

If CurrentProject.AllForms("frmModify").IsLoaded = True Then
lngID = DLookup("OwnerID", "tblInvoice", "InvoiceID = " _
& Form_frmModify.lstModify.Column(0))
ElseIf CurrentProject.AllForms("frmModifyInvoiceClient").IsLoaded
= True Then
lngID = DLookup("OwnerID", "tblInvoice", "InvoiceID = " _
& Form_frmModifyInvoiceClient.lstModify.value)
Else
Exit Sub
End If


strMail = Nz(DLookup("Email", "tblOwnerInfo", "OwnerID = " &
lngID), "")


If Not IsEmailOn Or Not IsOwnerWithEmail(lngID) Then
Exit Sub
End If

CurrentDb.Execute "UPDATE tblOwnerInfo " & _
"SET Emaildate = Now() " & _
"WHERE OwnerID = " & lngID, dbFailOnError



dtInvDate = Me.tbInvoiceDate
varInvNum = Me.tbInvoiceNumber
idHorse = Nz(Me.tbHorseID, 0)
If idHorse <> 0 Then
strHorse = Nz(DLookup("[Name]", "qryHorseNameAll",
"[HorseID]=" & idHorse), "")
Else
strHorse = ""
End If

strBodyMsg = "Dear "
strBodyMsg = strBodyMsg & Nz(DLookup("[ClientTitle]",
"tblOwnerInfo", "[OwnerID]=" & lngID), " ") & " "
strBodyMsg = strBodyMsg & Nz(DLookup("[OwnerLastName]",
"tblOwnerInfo", "[OwnerID]=" & lngID), " Owner")
strBodyMsg = strBodyMsg & "," & Chr(10) & Chr(10) & Chr(13) _
& "Attached is your " & varInvNum & " Dated " & Format(dtInvDate,
"d-mmm-yyyy") _
& IIf(Len(strHorse) > 0, " for " & strHorse, "") & "." _
& eMailSignature("Best Regards", True) & Chr(10) & Chr(10) &
Chr(13) _
& DownloadMessage("snp")




If strMail = "Null" Or Len(strMail) = 0 Or _
DLookup("[MailFlag]", "tblAdminSetup") = False Then
Exit Sub
End If


msgTitle = "E-Mail Sender"
msgBtns = vbYes + vbQuestion + vbDefaultButton2 +
vbApplicationModal
msgPmt = " Create E-Mail ? "
msgResp = MsgBox(msgPmt, msgBtns, msgTitle)
If msgResp = vbCancel Then
Exit Sub
Else
blEditMail = IIf(msgResp = vbYes, False, True)
End If

DoCmd.SendObject acSendReport, Me.Name, acFormatSNP, strMail, , ,
"Your Invoice " & IIf(Len(strHorse) > 0, " / " & strHorse, ""), _
strBodyMsg, blEditMail



Exit Sub

If MsgBox("Do you want to send Email??", vbYesNo +
vbDefaultButton2) = vbYes Then

DoCmd.SendObject acSendReport, Me.Name, acFormatRTF,
strMail, , , _
"Your Invoice", strBodyMsg, True '
DoCmd.Close acReport, "rptInvoiceModifyEmail",
acSaveNo


End If


Exit Sub

Error_Handler:
Select Case Err.Number
Case 2501
Exit Sub
Case 2487
Resume Next
Case Else

End Select
End Sub
Click to expand...
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Emailing Question from my DB 2
Enter Date on Emailing 6
True or False for SNP or PDF format to email 12
Sending Report via Email 3
No Error Message wanted 2
Open Report while creating email 1
Add to text box String 4
Case strFormat = acFormatRTF, Problem 5

Top