P
Pendragon
WinXP/Access 2003
I have an interesting situation where a small client (4 desktops) is able to
utilize an Outlook email function from my access database on only two of
their computers. This function is used by several clients in several
different kinds of network arrangements.
This particular client is on Exchange Server. I have tested the function at
each computer; the two computers which fail to send the email fail at the
line
Set objOutlook = CreateObject("Outlook.Application")
I have compared and verified the settings of each computer in terms of
Windows and Office updates, Access references (Access, Word and Outlook 11.0
included), Email account settings and probably 3 or 4 other items, as well as
conferred with the network tech to insure that all exchange server email
accounts are operating under the same permissions, etc.
The code is posted below. If there is something in the code that needs
changing, please let me know. If you think it's an Outlook issue on the
particular PCs, a network issue, etc., that would be helpful because I'll
stop wasting time in examining the code. As I said, this works on two PCs
and doesn't work on the other two. To the best of my knowledge, all of the
PCs are configured in the same manner.
Private Sub btnCreateEmail_Click()
On Local Error GoTo Err_btnCreateEmail_Click
Dim CompanyDB As Database
Dim rs As Recordset
Dim strBody As String
Dim lngCount As Long
Dim lngRSCount As Long
Dim objOutlook As Object
Dim objOutlookMsg As Object
Dim objOutlookRecip As Object
Dim objOutlookAttach As Object
Dim strSubject As String
Dim strImportance As Integer
Dim intSent As Integer
Dim intNotSent As Integer
Dim olMailItem As Long
olMailItem = 0
intSent = 0
intNotSent = 0
Set CompanyDB = CurrentDb
Set rs = CompanyDB.OpenRecordset("Select * from tblEmailAddresses")
If rs.RecordCount = 0 Or IsNull(rs.RecordCount) Then
MsgBox "Your selection found no email addresses.", vbOKCancel
DoCmd.CancelEvent
Else
rs.MoveLast
lngRSCount = rs.RecordCount
rs.MoveFirst
strBody = Me.txtBody
strSubject = Me.txtSubject
intImportance = Me.optImportance
Do Until rs.EOF
lngCount = lngCount + 1
StrTo = rs("EmailAddress")
If IsNull(StrTo) Then
intNotSent = intNotSent + 1
lblStatus.Caption = "Missing Email " & lngCount & " of " &
CStr(lngRSCount) & "..."
Else
intSent = intSent + 1
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add(StrTo)
objOutlookRecip.Type = olTo
' Set the Subject, Body, and Importance of the message.
.Subject = strSubject
.Body = strBody & vbCrLf & vbCrLf
If intImportance = 1 Then
.Importance = olImportanceHigh 'High importance
ElseIf intImportance = 3 Then
.Importance = olImportanceLow 'Low importance
Else
.Importance = olImportanceNormal
End If
' Add attachments to the message.
Dim nCur As Integer
For nCur = 0 To lstAttachments.ListCount - 1
AttachmentPath = CStr(lstAttachments.ItemData(nCur))
If Not IsMissing(AttachmentPath) Then
.Attachments.Add AttachmentPath
End If
Next nCur
.Save
.Send
End With
End If
rs.MoveNext
Loop
rs.Close
CompanyDB.Close
Set rs = Nothing
Set CompanyDB = Nothing
lblStatus.Caption = "Email routine completed."
MsgBox "Process complete for subject: " & strSubject, vbOKOnly
lblStatus.Caption = ""
End If
Exit Sub
Exit_btnCreateEmail_Click:
Exit Sub
Err_btnCreateEmail_Click:
MsgBox "Error " & Err.Number & ": " & Err.Description
End Sub
I have an interesting situation where a small client (4 desktops) is able to
utilize an Outlook email function from my access database on only two of
their computers. This function is used by several clients in several
different kinds of network arrangements.
This particular client is on Exchange Server. I have tested the function at
each computer; the two computers which fail to send the email fail at the
line
Set objOutlook = CreateObject("Outlook.Application")
I have compared and verified the settings of each computer in terms of
Windows and Office updates, Access references (Access, Word and Outlook 11.0
included), Email account settings and probably 3 or 4 other items, as well as
conferred with the network tech to insure that all exchange server email
accounts are operating under the same permissions, etc.
The code is posted below. If there is something in the code that needs
changing, please let me know. If you think it's an Outlook issue on the
particular PCs, a network issue, etc., that would be helpful because I'll
stop wasting time in examining the code. As I said, this works on two PCs
and doesn't work on the other two. To the best of my knowledge, all of the
PCs are configured in the same manner.
Private Sub btnCreateEmail_Click()
On Local Error GoTo Err_btnCreateEmail_Click
Dim CompanyDB As Database
Dim rs As Recordset
Dim strBody As String
Dim lngCount As Long
Dim lngRSCount As Long
Dim objOutlook As Object
Dim objOutlookMsg As Object
Dim objOutlookRecip As Object
Dim objOutlookAttach As Object
Dim strSubject As String
Dim strImportance As Integer
Dim intSent As Integer
Dim intNotSent As Integer
Dim olMailItem As Long
olMailItem = 0
intSent = 0
intNotSent = 0
Set CompanyDB = CurrentDb
Set rs = CompanyDB.OpenRecordset("Select * from tblEmailAddresses")
If rs.RecordCount = 0 Or IsNull(rs.RecordCount) Then
MsgBox "Your selection found no email addresses.", vbOKCancel
DoCmd.CancelEvent
Else
rs.MoveLast
lngRSCount = rs.RecordCount
rs.MoveFirst
strBody = Me.txtBody
strSubject = Me.txtSubject
intImportance = Me.optImportance
Do Until rs.EOF
lngCount = lngCount + 1
StrTo = rs("EmailAddress")
If IsNull(StrTo) Then
intNotSent = intNotSent + 1
lblStatus.Caption = "Missing Email " & lngCount & " of " &
CStr(lngRSCount) & "..."
Else
intSent = intSent + 1
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add(StrTo)
objOutlookRecip.Type = olTo
' Set the Subject, Body, and Importance of the message.
.Subject = strSubject
.Body = strBody & vbCrLf & vbCrLf
If intImportance = 1 Then
.Importance = olImportanceHigh 'High importance
ElseIf intImportance = 3 Then
.Importance = olImportanceLow 'Low importance
Else
.Importance = olImportanceNormal
End If
' Add attachments to the message.
Dim nCur As Integer
For nCur = 0 To lstAttachments.ListCount - 1
AttachmentPath = CStr(lstAttachments.ItemData(nCur))
If Not IsMissing(AttachmentPath) Then
.Attachments.Add AttachmentPath
End If
Next nCur
.Save
.Send
End With
End If
rs.MoveNext
Loop
rs.Close
CompanyDB.Close
Set rs = Nothing
Set CompanyDB = Nothing
lblStatus.Caption = "Email routine completed."
MsgBox "Process complete for subject: " & strSubject, vbOKOnly
lblStatus.Caption = ""
End If
Exit Sub
Exit_btnCreateEmail_Click:
Exit Sub
Err_btnCreateEmail_Click:
MsgBox "Error " & Err.Number & ": " & Err.Description
End Sub