Question one outlook has to be open to this code to work (how can be fixed)
Question two On the Public Sub AttachFile give error 424 qbject required.
Program runs on access 2000 but i was be able to make it run on access 2010 but because CDO is not included in office 2010 so I have to fix the code.
Thanks for any help.
Option Compare Database
Global Const gstrFileExt As String = "exp"
Sub SendEmailToHQ(strSubject As String)
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.MailItem
Dim account As Outlook.account
Dim strExt As String
Set objOutlook = CreateObject("Outlook.Application")
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
objOutlookMsg.Subject = strSubject
With objOutlookMsg
.Body = "Weekly Upload"
Set objOutlookRecip = .Recipients.Add("*** Email address is removed for privacy ***")
objOutlookRecip.Type = olTo
objOutlookRecip.Resolve
Set objOutlookRecip = Nothing
'Set objOutlookAttach = objOutlookMsg.Attachment
strExt = "gstrFileExt"
AttachFile objOutlookMsg, "fixedexpenses", strExt
AttachFile objOutlookMsg, "unitperiod", strExt
AttachFile objOutlookMsg, "purchase", strExt
AttachFile objOutlookMsg, "purchasecharge", strExt
AttachFile objOutlookMsg, "payroll2", strExt
AttachFile objOutlookMsg, "registercloseout", strExt
AttachFile objOutlookMsg, "nonregistersales", strExt
AttachFile objOutlookMsg, "inventory", strExt
AttachFile objOutlookMsg, "expense", strExt
AttachFile objOutlookMsg, "cateringorder", strExt
AttachFile objOutlookMsg, "cateringorderitem", strExt
' objOutlookMsg.Update True, True
DelaySecs
.Send
'objOutlookMsg.Send showDialog:=False
DelaySecs
Set objOutlookMsg = Nothing
'oSess.Logoff
'Set oSess = Nothing
End With
End Sub
Private Sub DelaySecs()
Dim i As Integer
For i = 1 To 500
DoEvents
Next i
End Sub
Public Sub AttachFile(objOutlookMsg As Outlook.MailItem, strTable As String, strExt As String)
Set objOutlookAttach = objOutlookMsg.Attachments
If strRAPLoc = "" Then SetRapLoc
objOutlookAttach = strTable
objOutlookAttach.ReadFromFile strRAPLoc & "impexp\" & strTable & "." & strExt
'oAttach.Type = CdoFileData
objOutlookAttach.Position = 0
'oAttach.Fields.Add CdoPR_ATTACH_LONG_FILENAME, strTable
DelaySecs
Set objOutlookAttach = Nothing
End Sub
Public Sub DetachFile(objOutlookMsg As Outlook.MailItem, strTable As String, strExt As String)
Dim oAttach As Outlook.Attachment
Dim blnFound As Boolean
For Each oAttach In objOutlookMsg.Attachments()
If oAttach.name = strTable & "." & strExt Or oAttach.name = strTable Then
blnFound = True
Exit For
End If
Next
On Error Resume Next
If strRAPLoc = "" Then SetRapLoc
Kill strRAPLoc & "impexp\" & strTable & "." & strExt
On Error GoTo 0
If blnFound Then
oAttach.WriteToFile (strRAPLoc & "impexp\" & strTable & "." & strExt)
Set oAttach = Nothing
Else
If strTable = "Payroll" Then
DetachFile objOutlookMsg, "Payroll2", strExt
Else
Err.Raise "100", , "Attachment " & strTable & " not found"
End If
End If
End Sub
Public Function ProcessUpdateEmail() As String
On Error GoTo ErrFound
Dim oSess As New MAPI.Session
Dim oFold As MAPI.Folder
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookMsges As Outlook.MailItems
Dim oRecip As MAPI.Recipient
Dim strOut As String
Dim strResult As String
Dim strExt As String
oSess.Logon showDialog:=True
Set oFold = oSess.Inbox
Set objOutlookMsges = oFold.Messages
strResult = "No Email Found..."
strExt = gstrFileExt
For Each objOutlookMsg In objOutlookMsges
If Left(objOutlookMsg.Text, 11) = "Update Data" Then
DetachFile objOutlookMsg, "state", strExt
DetachFile objOutlookMsg, "county", strExt
DetachFile objOutlookMsg, "district", strExt
DetachFile objOutlookMsg, "calculationcode", strExt
DetachFile objOutlookMsg, "city", strExt
DetachFile objOutlookMsg, "unit", strExt
DetachFile objOutlookMsg, "gltypecode", strExt
DetachFile objOutlookMsg, "registertype", strExt
DetachFile objOutlookMsg, "expensetype", strExt
DetachFile objOutlookMsg, "vendor", strExt
DetachFile objOutlookMsg, "unitvendor", strExt
DetachFile objOutlookMsg, "unittype", strExt
DetachFile objOutlookMsg, "employee", strExt
DetachFile objOutlookMsg, "glaccount", strExt
DetachFile objOutlookMsg, "glsubaccount", strExt
DetachFile objOutlookMsg, "empunit", strExt
DetachFile objOutlookMsg, "unitglaccount", strExt
DetachFile objOutlookMsg, "inventorycategory", strExt
DetachFile objOutlookMsg, "register", strExt
strResult = ImportUpdateData
If strResult <> "" Then
strResult = "Error Importing. " & vbCrLf & strResult
GoTo ErrFound
End If
strResult = "Update Applied."
objOutlookMsg.Delete
Set objOutlookMsg = Nothing
End If
Next objOutlookMsg
MsgBox strResult
oSess.Logoff
Set oSess = Nothing
Exit Function
ErrFound:
strOut = strOut & Err.description & vbCrLf
MsgBox "Error." & vbCrLf & strResult, vbCritical, "Error Processing Updates"
End Function
Question two On the Public Sub AttachFile give error 424 qbject required.
Program runs on access 2000 but i was be able to make it run on access 2010 but because CDO is not included in office 2010 so I have to fix the code.
Thanks for any help.
Option Compare Database
Global Const gstrFileExt As String = "exp"
Sub SendEmailToHQ(strSubject As String)
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.MailItem
Dim account As Outlook.account
Dim strExt As String
Set objOutlook = CreateObject("Outlook.Application")
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
objOutlookMsg.Subject = strSubject
With objOutlookMsg
.Body = "Weekly Upload"
Set objOutlookRecip = .Recipients.Add("*** Email address is removed for privacy ***")
objOutlookRecip.Type = olTo
objOutlookRecip.Resolve
Set objOutlookRecip = Nothing
'Set objOutlookAttach = objOutlookMsg.Attachment
strExt = "gstrFileExt"
AttachFile objOutlookMsg, "fixedexpenses", strExt
AttachFile objOutlookMsg, "unitperiod", strExt
AttachFile objOutlookMsg, "purchase", strExt
AttachFile objOutlookMsg, "purchasecharge", strExt
AttachFile objOutlookMsg, "payroll2", strExt
AttachFile objOutlookMsg, "registercloseout", strExt
AttachFile objOutlookMsg, "nonregistersales", strExt
AttachFile objOutlookMsg, "inventory", strExt
AttachFile objOutlookMsg, "expense", strExt
AttachFile objOutlookMsg, "cateringorder", strExt
AttachFile objOutlookMsg, "cateringorderitem", strExt
' objOutlookMsg.Update True, True
DelaySecs
.Send
'objOutlookMsg.Send showDialog:=False
DelaySecs
Set objOutlookMsg = Nothing
'oSess.Logoff
'Set oSess = Nothing
End With
End Sub
Private Sub DelaySecs()
Dim i As Integer
For i = 1 To 500
DoEvents
Next i
End Sub
Public Sub AttachFile(objOutlookMsg As Outlook.MailItem, strTable As String, strExt As String)
Set objOutlookAttach = objOutlookMsg.Attachments
If strRAPLoc = "" Then SetRapLoc
objOutlookAttach = strTable
objOutlookAttach.ReadFromFile strRAPLoc & "impexp\" & strTable & "." & strExt
'oAttach.Type = CdoFileData
objOutlookAttach.Position = 0
'oAttach.Fields.Add CdoPR_ATTACH_LONG_FILENAME, strTable
DelaySecs
Set objOutlookAttach = Nothing
End Sub
Public Sub DetachFile(objOutlookMsg As Outlook.MailItem, strTable As String, strExt As String)
Dim oAttach As Outlook.Attachment
Dim blnFound As Boolean
For Each oAttach In objOutlookMsg.Attachments()
If oAttach.name = strTable & "." & strExt Or oAttach.name = strTable Then
blnFound = True
Exit For
End If
Next
On Error Resume Next
If strRAPLoc = "" Then SetRapLoc
Kill strRAPLoc & "impexp\" & strTable & "." & strExt
On Error GoTo 0
If blnFound Then
oAttach.WriteToFile (strRAPLoc & "impexp\" & strTable & "." & strExt)
Set oAttach = Nothing
Else
If strTable = "Payroll" Then
DetachFile objOutlookMsg, "Payroll2", strExt
Else
Err.Raise "100", , "Attachment " & strTable & " not found"
End If
End If
End Sub
Public Function ProcessUpdateEmail() As String
On Error GoTo ErrFound
Dim oSess As New MAPI.Session
Dim oFold As MAPI.Folder
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookMsges As Outlook.MailItems
Dim oRecip As MAPI.Recipient
Dim strOut As String
Dim strResult As String
Dim strExt As String
oSess.Logon showDialog:=True
Set oFold = oSess.Inbox
Set objOutlookMsges = oFold.Messages
strResult = "No Email Found..."
strExt = gstrFileExt
For Each objOutlookMsg In objOutlookMsges
If Left(objOutlookMsg.Text, 11) = "Update Data" Then
DetachFile objOutlookMsg, "state", strExt
DetachFile objOutlookMsg, "county", strExt
DetachFile objOutlookMsg, "district", strExt
DetachFile objOutlookMsg, "calculationcode", strExt
DetachFile objOutlookMsg, "city", strExt
DetachFile objOutlookMsg, "unit", strExt
DetachFile objOutlookMsg, "gltypecode", strExt
DetachFile objOutlookMsg, "registertype", strExt
DetachFile objOutlookMsg, "expensetype", strExt
DetachFile objOutlookMsg, "vendor", strExt
DetachFile objOutlookMsg, "unitvendor", strExt
DetachFile objOutlookMsg, "unittype", strExt
DetachFile objOutlookMsg, "employee", strExt
DetachFile objOutlookMsg, "glaccount", strExt
DetachFile objOutlookMsg, "glsubaccount", strExt
DetachFile objOutlookMsg, "empunit", strExt
DetachFile objOutlookMsg, "unitglaccount", strExt
DetachFile objOutlookMsg, "inventorycategory", strExt
DetachFile objOutlookMsg, "register", strExt
strResult = ImportUpdateData
If strResult <> "" Then
strResult = "Error Importing. " & vbCrLf & strResult
GoTo ErrFound
End If
strResult = "Update Applied."
objOutlookMsg.Delete
Set objOutlookMsg = Nothing
End If
Next objOutlookMsg
MsgBox strResult
oSess.Logoff
Set oSess = Nothing
Exit Function
ErrFound:
strOut = strOut & Err.description & vbCrLf
MsgBox "Error." & vbCrLf & strResult, vbCritical, "Error Processing Updates"
End Function