Good day all,
I have a cmd bttn with the following code:
Private Sub cmdUpCert_Click()
Dim objCert As Object
Dim strFile As String
Dim strFolder As String
Dim varItem As Variant
Set objCert = Application.FileDialog(3)
objCert.allowMultiSelect = True
If objCert.Show Then
For Each varItem In objCert.SelectedItems
strFile = Dir(varItem)
strFolder = Left(varItem, Len(varItem) - Len(strFile))
MsgBox "Folder" & strFolder & vbCrLf & "File: " & strFile
UpCert = strFolder + strFile
Next
End If
Call CertificateEmail
Set objCert = Nothing
End Sub
When I click the bttn the dialog box open and I can grab my file but the CertificateEmail procedure does not work. The email does not open. What am I missing please?
Here is the CertificateEmail Procedure Code:
Private Sub CertificateEmail()
On Error GoTo Exit_Sub:
Dim oOutlook As Outlook.Application
Dim oEmailItem As MailItem
Dim db As DAO.Database
Dim rs As Recordset
Set db = CurrentDb
Set rs = db.OpenRecordset("Qry_Cert")
If rs.RecordCount > 0 Then
rs.MoveFirst
Do Until rs.EOF
If IsNull(rs!Email) Then
rs.MoveNext
Else
If oOutlook Is Nothing Then
Set oOutlook = New Outlook.Application
End If
Set oEmailItem = oOutlook.CreateItem(olMailItem)
With oEmailItem
.To = "arlette.watson@rmf.com"
.Subject = "A new certificate has been entered in the database"
.Body = "Check Tbl_EngineerLic for" & vbCr & _
"ID: " & rs!ID & vbCr & _
"License Number: " & rs!LicNum & vbCr & _
"Employee: " & rs!Emp & vbCr & vbCr & _
"Thank you"
.Display
'.Send
rs.Edit
'rs!EmailSent = Date
'rs.OpenNotify = Date
rs.Update
End With
Set oEmailItem = Nothing
Set oOutlook = Nothing
rs.MoveNext
End If
Loop
Else
'Do Nothing
End If
rs.Close
Exit_Sub:
Exit Sub
End Sub
Thank you for the help
I have a cmd bttn with the following code:
Private Sub cmdUpCert_Click()
Dim objCert As Object
Dim strFile As String
Dim strFolder As String
Dim varItem As Variant
Set objCert = Application.FileDialog(3)
objCert.allowMultiSelect = True
If objCert.Show Then
For Each varItem In objCert.SelectedItems
strFile = Dir(varItem)
strFolder = Left(varItem, Len(varItem) - Len(strFile))
MsgBox "Folder" & strFolder & vbCrLf & "File: " & strFile
UpCert = strFolder + strFile
Next
End If
Call CertificateEmail
Set objCert = Nothing
End Sub
When I click the bttn the dialog box open and I can grab my file but the CertificateEmail procedure does not work. The email does not open. What am I missing please?
Here is the CertificateEmail Procedure Code:
Private Sub CertificateEmail()
On Error GoTo Exit_Sub:
Dim oOutlook As Outlook.Application
Dim oEmailItem As MailItem
Dim db As DAO.Database
Dim rs As Recordset
Set db = CurrentDb
Set rs = db.OpenRecordset("Qry_Cert")
If rs.RecordCount > 0 Then
rs.MoveFirst
Do Until rs.EOF
If IsNull(rs!Email) Then
rs.MoveNext
Else
If oOutlook Is Nothing Then
Set oOutlook = New Outlook.Application
End If
Set oEmailItem = oOutlook.CreateItem(olMailItem)
With oEmailItem
.To = "arlette.watson@rmf.com"
.Subject = "A new certificate has been entered in the database"
.Body = "Check Tbl_EngineerLic for" & vbCr & _
"ID: " & rs!ID & vbCr & _
"License Number: " & rs!LicNum & vbCr & _
"Employee: " & rs!Emp & vbCr & vbCr & _
"Thank you"
.Display
'.Send
rs.Edit
'rs!EmailSent = Date
'rs.OpenNotify = Date
rs.Update
End With
Set oEmailItem = Nothing
Set oOutlook = Nothing
rs.MoveNext
End If
Loop
Else
'Do Nothing
End If
rs.Close
Exit_Sub:
Exit Sub
End Sub
Thank you for the help