D
D
Hi
Sorry for the lenght of the code; this was working before; No I get run time
error:-2147221233, An object can not be found; is the line with * on the
below code: set cf = ....
Why this error? and help is appreciated.
Thanks,
Dan
*************
Option Compare Database
Public Function ImportTasksFromOutlook()
' This code is based in Microsoft Access.
Dim rst As DAO.Recordset, dbs As Database, qdf As QueryDef
Dim ol As New Outlook.Application
Dim olns As Outlook.Namespace
Dim cf As Outlook.MAPIFolder
Dim c As Outlook.TaskItem
Dim objItems As Outlook.Items
'Dim Prop As Outlook.UserProperty
Dim vDateOpened As Date
'Dim vDateClosed As Date
Dim vIssueAge As Integer
Set rst = CurrentDb.OpenRecordset("IW Issues")
Set dbs = CurrentDb
Set qdf = dbs.QueryDefs("qry_dummy")
Set olns = ol.GetNamespace("MAPI")
'Set PF = olns.Folders("Public Folders").Folders("All Public Folders")
'Set AF = PF.Folders("Applications")
'Set HDFolder = AF.Folders("IW Issues")
'Set HDItems = HDFolder.Items
DoCmd.Hourglass (True)
'Set cf = olns.PickFolder ' .GetDefaultFolder (olFolderContacts)
*Set cf = olns.Folders("Public Folders").Folders("All Public
Folders").Folders("Applications").Folders("IW Issues")
Set objItems = cf.Items
qdf.SQL = "DELETE FROM [IW Issues];"
qdf.Execute
iNumTasks = objItems.Count
If iNumTasks <> 0 Then
For i = 1 To iNumTasks
Set c = objItems(i)
vDateOpened = c.UserProperties.Item("DateOpened")
'vDateClosed = c.UserProperties.Item("DateClosed")
rst.AddNew
If c.UserProperties.Item("DateClosed") < #1/1/4501# Then
vIssueAge = DateDiff("d", vDateOpened,
c.UserProperties.Item("DateClosed"))
rst!DateClosed = c.UserProperties.Item("DateClosed")
'vDateClosed = c.UserProperties.Item("DateClosed")
Else
vIssueAge = DateDiff("d", vDateOpened, Now)
End If
rst!IncidentNumber = c.UserProperties.Item("Incident")
rst!Description = c.UserProperties.Item("Description")
rst!Status = c.UserProperties.Item("IncidentStatus")
rst!OpenedBy = c.UserProperties.Item("OpenedBy")
rst!DateOpened = c.UserProperties.Item("DateOpened")
rst!IssueAge = vIssueAge
rst!Type = c.UserProperties.Item("Issue Type")
rst!Environment = c.UserProperties.Item("Environment")
rst!Urgency = c.UserProperties.Item("IncidentUrgency")
rst!Priority = c.UserProperties.Item("IncidentPriority")
rst!ClassificationType = c.UserProperties.Item("IncidentType")
rst!ClassificationCategory =
c.UserProperties.Item("IncidentCategory")
rst!Object = c.UserProperties.Item("Object")
rst!Assignee = c.UserProperties.Item("Assignee")
rst!AssignStatus = c.UserProperties.Item("Assign Status")
rst!PackageNumber = c.UserProperties.Item("Package")
rst!AffectedComponents = c.UserProperties.Item("Affected
Components")
rst!Source = c.UserProperties.Item("Source")
rst!RelatedIncident = c.UserProperties.Item("RelatedIncident")
rst!History = c.UserProperties.Item("History")
rst!User = c.UserProperties.Item("To")
' Custom Outlook properties would look like this:
' rst!AccessFieldName = c.UserProperties("OutlookPropertyName")
If DateDiff("d", vDateOpened, Now()) < 8 Then
rst!OpenedPriorWeek = True
Else
rst!OpenedPriorWeek = False
End If
If c.UserProperties.Item("DateClosed") < #1/1/4501# And
DateDiff("d", c.UserProperties.Item("DateClosed"), Now()) < 8 Then
rst!ClosedPriorWeek = True
Else
rst!ClosedPriorWeek = False
End If
rst.Update
Next i
End If
rst.Close
DoCmd.Hourglass (False)
MsgBox "Import Complete"
End Function
Sub ImportTasksFromOutlook1()
' This code is based in Microsoft Access.
Dim dbs As Database, qdf As QueryDef, rst As DAO.Recordset, rst2 As
DAO.Recordset, wsp As Workspace, rst3 As DAO.Recordset
Dim sqlstr As String
Dim ol As New Outlook.Application
Dim olns As Outlook.Namespace
Dim cf As Outlook.MAPIFolder
Dim c As Outlook.TaskItem
Dim objItems As Outlook.Items
Dim Prop As Outlook.UserProperty
Dim strSQL As String
Dim vIssueAge As Integer
Dim vOpenedPriorWeek As Boolean
Dim vClosedPriorWeek As Boolean
Dim vClosedDated As String
Set rst = CurrentDb.OpenRecordset("IW Issues")
Set wsp = DBEngine.Workspaces(0)
Set dbs = CurrentDb
Set qdf = dbs.QueryDefs("qry_dummy")
Set olns = ol.GetNamespace("MAPI")
Set cf = olns.PickFolder ' .GetDefaultFolder (olFolderContacts)
Set objItems = cf.Items
qdf.SQL = "DELETE FROM [IW Issues];"
qdf.Execute
iNumTasks = objItems.Count
wsp.BeginTrans
For i = 1 To iNumTasks
' If TypeName(objItems(i)) = "TaskItem" Then
Set c = objItems(i)
If c.UserProperties.Item("DateClosed") < #1/1/4501# Then
vDateClosed = "#" & c.UserProperties.Item("DateClosed") & "#"
vIssueAge = CLng(CDbl(DateDiff("d",
c.UserProperties.Item("DateOpened"), c.UserProperties.Item("DateClosed"))))
Else
vDateClosed = "NULL"
vIssueAge = CLng(CDbl(DateDiff("d",
c.UserProperties.Item("DateOpened"), Now)))
End If
If DateDiff("d", c.UserProperties.Item("DateOpened"), Now()) < 8
Then
vOpenedPriorWeek = True
Else
vOpenedPriorWeek = False
End If
If c.UserProperties.Item("DateClosed") < #1/1/4501# And
DateDiff("d", c.UserProperties.Item("DateClosed"), Now()) < 8 Then
vClosedPriorWeek = True
Else
vClosedPriorWeek = False
End If
qdf.SQL = "insert into [IW Issues] " & _
"(IncidentNumber, Description, Status ,OpenedBy,
DateOpened, DateClosed, IssueAge, OpenedPriorWeek, ClosedPriorWeek, " & _
"Type, Environment, Urgency, Priority,
ClassificationType, ClassificationCategory, Object, Assignee, AssignStatus,
PackageNumber, " & _
"AffectedComponents, Source, RelatedIncident)
values (" & _
"""" & c.UserProperties.Item("Incident") & """,""" &
c.UserProperties.Item("Description") & """," & _
"""" & c.UserProperties.Item("IncidentStatus") &
""",""" & c.UserProperties.Item("OpenedBy") & """," & _
"#" & c.UserProperties.Item("DateOpened") & "#," &
vDateClosed & "," & _
vIssueAge & "," & vOpenedPriorWeek & "," &
vClosedPriorWeek & "," & _
"""" & c.UserProperties.Item("Issue Type") & ""","""
& c.UserProperties.Item("Environment") & """," & _
"""" & c.UserProperties.Item("IncidentUrgency") &
""",""" & c.UserProperties.Item("IncidentPriority") & """," & _
"""" & c.UserProperties.Item("IncidentType") &
""",""" & c.UserProperties.Item("IncidentCategory") & """," & _
"""" & c.UserProperties.Item("Object") & """,""" &
c.UserProperties.Item("Assignee") & """," & _
"""" & c.UserProperties.Item("Assign Status") &
""",""" & c.UserProperties.Item("Package") & """," & _
"""" & c.UserProperties.Item("Affected Components")
& """,""" & c.UserProperties.Item("Source") & """," & _
"""" & c.UserProperties.Item("RelatedIncident") &
""");"
qdf.Execute
' End If
Next i
wsp.CommitTrans
End Sub
Sub OpenExchange_Calendar()
Dim ADOConn As ADODB.Connection
Dim ADORS As ADODB.Recordset
Dim strConn As String
Set ADOConn = New ADODB.Connection
Set ADORS = New ADODB.Recordset
With ADOConn
.Provider = "Microsoft.JET.OLEDB.4.0"
.ConnectionString = "Exchange 4.0;" _
& "MAPILEVEL=Public Folders|All Public
Folders\Applications\;" _
& "[email protected];" _
& "TABLETYPE=0;DATABASE=C:\WINDOWS\TEMP\;"
.Open
End With
With ADORS
' .Open "Select * from Calendar", ADOConn, adOpenStatic, _
' adLockReadOnly
.Open "Select * from [IW Issues]", ADOConn, adOpenStatic, _
adLockReadOnly
End With
'For i = 1 To iNumTasks
'.MoveFirst
Debug.Print ADORS(3).Name, ADORS(3).Value
Debug.Print ADORS(10).Name, ADORS(10).Value
ADORS.Close
Set ADORS = Nothing
ADOConn.Close
Set ADOConn = Nothing
End Sub
Function EmailLateIssues()
Dim rst As DAO.Recordset, dbs As Database, qdf As QueryDef
Set rst = CurrentDb.OpenRecordset("LateIssues - Distinct Assignees")
Set dbs = CurrentDb
Set qdf = dbs.QueryDefs("LateIssues - Detail")
rst.MoveFirst
While Not rst.EOF
qdf.SQL = "SELECT IssuesWithAgeGroup.Assignee,
IssuesWithAgeGroup.IssueAge, IssuesWithAgeGroup.DateOpened,
IssuesWithAgeGroup.Type, IssuesWithAgeGroup.IncidentNumber,
IssuesWithAgeGroup.Description FROM IssuesWithAgeGroup WHERE
(((IssuesWithAgeGroup.IssueAge) >= 20) And ((IssuesWithAgeGroup.IssueGroup)
<> ""Development"") And ((IssuesWithAgeGroup.Status) = ""Open"") And
((IssuesWithAgeGroup.AssignStatus) <> ""Deferred"") and
IssuesWithAgeGroup.Assignee = """ & rst!Assignee & """) ORDER BY
IssuesWithAgeGroup.Assignee, IssuesWithAgeGroup.IssueAge DESC ,
IssuesWithAgeGroup.Type;"
DoCmd.SendObject acSendReport, "LateIssues - Detail", acFormatHTML,
rst!Assignee, , , "IW Production Issues Open > 20 Days", "Attached is a list
of Production issues assigned to you that have been open for more than 20
days. Please review and update where necessary. Thank you.", False
rst.MoveNext
Wend
End Function
Sorry for the lenght of the code; this was working before; No I get run time
error:-2147221233, An object can not be found; is the line with * on the
below code: set cf = ....
Why this error? and help is appreciated.
Thanks,
Dan
*************
Option Compare Database
Public Function ImportTasksFromOutlook()
' This code is based in Microsoft Access.
Dim rst As DAO.Recordset, dbs As Database, qdf As QueryDef
Dim ol As New Outlook.Application
Dim olns As Outlook.Namespace
Dim cf As Outlook.MAPIFolder
Dim c As Outlook.TaskItem
Dim objItems As Outlook.Items
'Dim Prop As Outlook.UserProperty
Dim vDateOpened As Date
'Dim vDateClosed As Date
Dim vIssueAge As Integer
Set rst = CurrentDb.OpenRecordset("IW Issues")
Set dbs = CurrentDb
Set qdf = dbs.QueryDefs("qry_dummy")
Set olns = ol.GetNamespace("MAPI")
'Set PF = olns.Folders("Public Folders").Folders("All Public Folders")
'Set AF = PF.Folders("Applications")
'Set HDFolder = AF.Folders("IW Issues")
'Set HDItems = HDFolder.Items
DoCmd.Hourglass (True)
'Set cf = olns.PickFolder ' .GetDefaultFolder (olFolderContacts)
*Set cf = olns.Folders("Public Folders").Folders("All Public
Folders").Folders("Applications").Folders("IW Issues")
Set objItems = cf.Items
qdf.SQL = "DELETE FROM [IW Issues];"
qdf.Execute
iNumTasks = objItems.Count
If iNumTasks <> 0 Then
For i = 1 To iNumTasks
Set c = objItems(i)
vDateOpened = c.UserProperties.Item("DateOpened")
'vDateClosed = c.UserProperties.Item("DateClosed")
rst.AddNew
If c.UserProperties.Item("DateClosed") < #1/1/4501# Then
vIssueAge = DateDiff("d", vDateOpened,
c.UserProperties.Item("DateClosed"))
rst!DateClosed = c.UserProperties.Item("DateClosed")
'vDateClosed = c.UserProperties.Item("DateClosed")
Else
vIssueAge = DateDiff("d", vDateOpened, Now)
End If
rst!IncidentNumber = c.UserProperties.Item("Incident")
rst!Description = c.UserProperties.Item("Description")
rst!Status = c.UserProperties.Item("IncidentStatus")
rst!OpenedBy = c.UserProperties.Item("OpenedBy")
rst!DateOpened = c.UserProperties.Item("DateOpened")
rst!IssueAge = vIssueAge
rst!Type = c.UserProperties.Item("Issue Type")
rst!Environment = c.UserProperties.Item("Environment")
rst!Urgency = c.UserProperties.Item("IncidentUrgency")
rst!Priority = c.UserProperties.Item("IncidentPriority")
rst!ClassificationType = c.UserProperties.Item("IncidentType")
rst!ClassificationCategory =
c.UserProperties.Item("IncidentCategory")
rst!Object = c.UserProperties.Item("Object")
rst!Assignee = c.UserProperties.Item("Assignee")
rst!AssignStatus = c.UserProperties.Item("Assign Status")
rst!PackageNumber = c.UserProperties.Item("Package")
rst!AffectedComponents = c.UserProperties.Item("Affected
Components")
rst!Source = c.UserProperties.Item("Source")
rst!RelatedIncident = c.UserProperties.Item("RelatedIncident")
rst!History = c.UserProperties.Item("History")
rst!User = c.UserProperties.Item("To")
' Custom Outlook properties would look like this:
' rst!AccessFieldName = c.UserProperties("OutlookPropertyName")
If DateDiff("d", vDateOpened, Now()) < 8 Then
rst!OpenedPriorWeek = True
Else
rst!OpenedPriorWeek = False
End If
If c.UserProperties.Item("DateClosed") < #1/1/4501# And
DateDiff("d", c.UserProperties.Item("DateClosed"), Now()) < 8 Then
rst!ClosedPriorWeek = True
Else
rst!ClosedPriorWeek = False
End If
rst.Update
Next i
End If
rst.Close
DoCmd.Hourglass (False)
MsgBox "Import Complete"
End Function
Sub ImportTasksFromOutlook1()
' This code is based in Microsoft Access.
Dim dbs As Database, qdf As QueryDef, rst As DAO.Recordset, rst2 As
DAO.Recordset, wsp As Workspace, rst3 As DAO.Recordset
Dim sqlstr As String
Dim ol As New Outlook.Application
Dim olns As Outlook.Namespace
Dim cf As Outlook.MAPIFolder
Dim c As Outlook.TaskItem
Dim objItems As Outlook.Items
Dim Prop As Outlook.UserProperty
Dim strSQL As String
Dim vIssueAge As Integer
Dim vOpenedPriorWeek As Boolean
Dim vClosedPriorWeek As Boolean
Dim vClosedDated As String
Set rst = CurrentDb.OpenRecordset("IW Issues")
Set wsp = DBEngine.Workspaces(0)
Set dbs = CurrentDb
Set qdf = dbs.QueryDefs("qry_dummy")
Set olns = ol.GetNamespace("MAPI")
Set cf = olns.PickFolder ' .GetDefaultFolder (olFolderContacts)
Set objItems = cf.Items
qdf.SQL = "DELETE FROM [IW Issues];"
qdf.Execute
iNumTasks = objItems.Count
wsp.BeginTrans
For i = 1 To iNumTasks
' If TypeName(objItems(i)) = "TaskItem" Then
Set c = objItems(i)
If c.UserProperties.Item("DateClosed") < #1/1/4501# Then
vDateClosed = "#" & c.UserProperties.Item("DateClosed") & "#"
vIssueAge = CLng(CDbl(DateDiff("d",
c.UserProperties.Item("DateOpened"), c.UserProperties.Item("DateClosed"))))
Else
vDateClosed = "NULL"
vIssueAge = CLng(CDbl(DateDiff("d",
c.UserProperties.Item("DateOpened"), Now)))
End If
If DateDiff("d", c.UserProperties.Item("DateOpened"), Now()) < 8
Then
vOpenedPriorWeek = True
Else
vOpenedPriorWeek = False
End If
If c.UserProperties.Item("DateClosed") < #1/1/4501# And
DateDiff("d", c.UserProperties.Item("DateClosed"), Now()) < 8 Then
vClosedPriorWeek = True
Else
vClosedPriorWeek = False
End If
qdf.SQL = "insert into [IW Issues] " & _
"(IncidentNumber, Description, Status ,OpenedBy,
DateOpened, DateClosed, IssueAge, OpenedPriorWeek, ClosedPriorWeek, " & _
"Type, Environment, Urgency, Priority,
ClassificationType, ClassificationCategory, Object, Assignee, AssignStatus,
PackageNumber, " & _
"AffectedComponents, Source, RelatedIncident)
values (" & _
"""" & c.UserProperties.Item("Incident") & """,""" &
c.UserProperties.Item("Description") & """," & _
"""" & c.UserProperties.Item("IncidentStatus") &
""",""" & c.UserProperties.Item("OpenedBy") & """," & _
"#" & c.UserProperties.Item("DateOpened") & "#," &
vDateClosed & "," & _
vIssueAge & "," & vOpenedPriorWeek & "," &
vClosedPriorWeek & "," & _
"""" & c.UserProperties.Item("Issue Type") & ""","""
& c.UserProperties.Item("Environment") & """," & _
"""" & c.UserProperties.Item("IncidentUrgency") &
""",""" & c.UserProperties.Item("IncidentPriority") & """," & _
"""" & c.UserProperties.Item("IncidentType") &
""",""" & c.UserProperties.Item("IncidentCategory") & """," & _
"""" & c.UserProperties.Item("Object") & """,""" &
c.UserProperties.Item("Assignee") & """," & _
"""" & c.UserProperties.Item("Assign Status") &
""",""" & c.UserProperties.Item("Package") & """," & _
"""" & c.UserProperties.Item("Affected Components")
& """,""" & c.UserProperties.Item("Source") & """," & _
"""" & c.UserProperties.Item("RelatedIncident") &
""");"
qdf.Execute
' End If
Next i
wsp.CommitTrans
End Sub
Sub OpenExchange_Calendar()
Dim ADOConn As ADODB.Connection
Dim ADORS As ADODB.Recordset
Dim strConn As String
Set ADOConn = New ADODB.Connection
Set ADORS = New ADODB.Recordset
With ADOConn
.Provider = "Microsoft.JET.OLEDB.4.0"
.ConnectionString = "Exchange 4.0;" _
& "MAPILEVEL=Public Folders|All Public
Folders\Applications\;" _
& "[email protected];" _
& "TABLETYPE=0;DATABASE=C:\WINDOWS\TEMP\;"
.Open
End With
With ADORS
' .Open "Select * from Calendar", ADOConn, adOpenStatic, _
' adLockReadOnly
.Open "Select * from [IW Issues]", ADOConn, adOpenStatic, _
adLockReadOnly
End With
'For i = 1 To iNumTasks
'.MoveFirst
Debug.Print ADORS(3).Name, ADORS(3).Value
Debug.Print ADORS(10).Name, ADORS(10).Value
ADORS.Close
Set ADORS = Nothing
ADOConn.Close
Set ADOConn = Nothing
End Sub
Function EmailLateIssues()
Dim rst As DAO.Recordset, dbs As Database, qdf As QueryDef
Set rst = CurrentDb.OpenRecordset("LateIssues - Distinct Assignees")
Set dbs = CurrentDb
Set qdf = dbs.QueryDefs("LateIssues - Detail")
rst.MoveFirst
While Not rst.EOF
qdf.SQL = "SELECT IssuesWithAgeGroup.Assignee,
IssuesWithAgeGroup.IssueAge, IssuesWithAgeGroup.DateOpened,
IssuesWithAgeGroup.Type, IssuesWithAgeGroup.IncidentNumber,
IssuesWithAgeGroup.Description FROM IssuesWithAgeGroup WHERE
(((IssuesWithAgeGroup.IssueAge) >= 20) And ((IssuesWithAgeGroup.IssueGroup)
<> ""Development"") And ((IssuesWithAgeGroup.Status) = ""Open"") And
((IssuesWithAgeGroup.AssignStatus) <> ""Deferred"") and
IssuesWithAgeGroup.Assignee = """ & rst!Assignee & """) ORDER BY
IssuesWithAgeGroup.Assignee, IssuesWithAgeGroup.IssueAge DESC ,
IssuesWithAgeGroup.Type;"
DoCmd.SendObject acSendReport, "LateIssues - Detail", acFormatHTML,
rst!Assignee, , , "IW Production Issues Open > 20 Days", "Attached is a list
of Production issues assigned to you that have been open for more than 20
days. Please review and update where necessary. Thank you.", False
rst.MoveNext
Wend
End Function