Gainaxe
03-18-2010, 10:20 AM
I have some VBA code that sends automatic emails with different attachments for each email. It works perfectly when run in access 2003, however anytime I run it in access 2007 or 2010 the first attachment gets sent on every single email(the body changes, the attachment does not). I have been pulling my hair out trying to figure out why. Code Pasted below;
The code to create attachments
Option Compare Database
Function ExportFeeWithoutApprovalReports()
Dim DB As Database
Dim rs As Recordset
Dim RS1 As Recordset
Dim objQR As QueryDef
Dim txtCurDir As String
Dim txtSQL As String
Dim txtSQL2 As String
Dim txtName As String
Dim txtSQLFilterField As String
Dim lngStrReturn As Long
Dim Quote
Dim TheDate
Quote = Chr(34)
Dim strfinaldir As String
Dim strBody As String
Dim strEmail As String
Dim strEmailAdd As String
Dim blnEmailGood() As Boolean
Dim blnEmailGd As Boolean
Dim pintCount As Integer
Dim pintCounting As Integer
Dim pintCounter As Integer
Dim pintCounted As Integer
Dim txtOpsCntr As String
Dim strLarN As String
Dim strTo As String
Dim strCC As String
On Error GoTo ExportError
strfinaldir = "Fee Without Approval"
txtCurDir = "****"
Set DB = DBEngine.Workspaces(0).Databases(0)
Set rs = DB.OpenRecordset("SELECT DISTINCT [Name],[PCN] FROM tblFeeWithoutApprovalInformation")
rs.MoveFirst
If rs.EOF = True Then
MsgBox "No Fee Without Approval to Report"
Exit Function
End If
TheDate = Format((Date), "mmm dd yyyy")
Do
txtName = rs.Fields("Name").Value
txtPCN = rs.Fields("PCN").Value
strQSQL = "SELECT [InvoiceNumber], [AgreementNumber], [SalesLocationName], [ContractTypeName], [OperationsCenterCode], [PurchaseOrderNumber], [PurchaseOrderTypeCode], [PCN], [Name], [InvoiceAmount], [InvoiceCurrencyCode], [FeeLevelCode] as 'Fee Level', [InvoiceCreatedDate]"
strQSQL = strQSQL & " FROM tblFeeWithoutApprovalInformation WHERE [Name] = " & Quote & txtName & Quote & " ;"
Set objQR = DB.CreateQueryDef("FeeWithoutApproval_Query", strQSQL)
strFilenameXLS = "*****" & txtName & " (Fee Without Approval - " & TheDate & ")" & ".xls"
DoCmd.OutputTo acOutputQuery, "FeeWithoutApproval_Query", acFormatXLS, strFilenameXLS, 0
strAttachfiles = strFilenameXLS
'Place email information here
'Check for Spanish
If checkLanguageCode(txtPCN) = "SP" And checkRegionCode(txtESAPCN) <> "North America" Then
strBody = "Fecha del Reporte: " & Date & "<BR><BR>"
strBody = strBody & "Estimado,<BR><BR>"
strBody = strBody & "El reporte mencionado señala los reportes de honorarios que se les ha enviado, y que esperan la aprobación por parte suya.<BR><BR>"
'Check for Portuguese
ElseIf checkLanguageCode(txtPCN) = "PO" And checkRegionCode(txtESAPCN) <> "North America" Then
strBody = "Data do relatório: " & Date & "<BR><BR>"
strBody = strBody & "Estimado,<BR><BR>"
strBody = strBody & "O relatório de honorários do, que requer sua aprovação, se encontra em anexo.<BR><BR>"
'Check for North America
ElseIf checkLanguageCode(txtPCN) <> "PO" And checkLanguageCode(txtESAPCN) <> "SP" And checkRegionCode(txtESAPCN) = "North America" Then
strBody = "Report Date: " & Date & "<BR><BR>"
strBody = strBody & "Attached is your Fee Without Approval Report.<BR><BR>"
Else
strBody = "Report Date: " & Date & "<BR><BR>"
strBody = strBody & "Attached is your Fee Without Approval Report.<BR><BR>"
End If
'Get the Partner's Email Address. If it does not exist, use gblstrEmlAdmin.
strTo = checkAddress(txtPCN, gblstrEmlAnalyst)
'Get the COM's or CAM's Email Address. If it does not exist, use nothing.
strCC = checkCAMCOM(txtPCN)
Call EmailAll(strAttachfiles, strTo, strCC, strfinaldir, strBody)
DB.QueryDefs.Delete objQR.Name
rs.MoveNext
If gblTestMode = 1 Then Exit Do
Loop Until rs.EOF = True
rs.Close
Set rs = Nothing
The code that emails attachments(please note the schemas use http but cannot post links yet)
Sub EmailAll(strAttachments, strTo, strCC, strSubject, strBody)
Dim strEmlAdmin As String
Dim strAddress As String
Dim strFrom As String
Dim objMsg
If gblTestMode = 0 Then
strEmlAdmin = gblstrEmlAdmin
If Trim(strTo & "") <> "" Then
strAddress = strTo
Else
strAddress = gblstrEmlAdmin
End If
strFrom = "****"
Else
strEmlAdmin = gblstrEmlTest
strAddress = gblstrEmlTest
strFrom = gblstrEmlTest
End If
Set objMsg = CreateObject("CDO.Message")
With objMsg
.from = strFrom
.To = strAddress
.cc = strCC
.BCC = strEmlAdmin
If strAddress = strEmlAdmin Then
objMsg.Subject = "Undeliverable " & strSubject
Else
objMsg.Subject = strSubject
End If
.HTMLBody = strBody
'strAttArray = Split(strAttachments, "|")
'For i = 0 To UBound(strAttArray)
.addattachment strAttachments 'strAttArray(i)
'Next
.Configuration.Fields.Item
Sub EmailAll(strAttachments, strTo, strCC, strSubject, strBody)
Dim strEmlAdmin As String
Dim strAddress As String
Dim strFrom As String
Dim objMsg
If gblTestMode = 0 Then
strEmlAdmin = gblstrEmlAdmin
If Trim(strTo & "") <> "" Then
strAddress = strTo
Else
strAddress = gblstrEmlAdmin
End If
strFrom = "****"
Else
strEmlAdmin = gblstrEmlTest
strAddress = gblstrEmlTest
strFrom = gblstrEmlTest
End If
Set objMsg = CreateObject("CDO.Message")
With objMsg
.from = strFrom
.To = strAddress
.cc = strCC
.BCC = strEmlAdmin
If strAddress = strEmlAdmin Then
objMsg.Subject = "Undeliverable " & strSubject
Else
objMsg.Subject = strSubject
End If
.HTMLBody = strBody
'strAttArray = Split(strAttachments, "|")
'For i = 0 To UBound(strAttArray)
.addattachment strAttachments 'strAttArray(i)
'Next
.Configuration.Fields.Item("//schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Configuration.Fields.Item("//schemas.microsoft.com/cdo/configuration/smtpserver") = "smtphost"
.Configuration.Fields.Item("//schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Configuration.Fields.Item("//schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 2
.Configuration.Fields.Update
.Send
End With
Set objMsg = Nothing
End Sub
.Configuration.Fields.Update
.Send
End With
Set objMsg = Nothing
End Sub
The code to create attachments
Option Compare Database
Function ExportFeeWithoutApprovalReports()
Dim DB As Database
Dim rs As Recordset
Dim RS1 As Recordset
Dim objQR As QueryDef
Dim txtCurDir As String
Dim txtSQL As String
Dim txtSQL2 As String
Dim txtName As String
Dim txtSQLFilterField As String
Dim lngStrReturn As Long
Dim Quote
Dim TheDate
Quote = Chr(34)
Dim strfinaldir As String
Dim strBody As String
Dim strEmail As String
Dim strEmailAdd As String
Dim blnEmailGood() As Boolean
Dim blnEmailGd As Boolean
Dim pintCount As Integer
Dim pintCounting As Integer
Dim pintCounter As Integer
Dim pintCounted As Integer
Dim txtOpsCntr As String
Dim strLarN As String
Dim strTo As String
Dim strCC As String
On Error GoTo ExportError
strfinaldir = "Fee Without Approval"
txtCurDir = "****"
Set DB = DBEngine.Workspaces(0).Databases(0)
Set rs = DB.OpenRecordset("SELECT DISTINCT [Name],[PCN] FROM tblFeeWithoutApprovalInformation")
rs.MoveFirst
If rs.EOF = True Then
MsgBox "No Fee Without Approval to Report"
Exit Function
End If
TheDate = Format((Date), "mmm dd yyyy")
Do
txtName = rs.Fields("Name").Value
txtPCN = rs.Fields("PCN").Value
strQSQL = "SELECT [InvoiceNumber], [AgreementNumber], [SalesLocationName], [ContractTypeName], [OperationsCenterCode], [PurchaseOrderNumber], [PurchaseOrderTypeCode], [PCN], [Name], [InvoiceAmount], [InvoiceCurrencyCode], [FeeLevelCode] as 'Fee Level', [InvoiceCreatedDate]"
strQSQL = strQSQL & " FROM tblFeeWithoutApprovalInformation WHERE [Name] = " & Quote & txtName & Quote & " ;"
Set objQR = DB.CreateQueryDef("FeeWithoutApproval_Query", strQSQL)
strFilenameXLS = "*****" & txtName & " (Fee Without Approval - " & TheDate & ")" & ".xls"
DoCmd.OutputTo acOutputQuery, "FeeWithoutApproval_Query", acFormatXLS, strFilenameXLS, 0
strAttachfiles = strFilenameXLS
'Place email information here
'Check for Spanish
If checkLanguageCode(txtPCN) = "SP" And checkRegionCode(txtESAPCN) <> "North America" Then
strBody = "Fecha del Reporte: " & Date & "<BR><BR>"
strBody = strBody & "Estimado,<BR><BR>"
strBody = strBody & "El reporte mencionado señala los reportes de honorarios que se les ha enviado, y que esperan la aprobación por parte suya.<BR><BR>"
'Check for Portuguese
ElseIf checkLanguageCode(txtPCN) = "PO" And checkRegionCode(txtESAPCN) <> "North America" Then
strBody = "Data do relatório: " & Date & "<BR><BR>"
strBody = strBody & "Estimado,<BR><BR>"
strBody = strBody & "O relatório de honorários do, que requer sua aprovação, se encontra em anexo.<BR><BR>"
'Check for North America
ElseIf checkLanguageCode(txtPCN) <> "PO" And checkLanguageCode(txtESAPCN) <> "SP" And checkRegionCode(txtESAPCN) = "North America" Then
strBody = "Report Date: " & Date & "<BR><BR>"
strBody = strBody & "Attached is your Fee Without Approval Report.<BR><BR>"
Else
strBody = "Report Date: " & Date & "<BR><BR>"
strBody = strBody & "Attached is your Fee Without Approval Report.<BR><BR>"
End If
'Get the Partner's Email Address. If it does not exist, use gblstrEmlAdmin.
strTo = checkAddress(txtPCN, gblstrEmlAnalyst)
'Get the COM's or CAM's Email Address. If it does not exist, use nothing.
strCC = checkCAMCOM(txtPCN)
Call EmailAll(strAttachfiles, strTo, strCC, strfinaldir, strBody)
DB.QueryDefs.Delete objQR.Name
rs.MoveNext
If gblTestMode = 1 Then Exit Do
Loop Until rs.EOF = True
rs.Close
Set rs = Nothing
The code that emails attachments(please note the schemas use http but cannot post links yet)
Sub EmailAll(strAttachments, strTo, strCC, strSubject, strBody)
Dim strEmlAdmin As String
Dim strAddress As String
Dim strFrom As String
Dim objMsg
If gblTestMode = 0 Then
strEmlAdmin = gblstrEmlAdmin
If Trim(strTo & "") <> "" Then
strAddress = strTo
Else
strAddress = gblstrEmlAdmin
End If
strFrom = "****"
Else
strEmlAdmin = gblstrEmlTest
strAddress = gblstrEmlTest
strFrom = gblstrEmlTest
End If
Set objMsg = CreateObject("CDO.Message")
With objMsg
.from = strFrom
.To = strAddress
.cc = strCC
.BCC = strEmlAdmin
If strAddress = strEmlAdmin Then
objMsg.Subject = "Undeliverable " & strSubject
Else
objMsg.Subject = strSubject
End If
.HTMLBody = strBody
'strAttArray = Split(strAttachments, "|")
'For i = 0 To UBound(strAttArray)
.addattachment strAttachments 'strAttArray(i)
'Next
.Configuration.Fields.Item
Sub EmailAll(strAttachments, strTo, strCC, strSubject, strBody)
Dim strEmlAdmin As String
Dim strAddress As String
Dim strFrom As String
Dim objMsg
If gblTestMode = 0 Then
strEmlAdmin = gblstrEmlAdmin
If Trim(strTo & "") <> "" Then
strAddress = strTo
Else
strAddress = gblstrEmlAdmin
End If
strFrom = "****"
Else
strEmlAdmin = gblstrEmlTest
strAddress = gblstrEmlTest
strFrom = gblstrEmlTest
End If
Set objMsg = CreateObject("CDO.Message")
With objMsg
.from = strFrom
.To = strAddress
.cc = strCC
.BCC = strEmlAdmin
If strAddress = strEmlAdmin Then
objMsg.Subject = "Undeliverable " & strSubject
Else
objMsg.Subject = strSubject
End If
.HTMLBody = strBody
'strAttArray = Split(strAttachments, "|")
'For i = 0 To UBound(strAttArray)
.addattachment strAttachments 'strAttArray(i)
'Next
.Configuration.Fields.Item("//schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Configuration.Fields.Item("//schemas.microsoft.com/cdo/configuration/smtpserver") = "smtphost"
.Configuration.Fields.Item("//schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Configuration.Fields.Item("//schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 2
.Configuration.Fields.Update
.Send
End With
Set objMsg = Nothing
End Sub
.Configuration.Fields.Update
.Send
End With
Set objMsg = Nothing
End Sub