The attached code was written to enable a database form with multiple attached pdfs to be emailed from the command-click button on the form.
Since some machines have been upgraded to the latest versions of Windows 10 and Office 16, I get different errors, such as "User-defined Type not defined" (mostly to do with recordset and savetofile commands). It still works on machines that were not upgraded. I read it may be due to the DAO 3.6 reference library, but I have installed that.
Can anyone please help? I have been going round in circles for hours!
I changed a couple of references to file directories in the below code.
Many thanks in advance..
Since some machines have been upgraded to the latest versions of Windows 10 and Office 16, I get different errors, such as "User-defined Type not defined" (mostly to do with recordset and savetofile commands). It still works on machines that were not upgraded. I read it may be due to the DAO 3.6 reference library, but I have installed that.
Can anyone please help? I have been going round in circles for hours!
I changed a couple of references to file directories in the below code.
Many thanks in advance..
Code:
Private Sub cmdMAILTEAM_Click()
Dim oAPP As Object
Dim oEMail As Object
' Reference library set to DAO 3.6
Dim rstAttachments As DAO.Recordset
Dim db As DAO.Database
Dim rsParent As DAO.Recordset
Dim rsChild As DAO.Recordset
Set oAPP = CreateObject("Outlook.application")
Set oEMail = oAPP.CreateItem(0)
' Get atttachments ************************************
Set db = CurrentDb
Set rsParent = Me.Recordset
On Error Resume Next
Set rsChild = rsParent.Fields("Attachment").Value
folderspec = "C:\dbtemp"
With rsChild
.MoveFirst
Do While Not .EOF
rsChild.OpenRecordset
rsChild.Fields("FileData").SaveToFile (folderspec) ' this line fails in Win10/Office 19
.MoveNext
Loop
.Close
End With
*********************************************************
Set rsChild = Nothing
Set rsParent = Nothing
Dim OlApp As Object
Dim objMail As Object
Dim stWhere As String '-- Criteria for DLookup
Dim varTo As Variant '-- Address for SendObject
Dim stText As String '-- E-mail text
Dim stWho As String '-- email to this person
Dim stSubject As String '-- Subject line of e-mail
Dim stDESC As String
Dim stNoreply As String
Dim recid As String
Dim stdatum As Date
Dim stidate As String
Dim yrrecs As Integer
Dim eTotal As Long
Dim i As Long
Dim distro As String '-- distribution group selected in FORM
On Error Resume Next 'Keep going if there is an error
'*********************************************************
Dim rs As DAO.Recordset
Dim rs2 As DAO.Recordset
Dim sSQL1 As String
Dim sSQL2 As String
Dim sSQL3 As String
'*************************************************************
'*************************************************************
'Send email **************************************************
Set db = CurrentDb
sSQL1 = "SELECT tblPOI.email, tblPOI.chosen FROM tblPOI WHERE tblPOI.chosen = TRUE"
Set rs = db.OpenRecordset(sSQL1, dbOpenDynaset)
Do While Not rs.EOF
sSQL3 = rs.Fields("EMAIL")
distro = distro & sSQL3 & "; "
rs.MoveNext
Loop
varTo = Left(distro, Len(distro) - 2)
If Len(varTo) > 0 Then
MsgBox "sending to " & varTo
Set rs = Nothing
'*********************************************************
Set OlApp = GetObject(, "Outlook.Application") 'See if Outlook is open *************************
If Err Then 'Outlook is not open
Set OlApp = CreateObject("Outlook.Application") 'Create a new instance of Outlook **********
End If
'Create e-mail item for distro group ***********************
Set objMail = OlApp.CreateItem(olMailItem)
stSubject = ""
stDESC = Me.DESCRIPTION
recid = Me.ID
irec = Form.CurrentRecord
strecyear = Me.txtrecordno & " of " & Me.txtYear & " (" & "ID " & recid & ")"
stSubject = InputBox("Type Message Subject or use default: ")
If Len(stSubject) = 0 Then
stSubject = ":: New Incident ::"
End If
stNoreply = "This is an automated message. Please do not reply."
With objMail
'For each file in "C:\dbtemp" **********************************
strPath = "C:\dbtemp\"
strFile = Dir(strPath & "*.*")
Do While Len(strFile) > 0
.Attachments.Add strPath & strFile
strFile = Dir
Loop
'******************************************************