Sue Mosher said:Try using Find instead of Restrict and in the example below, use objMinItems.GetFirst and GetNext instead of a For Each loop, setting objMinItem and objCDOItem to Nothing before reusing them. I'm not sure that will do the trick, but it's the logical thing to try.
--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers
Vaughan said:Sadly, Sue, the situation is still the same.
Reworked code is as follows. I would be eternally grateful for some more
help with this.
Sub TransferMinutesToAccess()
On Error Resume Next
Dim objADOConn As Object
Dim objADORS As Object
Dim objMinItem As Object
Dim objMinItems As Outlook.Items
Dim objFolder As Object
Dim arrMinItem(12) As Variant
Dim objFlag As Object
Dim objFlagText As Object
strMinFolderPath = "Public Folders\All Public Folders\Projects\Project
Details\Minutes"
Set objADOConn = New ADODB.Connection
objADOConn.Open "DSN=ProjectPacks"
Set objADORS = New ADODB.RecordSet
With objADORS
.Open "Select * From tbl_ExchangeMinutes", objADOConn,
adOpenStatic,
adLockOptimistic
If Not .BOF Then
.MoveFirst
While Not .EOF
.Delete
.MoveNext
Wend
End If
End With
DoCDOLogon
Set objFolder = GetFolder(strMinFolderPath)
Set objMinItems = objFolder.Items
Set objMinItem = objMinItems.Find("[Message Class] <>
""IPM.Post.Meeting_Header""")
Do While Not objMinItem Is Nothing
Set objCDOItem = GetCDOItemFromOL(objMinItem)
Set objFields = objCDOItem.Fields
arrMinItem(1) = objMinItem.UserProperties("Meeting Description")
arrMinItem(2) = objMinItem.UserProperties("Job")
arrMinItem(3) = objMinItem.UserProperties("MeetingDate")
arrMinItem(4) = objMinItem.Body
arrMinItem(5) = objMinItem.ConversationIndex
arrMinItem(6) = objMinItem.UserProperties("AssignedTo")
arrMinItem(7) = objMinItem.UserProperties("DueDate")
Set objFlag = objFields.Item(&H10900003)
If Err.Number <> 0 Then
arrMinItem(8) = 1000
Err.Clear
Else
arrMinItem(8) = objFlag.Value
End If
Set objFlagText = objFields.Item("0x8530",
"0820060000000000C000000000000046")
If Err.Number <> 0 Then
arrMinItem(9) = ""
Err.Clear
Else
arrMinItem(9) = objFlagText.Value
End If
arrMinItem(10) = objMinItem.UserProperties("MeetingThread")
arrMinItem(11) = objMinItem.ConversationTopic
arrMinItem(12) = objMinItem.MessageClass
objADORS.AddNew
For n = 1 To 12
objADORS(n) = arrMinItem(n)
Set arrMinItem(n) = Nothing
Next n
objADORS.Update
Set objNewRec = Nothing
Set objFlag = Nothing
Set objFlagText = Nothing
Set objFields = Nothing
Set objCDOItem = Nothing
Set GetCDOItemFromOL(objMinItem) = Nothing
Set objMinItem = Nothing
Set objMinItem = objMinItems.FindNext
Loop
objADORS.Close
Set objADORS = Nothing
objADOConn.Close
Set objADOConn = Nothing
Set objFields = Nothing
DoCDOLogoff
End Sub
Vaughan said:Many thanks Sue, I'll give these a try.
Vaughan
Dmitry Streblechenko said:Try to store the UserProperties collection in a separate variable:
set UserProperties = objMinItem.UserProperties
arrMinItem(1) = UserProperties("Meeting Description")
....
set UserProperties = Nothing
Or, better yet, move the item processing logic inside of the while loop into
a separate sub to make sure all local variables are properly dereferenced
when the sub exits
Do While Not objMinItem Is Nothing
ProcessItem(objMinItem)
Set objMinItem = objMinItems.FindNext
Loop
Dmitry Streblechenko (MVP)
http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool
Vaughan said:Sadly, Sue, the situation is still the same.
Reworked code is as follows. I would be eternally grateful for some more
help with this.
Sub TransferMinutesToAccess()
On Error Resume Next
Dim objADOConn As Object
Dim objADORS As Object
Dim objMinItem As Object
Dim objMinItems As Outlook.Items
Dim objFolder As Object
Dim arrMinItem(12) As Variant
Dim objFlag As Object
Dim objFlagText As Object
strMinFolderPath = "Public Folders\All Public Folders\Projects\Project
Details\Minutes"
Set objADOConn = New ADODB.Connection
objADOConn.Open "DSN=ProjectPacks"
Set objADORS = New ADODB.RecordSet
With objADORS
.Open "Select * From tbl_ExchangeMinutes", objADOConn,
adOpenStatic,
adLockOptimistic
If Not .BOF Then
.MoveFirst
While Not .EOF
.Delete
.MoveNext
Wend
End If
End With
DoCDOLogon
Set objFolder = GetFolder(strMinFolderPath)
Set objMinItems = objFolder.Items
Set objMinItem = objMinItems.Find("[Message Class] <>
""IPM.Post.Meeting_Header""")
Do While Not objMinItem Is Nothing
Set objCDOItem = GetCDOItemFromOL(objMinItem)
Set objFields = objCDOItem.Fields
arrMinItem(1) = objMinItem.UserProperties("Meeting Description")
arrMinItem(2) = objMinItem.UserProperties("Job")
arrMinItem(3) = objMinItem.UserProperties("MeetingDate")
arrMinItem(4) = objMinItem.Body
arrMinItem(5) = objMinItem.ConversationIndex
arrMinItem(6) = objMinItem.UserProperties("AssignedTo")
arrMinItem(7) = objMinItem.UserProperties("DueDate")
Set objFlag = objFields.Item(&H10900003)
If Err.Number <> 0 Then
arrMinItem(8) = 1000
Err.Clear
Else
arrMinItem(8) = objFlag.Value
End If
Set objFlagText = objFields.Item("0x8530",
"0820060000000000C000000000000046")
If Err.Number <> 0 Then
arrMinItem(9) = ""
Err.Clear
Else
arrMinItem(9) = objFlagText.Value
End If
arrMinItem(10) = objMinItem.UserProperties("MeetingThread")
arrMinItem(11) = objMinItem.ConversationTopic
arrMinItem(12) = objMinItem.MessageClass
objADORS.AddNew
For n = 1 To 12
objADORS(n) = arrMinItem(n)
Set arrMinItem(n) = Nothing
Next n
objADORS.Update
Set objNewRec = Nothing
Set objFlag = Nothing
Set objFlagText = Nothing
Set objFields = Nothing
Set objCDOItem = Nothing
Set GetCDOItemFromOL(objMinItem) = Nothing
Set objMinItem = Nothing
Set objMinItem = objMinItems.FindNext
Loop
objADORS.Close
Set objADORS = Nothing
objADOConn.Close
Set objADOConn = Nothing
Set objFields = Nothing
DoCDOLogoff
End Sub
Vaughan said:Many thanks Sue, I'll give these a try.
Vaughan
:
Try using Find instead of Restrict and in the example below, use
objMinItems.GetFirst and GetNext instead of a For Each loop, setting
objMinItem and objCDOItem to Nothing before reusing them. I'm not sure
that will do the trick, but it's the logical thing to try.
--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers
Thanks for your patience Sue.
I am using Outlook VBA v 6.2. My code is as follows:
Sub TransferMinutesToAccess()
On Error Resume Next
Dim objADOConn As Object
Dim objADORS As Object
Dim objMinItem As Object
Dim objMinItems As Outlook.Items
Dim objFolder As Object
Dim arrMinItem(12) As Variant
Dim dtmMinItem As Date
Dim intUniqueNo As Integer
Dim objFlag As Object
Dim objFlagText As Object
strMinFolderPath = "Public Folders\All Public
Folders\Projects\Project _
Details\Minutes"
Set objADOConn = New ADODB.Connection
Set objADORS = New ADODB.RecordSet
objADOConn.Open "DSN=ProjectPacks"
With objADORS
.Open "Select * From tbl_ExchangeMinutes", objADOConn,
adOpenStatic, _
adLockOptimistic
If Not .BOF Then
.MoveFirst
While Not .EOF
.Delete
.MoveNext
Wend
End If
End With
DoCDOLogon
Set objFolder = GetFolder(strMinFolderPath)
Set objMinItems = objFolder.Items
For Each objMinItem In objMinItems
If objMinItem.MessageClass <> "IPM.Post.Meeting_Header" Then
Set objCDOItem = GetCDOItemFromOL(objMinItem)
Set objFields = objCDOItem.Fields
arrMinItem(1) = objMinItem.UserProperties("Meeting
Description")
arrMinItem(2) = objMinItem.UserProperties("Job")
arrMinItem(3) = objMinItem.UserProperties("MeetingDate")
arrMinItem(4) = objMinItem.Body
arrMinItem(5) = objMinItem.ConversationIndex
arrMinItem(6) = objMinItem.UserProperties("AssignedTo")
arrMinItem(7) = objMinItem.UserProperties("DueDate")
Set objFlag = objFields.Item(&H10900003)
If Err.Number <> 0 Then
arrMinItem(8) = 1000
Err.Clear
Else
arrMinItem(8) = objFlag.Value
End If
Set objFlagText = objFields.Item _("0x8530",
"0820060000000000C000000000000046")
If Err.Number <> 0 Then
arrMinItem(9) = ""
Err.Clear
Else
arrMinItem(9) = objFlagText.Value
End If
arrMinItem(10) =
objMinItem.UserProperties("MeetingThread")
arrMinItem(11) = objMinItem.ConversationTopic
arrMinItem(12) = objMinItem.MessageClass
Set objNewRec = objADORS.AddNew
For n = 1 To 12
objADORS(n) = arrMinItem(n)
Set arrMinItem(n) = Nothing
Next n
End If
objADORS.Update
Set objNewRec = Nothing
Set objFlag = Nothing
Set objFlagText = Nothing
Set objFields = Nothing
Set objCDOItem = Nothing
Set objMinItem = Nothing
Set GetCDOItemFromOL(objMinItem) = Nothing
Next
objADORS.Close
Set objADORS = Nothing
objADOConn.Close
Set objADOConn = Nothing
Set objFields = Nothing
DoCDOLogoff
Exit Sub
End Sub
:
In what programming language?
--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers
Sorry Sue. Yes OL2003 and Exchange2003.
Sounds promising. How do I dereference the item object variables?
:
You didn't mention the Outlook version or mail configuration or
coding environment, but it sounds like you're running Outlook
2003 against an Exchange and running up against the limit on open
RPC channels. Make sure you dereference item object variables as
you use them. If you're using VS.NET, you'll need to perform
garbage collection periodically.
I am using the restrict method to return a collection of the
items in a
public folder. Only the first 249 items returned appear to
contain any data,
anything after that is just a heap of nothing. Is this a limit
on Restrict's
functionality?
Vaughan said:Thanks Dmitri. I tried what you said. I have progressively moved
everything
to do with processing the items into the separate sub until there is
virtually nothing left in the main sub. Still no joy.
My code looks like this now, and its really slow. Any insights would be
most
gratefully received.
Thanks again for your interest and help
Vaughan
Sub TransferMinutesToAccess()
On Error Resume Next
Dim objADOConn As Object
Dim objADORS As Object
Dim objMinItem As Object
Dim objMinItems As Outlook.Items
Dim objFolder As Object
strMinFolderPath = "Public Folders\All Public Folders\Projects\Project
Details\Minutes"
Set objADOConn = New ADODB.Connection
objADOConn.Open "DSN=ProjectPacks"
Set objADORS = New ADODB.RecordSet
With objADORS
.Open "Select * From tbl_ExchangeMinutes", objADOConn,
adOpenStatic,
adLockOptimistic
If Not .BOF Then
.MoveFirst
While Not .EOF
.Delete
.MoveNext
Wend
End If
End With
objADORS.Close
Set objADORS = Nothing
objADOConn.Close
Set objADOConn = Nothing
Set objFolder = GetFolder(strMinFolderPath)
Set objMinItems = objFolder.Items
Set objMinItem = objMinItems.Find("[Message Class] <>
""IPM.Post.Meeting_Header""")
Do While Not objMinItem Is Nothing
Call GetRecordData(objMinItem)
Set objMinItem = objMinItems.FindNext
Loop
Set objMinItem = Nothing
Set objMinItems = Nothing
Set objFolder = Nothing
End Sub
Sub GetRecordData(ByVal objMinIt As Object)
On Error Resume Next
Dim arrMinItem(13) As Variant
Dim objCDOItem As Object
Dim objFields As Object
Dim objFlag As Object
Dim objFlagText As Object
Dim objUserProps As Object
Dim objADORS As Object
Dim objADOConn As Object
Dim n As Integer
DoCDOLogon
Set objCDOItem = GetCDOItemFromOL(objMinIt)
DoCDOLogoff
Set objFields = objCDOItem.Fields
Set objUserProps = objMinIt.UserProperties
Set arrMinItem(0) = Nothing
Set objADOConn = New ADODB.Connection
objADOConn.Open "DSN=ProjectPacks"
Set objADORS = New ADODB.RecordSet
objADORS.Open "Select * From tbl_ExchangeMinutes", objADOConn,
adOpenStatic, adLockOptimistic
arrMinItem(1) = objUserProps("Meeting Description")
arrMinItem(2) = objUserProps("Job")
arrMinItem(3) = objUserProps("MeetingDate")
arrMinItem(4) = objMinIt.Body
arrMinItem(5) = objMinIt.ConversationIndex
arrMinItem(6) = objUserProps("AssignedTo")
arrMinItem(7) = objUserProps("DueDate")
Set objFlag = objFields.Item(&H10900003)
If Err.Number <> 0 Then
arrMinItem(8) = 1000
Err.Clear
Else
arrMinItem(8) = objFlag.Value
End If
Set objFlagText = objFields.Item("0x8530",
"0820060000000000C000000000000046")
If Err.Number <> 0 Then
arrMinItem(9) = ""
Err.Clear
Else
arrMinItem(9) = objFlagText.Value
End If
arrMinItem(10) = objUserProps("MeetingThread")
arrMinItem(11) = objMinIt.ConversationTopic
arrMinItem(12) = objMinIt.MessageClass
objADORS.AddNew
For n = 0 To 12
objADORS(n) = arrMinItem(n)
Set arrMinItem(n) = Nothing
Next n
objADORS.Update
objADORS.Close
objADOConn.Close
Set objADORS = Nothing
Set objADOConn = Nothing
Set objUserProps = Nothing
Set objFlag = Nothing
Set objFlagText = Nothing
Set objFields = Nothing
Set objCDOItem = Nothing
Set objADORS = Nothing
Set objMinIt = Nothing
End Sub
Dmitry Streblechenko said:Try to store the UserProperties collection in a separate variable:
set UserProperties = objMinItem.UserProperties
arrMinItem(1) = UserProperties("Meeting Description")
....
set UserProperties = Nothing
Or, better yet, move the item processing logic inside of the while loop
into
a separate sub to make sure all local variables are properly dereferenced
when the sub exits
Do While Not objMinItem Is Nothing
ProcessItem(objMinItem)
Set objMinItem = objMinItems.FindNext
Loop
Dmitry Streblechenko (MVP)
http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool
Vaughan said:Sadly, Sue, the situation is still the same.
Reworked code is as follows. I would be eternally grateful for some
more
help with this.
Sub TransferMinutesToAccess()
On Error Resume Next
Dim objADOConn As Object
Dim objADORS As Object
Dim objMinItem As Object
Dim objMinItems As Outlook.Items
Dim objFolder As Object
Dim arrMinItem(12) As Variant
Dim objFlag As Object
Dim objFlagText As Object
strMinFolderPath = "Public Folders\All Public
Folders\Projects\Project
Details\Minutes"
Set objADOConn = New ADODB.Connection
objADOConn.Open "DSN=ProjectPacks"
Set objADORS = New ADODB.RecordSet
With objADORS
.Open "Select * From tbl_ExchangeMinutes", objADOConn,
adOpenStatic,
adLockOptimistic
If Not .BOF Then
.MoveFirst
While Not .EOF
.Delete
.MoveNext
Wend
End If
End With
DoCDOLogon
Set objFolder = GetFolder(strMinFolderPath)
Set objMinItems = objFolder.Items
Set objMinItem = objMinItems.Find("[Message Class] <>
""IPM.Post.Meeting_Header""")
Do While Not objMinItem Is Nothing
Set objCDOItem = GetCDOItemFromOL(objMinItem)
Set objFields = objCDOItem.Fields
arrMinItem(1) = objMinItem.UserProperties("Meeting Description")
arrMinItem(2) = objMinItem.UserProperties("Job")
arrMinItem(3) = objMinItem.UserProperties("MeetingDate")
arrMinItem(4) = objMinItem.Body
arrMinItem(5) = objMinItem.ConversationIndex
arrMinItem(6) = objMinItem.UserProperties("AssignedTo")
arrMinItem(7) = objMinItem.UserProperties("DueDate")
Set objFlag = objFields.Item(&H10900003)
If Err.Number <> 0 Then
arrMinItem(8) = 1000
Err.Clear
Else
arrMinItem(8) = objFlag.Value
End If
Set objFlagText = objFields.Item("0x8530",
"0820060000000000C000000000000046")
If Err.Number <> 0 Then
arrMinItem(9) = ""
Err.Clear
Else
arrMinItem(9) = objFlagText.Value
End If
arrMinItem(10) = objMinItem.UserProperties("MeetingThread")
arrMinItem(11) = objMinItem.ConversationTopic
arrMinItem(12) = objMinItem.MessageClass
objADORS.AddNew
For n = 1 To 12
objADORS(n) = arrMinItem(n)
Set arrMinItem(n) = Nothing
Next n
objADORS.Update
Set objNewRec = Nothing
Set objFlag = Nothing
Set objFlagText = Nothing
Set objFields = Nothing
Set objCDOItem = Nothing
Set GetCDOItemFromOL(objMinItem) = Nothing
Set objMinItem = Nothing
Set objMinItem = objMinItems.FindNext
Loop
objADORS.Close
Set objADORS = Nothing
objADOConn.Close
Set objADOConn = Nothing
Set objFields = Nothing
DoCDOLogoff
End Sub
:
Many thanks Sue, I'll give these a try.
Vaughan
:
Try using Find instead of Restrict and in the example below, use
objMinItems.GetFirst and GetNext instead of a For Each loop, setting
objMinItem and objCDOItem to Nothing before reusing them. I'm not
sure
that will do the trick, but it's the logical thing to try.
--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers
Thanks for your patience Sue.
I am using Outlook VBA v 6.2. My code is as follows:
Sub TransferMinutesToAccess()
On Error Resume Next
Dim objADOConn As Object
Dim objADORS As Object
Dim objMinItem As Object
Dim objMinItems As Outlook.Items
Dim objFolder As Object
Dim arrMinItem(12) As Variant
Dim dtmMinItem As Date
Dim intUniqueNo As Integer
Dim objFlag As Object
Dim objFlagText As Object
strMinFolderPath = "Public Folders\All Public
Folders\Projects\Project _
Details\Minutes"
Set objADOConn = New ADODB.Connection
Set objADORS = New ADODB.RecordSet
objADOConn.Open "DSN=ProjectPacks"
With objADORS
.Open "Select * From tbl_ExchangeMinutes", objADOConn,
adOpenStatic, _
adLockOptimistic
If Not .BOF Then
.MoveFirst
While Not .EOF
.Delete
.MoveNext
Wend
End If
End With
DoCDOLogon
Set objFolder = GetFolder(strMinFolderPath)
Set objMinItems = objFolder.Items
For Each objMinItem In objMinItems
If objMinItem.MessageClass <> "IPM.Post.Meeting_Header"
Then
Set objCDOItem = GetCDOItemFromOL(objMinItem)
Set objFields = objCDOItem.Fields
arrMinItem(1) = objMinItem.UserProperties("Meeting
Description")
arrMinItem(2) = objMinItem.UserProperties("Job")
arrMinItem(3) =
objMinItem.UserProperties("MeetingDate")
arrMinItem(4) = objMinItem.Body
arrMinItem(5) = objMinItem.ConversationIndex
arrMinItem(6) = objMinItem.UserProperties("AssignedTo")
arrMinItem(7) = objMinItem.UserProperties("DueDate")
Set objFlag = objFields.Item(&H10900003)
If Err.Number <> 0 Then
arrMinItem(8) = 1000
Err.Clear
Else
arrMinItem(8) = objFlag.Value
End If
Set objFlagText = objFields.Item _("0x8530",
"0820060000000000C000000000000046")
If Err.Number <> 0 Then
arrMinItem(9) = ""
Err.Clear
Else
arrMinItem(9) = objFlagText.Value
End If
arrMinItem(10) =
objMinItem.UserProperties("MeetingThread")
arrMinItem(11) = objMinItem.ConversationTopic
arrMinItem(12) = objMinItem.MessageClass
Set objNewRec = objADORS.AddNew
For n = 1 To 12
objADORS(n) = arrMinItem(n)
Set arrMinItem(n) = Nothing
Next n
End If
objADORS.Update
Set objNewRec = Nothing
Set objFlag = Nothing
Set objFlagText = Nothing
Set objFields = Nothing
Set objCDOItem = Nothing
Set objMinItem = Nothing
Set GetCDOItemFromOL(objMinItem) = Nothing
Next
objADORS.Close
Set objADORS = Nothing
objADOConn.Close
Set objADOConn = Nothing
Set objFields = Nothing
DoCDOLogoff
Exit Sub
End Sub
:
In what programming language?
--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers
Sorry Sue. Yes OL2003 and Exchange2003.
Sounds promising. How do I dereference the item object
variables?
:
You didn't mention the Outlook version or mail configuration
or
coding environment, but it sounds like you're running Outlook
2003 against an Exchange and running up against the limit on
open
RPC channels. Make sure you dereference item object variables
as
you use them. If you're using VS.NET, you'll need to perform
garbage collection periodically.
I am using the restrict method to return a collection of the
items in a
public folder. Only the first 249 items returned appear to
contain any data,
anything after that is just a heap of nothing. Is this a
limit
on Restrict's
functionality?
Dmitry Streblechenko said:How many items can you process now?
Dmitry Streblechenko (MVP)
http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool
Vaughan said:Thanks Dmitri. I tried what you said. I have progressively moved
everything
to do with processing the items into the separate sub until there is
virtually nothing left in the main sub. Still no joy.
My code looks like this now, and its really slow. Any insights would be
most
gratefully received.
Thanks again for your interest and help
Vaughan
Sub TransferMinutesToAccess()
On Error Resume Next
Dim objADOConn As Object
Dim objADORS As Object
Dim objMinItem As Object
Dim objMinItems As Outlook.Items
Dim objFolder As Object
strMinFolderPath = "Public Folders\All Public Folders\Projects\Project
Details\Minutes"
Set objADOConn = New ADODB.Connection
objADOConn.Open "DSN=ProjectPacks"
Set objADORS = New ADODB.RecordSet
With objADORS
.Open "Select * From tbl_ExchangeMinutes", objADOConn,
adOpenStatic,
adLockOptimistic
If Not .BOF Then
.MoveFirst
While Not .EOF
.Delete
.MoveNext
Wend
End If
End With
objADORS.Close
Set objADORS = Nothing
objADOConn.Close
Set objADOConn = Nothing
Set objFolder = GetFolder(strMinFolderPath)
Set objMinItems = objFolder.Items
Set objMinItem = objMinItems.Find("[Message Class] <>
""IPM.Post.Meeting_Header""")
Do While Not objMinItem Is Nothing
Call GetRecordData(objMinItem)
Set objMinItem = objMinItems.FindNext
Loop
Set objMinItem = Nothing
Set objMinItems = Nothing
Set objFolder = Nothing
End Sub
Sub GetRecordData(ByVal objMinIt As Object)
On Error Resume Next
Dim arrMinItem(13) As Variant
Dim objCDOItem As Object
Dim objFields As Object
Dim objFlag As Object
Dim objFlagText As Object
Dim objUserProps As Object
Dim objADORS As Object
Dim objADOConn As Object
Dim n As Integer
DoCDOLogon
Set objCDOItem = GetCDOItemFromOL(objMinIt)
DoCDOLogoff
Set objFields = objCDOItem.Fields
Set objUserProps = objMinIt.UserProperties
Set arrMinItem(0) = Nothing
Set objADOConn = New ADODB.Connection
objADOConn.Open "DSN=ProjectPacks"
Set objADORS = New ADODB.RecordSet
objADORS.Open "Select * From tbl_ExchangeMinutes", objADOConn,
adOpenStatic, adLockOptimistic
arrMinItem(1) = objUserProps("Meeting Description")
arrMinItem(2) = objUserProps("Job")
arrMinItem(3) = objUserProps("MeetingDate")
arrMinItem(4) = objMinIt.Body
arrMinItem(5) = objMinIt.ConversationIndex
arrMinItem(6) = objUserProps("AssignedTo")
arrMinItem(7) = objUserProps("DueDate")
Set objFlag = objFields.Item(&H10900003)
If Err.Number <> 0 Then
arrMinItem(8) = 1000
Err.Clear
Else
arrMinItem(8) = objFlag.Value
End If
Set objFlagText = objFields.Item("0x8530",
"0820060000000000C000000000000046")
If Err.Number <> 0 Then
arrMinItem(9) = ""
Err.Clear
Else
arrMinItem(9) = objFlagText.Value
End If
arrMinItem(10) = objUserProps("MeetingThread")
arrMinItem(11) = objMinIt.ConversationTopic
arrMinItem(12) = objMinIt.MessageClass
objADORS.AddNew
For n = 0 To 12
objADORS(n) = arrMinItem(n)
Set arrMinItem(n) = Nothing
Next n
objADORS.Update
objADORS.Close
objADOConn.Close
Set objADORS = Nothing
Set objADOConn = Nothing
Set objUserProps = Nothing
Set objFlag = Nothing
Set objFlagText = Nothing
Set objFields = Nothing
Set objCDOItem = Nothing
Set objADORS = Nothing
Set objMinIt = Nothing
End Sub
Dmitry Streblechenko said:Try to store the UserProperties collection in a separate variable:
set UserProperties = objMinItem.UserProperties
arrMinItem(1) = UserProperties("Meeting Description")
....
set UserProperties = Nothing
Or, better yet, move the item processing logic inside of the while loop
into
a separate sub to make sure all local variables are properly dereferenced
when the sub exits
Do While Not objMinItem Is Nothing
ProcessItem(objMinItem)
Set objMinItem = objMinItems.FindNext
Loop
Dmitry Streblechenko (MVP)
http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool
Sadly, Sue, the situation is still the same.
Reworked code is as follows. I would be eternally grateful for some
more
help with this.
Sub TransferMinutesToAccess()
On Error Resume Next
Dim objADOConn As Object
Dim objADORS As Object
Dim objMinItem As Object
Dim objMinItems As Outlook.Items
Dim objFolder As Object
Dim arrMinItem(12) As Variant
Dim objFlag As Object
Dim objFlagText As Object
strMinFolderPath = "Public Folders\All Public
Folders\Projects\Project
Details\Minutes"
Set objADOConn = New ADODB.Connection
objADOConn.Open "DSN=ProjectPacks"
Set objADORS = New ADODB.RecordSet
With objADORS
.Open "Select * From tbl_ExchangeMinutes", objADOConn,
adOpenStatic,
adLockOptimistic
If Not .BOF Then
.MoveFirst
While Not .EOF
.Delete
.MoveNext
Wend
End If
End With
DoCDOLogon
Set objFolder = GetFolder(strMinFolderPath)
Set objMinItems = objFolder.Items
Set objMinItem = objMinItems.Find("[Message Class] <>
""IPM.Post.Meeting_Header""")
Do While Not objMinItem Is Nothing
Set objCDOItem = GetCDOItemFromOL(objMinItem)
Set objFields = objCDOItem.Fields
arrMinItem(1) = objMinItem.UserProperties("Meeting Description")
arrMinItem(2) = objMinItem.UserProperties("Job")
arrMinItem(3) = objMinItem.UserProperties("MeetingDate")
arrMinItem(4) = objMinItem.Body
arrMinItem(5) = objMinItem.ConversationIndex
arrMinItem(6) = objMinItem.UserProperties("AssignedTo")
arrMinItem(7) = objMinItem.UserProperties("DueDate")
Set objFlag = objFields.Item(&H10900003)
If Err.Number <> 0 Then
arrMinItem(8) = 1000
Err.Clear
Else
arrMinItem(8) = objFlag.Value
End If
Set objFlagText = objFields.Item("0x8530",
"0820060000000000C000000000000046")
If Err.Number <> 0 Then
arrMinItem(9) = ""
Err.Clear
Else
arrMinItem(9) = objFlagText.Value
End If
arrMinItem(10) = objMinItem.UserProperties("MeetingThread")
arrMinItem(11) = objMinItem.ConversationTopic
arrMinItem(12) = objMinItem.MessageClass
objADORS.AddNew
For n = 1 To 12
objADORS(n) = arrMinItem(n)
Set arrMinItem(n) = Nothing
Next n
objADORS.Update
Set objNewRec = Nothing
Set objFlag = Nothing
Set objFlagText = Nothing
Set objFields = Nothing
Set objCDOItem = Nothing
Set GetCDOItemFromOL(objMinItem) = Nothing
Set objMinItem = Nothing
Set objMinItem = objMinItems.FindNext
Loop
objADORS.Close
Set objADORS = Nothing
objADOConn.Close
Set objADOConn = Nothing
Set objFields = Nothing
DoCDOLogoff
End Sub
:
Many thanks Sue, I'll give these a try.
Vaughan
:
Try using Find instead of Restrict and in the example below, use
objMinItems.GetFirst and GetNext instead of a For Each loop, setting
objMinItem and objCDOItem to Nothing before reusing them. I'm not
sure
that will do the trick, but it's the logical thing to try.
--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers
Thanks for your patience Sue.
I am using Outlook VBA v 6.2. My code is as follows:
Sub TransferMinutesToAccess()
On Error Resume Next
Dim objADOConn As Object
Dim objADORS As Object
Dim objMinItem As Object
Dim objMinItems As Outlook.Items
Dim objFolder As Object
Vaughan said:Still exactly 249 items Dmitry.
Dmitry Streblechenko said:How many items can you process now?
Dmitry Streblechenko (MVP)
http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool
Vaughan said:Thanks Dmitri. I tried what you said. I have progressively moved
everything
to do with processing the items into the separate sub until there is
virtually nothing left in the main sub. Still no joy.
My code looks like this now, and its really slow. Any insights would be
most
gratefully received.
Thanks again for your interest and help
Vaughan
Sub TransferMinutesToAccess()
On Error Resume Next
Dim objADOConn As Object
Dim objADORS As Object
Dim objMinItem As Object
Dim objMinItems As Outlook.Items
Dim objFolder As Object
strMinFolderPath = "Public Folders\All Public Folders\Projects\Project
Details\Minutes"
Set objADOConn = New ADODB.Connection
objADOConn.Open "DSN=ProjectPacks"
Set objADORS = New ADODB.RecordSet
With objADORS
.Open "Select * From tbl_ExchangeMinutes", objADOConn,
adOpenStatic,
adLockOptimistic
If Not .BOF Then
.MoveFirst
While Not .EOF
.Delete
.MoveNext
Wend
End If
End With
objADORS.Close
Set objADORS = Nothing
objADOConn.Close
Set objADOConn = Nothing
Set objFolder = GetFolder(strMinFolderPath)
Set objMinItems = objFolder.Items
Set objMinItem = objMinItems.Find("[Message Class] <>
""IPM.Post.Meeting_Header""")
Do While Not objMinItem Is Nothing
Call GetRecordData(objMinItem)
Set objMinItem = objMinItems.FindNext
Loop
Set objMinItem = Nothing
Set objMinItems = Nothing
Set objFolder = Nothing
End Sub
Sub GetRecordData(ByVal objMinIt As Object)
On Error Resume Next
Dim arrMinItem(13) As Variant
Dim objCDOItem As Object
Dim objFields As Object
Dim objFlag As Object
Dim objFlagText As Object
Dim objUserProps As Object
Dim objADORS As Object
Dim objADOConn As Object
Dim n As Integer
DoCDOLogon
Set objCDOItem = GetCDOItemFromOL(objMinIt)
DoCDOLogoff
Set objFields = objCDOItem.Fields
Set objUserProps = objMinIt.UserProperties
Set arrMinItem(0) = Nothing
Set objADOConn = New ADODB.Connection
objADOConn.Open "DSN=ProjectPacks"
Set objADORS = New ADODB.RecordSet
objADORS.Open "Select * From tbl_ExchangeMinutes", objADOConn,
adOpenStatic, adLockOptimistic
arrMinItem(1) = objUserProps("Meeting Description")
arrMinItem(2) = objUserProps("Job")
arrMinItem(3) = objUserProps("MeetingDate")
arrMinItem(4) = objMinIt.Body
arrMinItem(5) = objMinIt.ConversationIndex
arrMinItem(6) = objUserProps("AssignedTo")
arrMinItem(7) = objUserProps("DueDate")
Set objFlag = objFields.Item(&H10900003)
If Err.Number <> 0 Then
arrMinItem(8) = 1000
Err.Clear
Else
arrMinItem(8) = objFlag.Value
End If
Set objFlagText = objFields.Item("0x8530",
"0820060000000000C000000000000046")
If Err.Number <> 0 Then
arrMinItem(9) = ""
Err.Clear
Else
arrMinItem(9) = objFlagText.Value
End If
arrMinItem(10) = objUserProps("MeetingThread")
arrMinItem(11) = objMinIt.ConversationTopic
arrMinItem(12) = objMinIt.MessageClass
objADORS.AddNew
For n = 0 To 12
objADORS(n) = arrMinItem(n)
Set arrMinItem(n) = Nothing
Next n
objADORS.Update
objADORS.Close
objADOConn.Close
Set objADORS = Nothing
Set objADOConn = Nothing
Set objUserProps = Nothing
Set objFlag = Nothing
Set objFlagText = Nothing
Set objFields = Nothing
Set objCDOItem = Nothing
Set objADORS = Nothing
Set objMinIt = Nothing
End Sub
:
Try to store the UserProperties collection in a separate variable:
set UserProperties = objMinItem.UserProperties
arrMinItem(1) = UserProperties("Meeting Description")
....
set UserProperties = Nothing
Or, better yet, move the item processing logic inside of the while loop
into
a separate sub to make sure all local variables are properly dereferenced
when the sub exits
Do While Not objMinItem Is Nothing
ProcessItem(objMinItem)
Set objMinItem = objMinItems.FindNext
Loop
Dmitry Streblechenko (MVP)
http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool
Sadly, Sue, the situation is still the same.
Reworked code is as follows. I would be eternally grateful for some
more
help with this.
Sub TransferMinutesToAccess()
On Error Resume Next
Dim objADOConn As Object
Dim objADORS As Object
Dim objMinItem As Object
Dim objMinItems As Outlook.Items
Dim objFolder As Object
Dim arrMinItem(12) As Variant
Dim objFlag As Object
Dim objFlagText As Object
strMinFolderPath = "Public Folders\All Public
Folders\Projects\Project
Details\Minutes"
Set objADOConn = New ADODB.Connection
objADOConn.Open "DSN=ProjectPacks"
Set objADORS = New ADODB.RecordSet
With objADORS
.Open "Select * From tbl_ExchangeMinutes", objADOConn,
adOpenStatic,
adLockOptimistic
If Not .BOF Then
.MoveFirst
While Not .EOF
.Delete
.MoveNext
Wend
End If
End With
DoCDOLogon
Set objFolder = GetFolder(strMinFolderPath)
Set objMinItems = objFolder.Items
Set objMinItem = objMinItems.Find("[Message Class] <>
""IPM.Post.Meeting_Header""")
Do While Not objMinItem Is Nothing
Set objCDOItem = GetCDOItemFromOL(objMinItem)
Set objFields = objCDOItem.Fields
arrMinItem(1) = objMinItem.UserProperties("Meeting Description")
arrMinItem(2) = objMinItem.UserProperties("Job")
arrMinItem(3) = objMinItem.UserProperties("MeetingDate")
arrMinItem(4) = objMinItem.Body
arrMinItem(5) = objMinItem.ConversationIndex
arrMinItem(6) = objMinItem.UserProperties("AssignedTo")
arrMinItem(7) = objMinItem.UserProperties("DueDate")
Set objFlag = objFields.Item(&H10900003)
If Err.Number <> 0 Then
arrMinItem(8) = 1000
Err.Clear
Else
arrMinItem(8) = objFlag.Value
End If
Set objFlagText = objFields.Item("0x8530",
"0820060000000000C000000000000046")
If Err.Number <> 0 Then
arrMinItem(9) = ""
Err.Clear
Else
arrMinItem(9) = objFlagText.Value
End If
arrMinItem(10) = objMinItem.UserProperties("MeetingThread")
arrMinItem(11) = objMinItem.ConversationTopic
arrMinItem(12) = objMinItem.MessageClass
objADORS.AddNew
For n = 1 To 12
objADORS(n) = arrMinItem(n)
Set arrMinItem(n) = Nothing
Next n
objADORS.Update
Set objNewRec = Nothing
Set objFlag = Nothing
Set objFlagText = Nothing
Set objFields = Nothing
Set objCDOItem = Nothing
Set GetCDOItemFromOL(objMinItem) = Nothing
Set objMinItem = Nothing
Set objMinItem = objMinItems.FindNext
Loop
objADORS.Close
Set objADORS = Nothing
objADOConn.Close
Set objADOConn = Nothing
Set objFields = Nothing
DoCDOLogoff
End Sub
:
Many thanks Sue, I'll give these a try.
Vaughan
:
Try using Find instead of Restrict and in the example below, use
objMinItems.GetFirst and GetNext instead of a For Each loop, setting
objMinItem and objCDOItem to Nothing before reusing them. I'm not
sure
that will do the trick, but it's the logical thing to try.
--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers
Thanks for your patience Sue.
I am using Outlook VBA v 6.2. My code is as follows:
Sub TransferMinutesToAccess()
On Error Resume Next
Dim objADOConn As Object
Vaughan said:Here is an interesting contrast. The following code loops through all the
items in the folder and for every item after the 247th it displays a
message
box containing the content of the items' Body property. It produces an
error
on the 250th item:
Sub TestThisOut()
Dim objFolder As MAPIFolder
Dim objMinItems As Outlook.Items
Dim objMinItem As Object
Dim strMinBody As String
Dim n As Integer
Const strMinFolderPath As String = "Public Folders\All Public
Folders\Projects\Project Details\Minutes"
Set objFolder = GetFolder(strMinFolderPath)
Set objMinItems = objFolder.Items
Set objMinItem = objMinItems.GetFirst
n = 1
Do While Not objMinItem Is Nothing
strMinBody = objMinItem.Body
If n > 247 Then
MsgBox n & " " & strMinBody
End If
strMinBody = ""
Set objMinItem = Nothing
Set objMinItem = objMinItems.GetNext
n = n + 1
Loop
Set objMinItems = Nothing
Set objFolder = Nothing
End Sub
BUT, if I change the code to display the Subject property of each item,
the
error is not produced.
AND, if I change the code to drop the strMinBody variable and instead get
the message box to display objMinItem.Body, again no error is produced.
Can anyone explain that behaviour?
Thanks again
Vaughan
Vaughan said:Still exactly 249 items Dmitry.
Dmitry Streblechenko said:How many items can you process now?
Dmitry Streblechenko (MVP)
http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool
Thanks Dmitri. I tried what you said. I have progressively moved
everything
to do with processing the items into the separate sub until there is
virtually nothing left in the main sub. Still no joy.
My code looks like this now, and its really slow. Any insights would
be
most
gratefully received.
Thanks again for your interest and help
Vaughan
Sub TransferMinutesToAccess()
On Error Resume Next
Dim objADOConn As Object
Dim objADORS As Object
Dim objMinItem As Object
Dim objMinItems As Outlook.Items
Dim objFolder As Object
strMinFolderPath = "Public Folders\All Public
Folders\Projects\Project
Details\Minutes"
Set objADOConn = New ADODB.Connection
objADOConn.Open "DSN=ProjectPacks"
Set objADORS = New ADODB.RecordSet
With objADORS
.Open "Select * From tbl_ExchangeMinutes", objADOConn,
adOpenStatic,
adLockOptimistic
If Not .BOF Then
.MoveFirst
While Not .EOF
.Delete
.MoveNext
Wend
End If
End With
objADORS.Close
Set objADORS = Nothing
objADOConn.Close
Set objADOConn = Nothing
Set objFolder = GetFolder(strMinFolderPath)
Set objMinItems = objFolder.Items
Set objMinItem = objMinItems.Find("[Message Class] <>
""IPM.Post.Meeting_Header""")
Do While Not objMinItem Is Nothing
Call GetRecordData(objMinItem)
Set objMinItem = objMinItems.FindNext
Loop
Set objMinItem = Nothing
Set objMinItems = Nothing
Set objFolder = Nothing
End Sub
Sub GetRecordData(ByVal objMinIt As Object)
On Error Resume Next
Dim arrMinItem(13) As Variant
Dim objCDOItem As Object
Dim objFields As Object
Dim objFlag As Object
Dim objFlagText As Object
Dim objUserProps As Object
Dim objADORS As Object
Dim objADOConn As Object
Dim n As Integer
DoCDOLogon
Set objCDOItem = GetCDOItemFromOL(objMinIt)
DoCDOLogoff
Set objFields = objCDOItem.Fields
Set objUserProps = objMinIt.UserProperties
Set arrMinItem(0) = Nothing
Set objADOConn = New ADODB.Connection
objADOConn.Open "DSN=ProjectPacks"
Set objADORS = New ADODB.RecordSet
objADORS.Open "Select * From tbl_ExchangeMinutes", objADOConn,
adOpenStatic, adLockOptimistic
arrMinItem(1) = objUserProps("Meeting Description")
arrMinItem(2) = objUserProps("Job")
arrMinItem(3) = objUserProps("MeetingDate")
arrMinItem(4) = objMinIt.Body
arrMinItem(5) = objMinIt.ConversationIndex
arrMinItem(6) = objUserProps("AssignedTo")
arrMinItem(7) = objUserProps("DueDate")
Set objFlag = objFields.Item(&H10900003)
If Err.Number <> 0 Then
arrMinItem(8) = 1000
Err.Clear
Else
arrMinItem(8) = objFlag.Value
End If
Set objFlagText = objFields.Item("0x8530",
"0820060000000000C000000000000046")
If Err.Number <> 0 Then
arrMinItem(9) = ""
Err.Clear
Else
arrMinItem(9) = objFlagText.Value
End If
arrMinItem(10) = objUserProps("MeetingThread")
arrMinItem(11) = objMinIt.ConversationTopic
arrMinItem(12) = objMinIt.MessageClass
objADORS.AddNew
For n = 0 To 12
objADORS(n) = arrMinItem(n)
Set arrMinItem(n) = Nothing
Next n
objADORS.Update
objADORS.Close
objADOConn.Close
Set objADORS = Nothing
Set objADOConn = Nothing
Set objUserProps = Nothing
Set objFlag = Nothing
Set objFlagText = Nothing
Set objFields = Nothing
Set objCDOItem = Nothing
Set objADORS = Nothing
Set objMinIt = Nothing
End Sub
:
Try to store the UserProperties collection in a separate variable:
set UserProperties = objMinItem.UserProperties
arrMinItem(1) = UserProperties("Meeting Description")
....
set UserProperties = Nothing
Or, better yet, move the item processing logic inside of the while
loop
into
a separate sub to make sure all local variables are properly
dereferenced
when the sub exits
Do While Not objMinItem Is Nothing
ProcessItem(objMinItem)
Set objMinItem = objMinItems.FindNext
Loop
Dmitry Streblechenko (MVP)
http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool
Sadly, Sue, the situation is still the same.
Reworked code is as follows. I would be eternally grateful for
some
more
help with this.
Sub TransferMinutesToAccess()
On Error Resume Next
Dim objADOConn As Object
Dim objADORS As Object
Dim objMinItem As Object
Dim objMinItems As Outlook.Items
Dim objFolder As Object
Dim arrMinItem(12) As Variant
Dim objFlag As Object
Dim objFlagText As Object
strMinFolderPath = "Public Folders\All Public
Folders\Projects\Project
Details\Minutes"
Set objADOConn = New ADODB.Connection
objADOConn.Open "DSN=ProjectPacks"
Set objADORS = New ADODB.RecordSet
With objADORS
.Open "Select * From tbl_ExchangeMinutes", objADOConn,
adOpenStatic,
adLockOptimistic
If Not .BOF Then
.MoveFirst
While Not .EOF
.Delete
.MoveNext
Wend
End If
End With
DoCDOLogon
Set objFolder = GetFolder(strMinFolderPath)
Set objMinItems = objFolder.Items
Set objMinItem = objMinItems.Find("[Message Class] <>
""IPM.Post.Meeting_Header""")
Do While Not objMinItem Is Nothing
Set objCDOItem = GetCDOItemFromOL(objMinItem)
Set objFields = objCDOItem.Fields
arrMinItem(1) = objMinItem.UserProperties("Meeting
Description")
arrMinItem(2) = objMinItem.UserProperties("Job")
arrMinItem(3) = objMinItem.UserProperties("MeetingDate")
arrMinItem(4) = objMinItem.Body
arrMinItem(5) = objMinItem.ConversationIndex
arrMinItem(6) = objMinItem.UserProperties("AssignedTo")
arrMinItem(7) = objMinItem.UserProperties("DueDate")
Set objFlag = objFields.Item(&H10900003)
If Err.Number <> 0 Then
arrMinItem(8) = 1000
Err.Clear
Else
arrMinItem(8) = objFlag.Value
End If
Set objFlagText = objFields.Item("0x8530",
"0820060000000000C000000000000046")
If Err.Number <> 0 Then
arrMinItem(9) = ""
Err.Clear
Else
arrMinItem(9) = objFlagText.Value
End If
arrMinItem(10) = objMinItem.UserProperties("MeetingThread")
arrMinItem(11) = objMinItem.ConversationTopic
arrMinItem(12) = objMinItem.MessageClass
objADORS.AddNew
For n = 1 To 12
objADORS(n) = arrMinItem(n)
Set arrMinItem(n) = Nothing
Next n
objADORS.Update
Set objNewRec = Nothing
Set objFlag = Nothing
Set objFlagText = Nothing
Set objFields = Nothing
Set objCDOItem = Nothing
Set GetCDOItemFromOL(objMinItem) = Nothing
Set objMinItem = Nothing
Set objMinItem = objMinItems.FindNext
Loop
objADORS.Close
Set objADORS = Nothing
objADOConn.Close
Set objADOConn = Nothing
Set objFields = Nothing
DoCDOLogoff
End Sub
:
Many thanks Sue, I'll give these a try.
Vaughan
:
Try using Find instead of Restrict and in the example below,
use
objMinItems.GetFirst and GetNext instead of a For Each loop,
setting
objMinItem and objCDOItem to Nothing before reusing them. I'm
not
sure
that will do the trick, but it's the logical thing to try.
--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers
Thanks for your patience Sue.
I am using Outlook VBA v 6.2. My code is as follows:
Sub TransferMinutesToAccess()
On Error Resume Next
Dim objADOConn As Object
Dmitry Streblechenko said:When you access the subject property, Outlook does not open the
corresponding IMessage Extended MAPI object, instead it uses the value
returned by IMAPITable::QueryRows, where IMAPITable is the folder contents
table. If you access large property or property not in the row set (that's
what Items.SetColumns is for), Outlook opens the message as IMessage using
the value of PR_ENTRYID and requests the property from the message itself
using IMessage::GetProps. Just a performance optimization...
Once the message is opened, it opens an RPC channel that counts towards the
255 RPC channels limit.
I can only guess what happens when you access the Body property through an
intermediate variable: most likely the script host still holds an implicit
variable which will be released when the sub exits, but that's not what you
want. Oh wonders of using languages (like VBScript) that try so hard to make
life "easy" for the develpers...
Can you try to use a for loop instead of while?
Can you try to collect the values of EntryID in an array/collection in the
loop, then add another loop that uses the cached values of entry ids to call
Namespace.GetItemfromID?
Dmitry Streblechenko (MVP)
http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool
Vaughan said:Here is an interesting contrast. The following code loops through all the
items in the folder and for every item after the 247th it displays a
message
box containing the content of the items' Body property. It produces an
error
on the 250th item:
Sub TestThisOut()
Dim objFolder As MAPIFolder
Dim objMinItems As Outlook.Items
Dim objMinItem As Object
Dim strMinBody As String
Dim n As Integer
Const strMinFolderPath As String = "Public Folders\All Public
Folders\Projects\Project Details\Minutes"
Set objFolder = GetFolder(strMinFolderPath)
Set objMinItems = objFolder.Items
Set objMinItem = objMinItems.GetFirst
n = 1
Do While Not objMinItem Is Nothing
strMinBody = objMinItem.Body
If n > 247 Then
MsgBox n & " " & strMinBody
End If
strMinBody = ""
Set objMinItem = Nothing
Set objMinItem = objMinItems.GetNext
n = n + 1
Loop
Set objMinItems = Nothing
Set objFolder = Nothing
End Sub
BUT, if I change the code to display the Subject property of each item,
the
error is not produced.
AND, if I change the code to drop the strMinBody variable and instead get
the message box to display objMinItem.Body, again no error is produced.
Can anyone explain that behaviour?
Thanks again
Vaughan
Vaughan said:Still exactly 249 items Dmitry.
:
How many items can you process now?
Dmitry Streblechenko (MVP)
http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool
Thanks Dmitri. I tried what you said. I have progressively moved
everything
to do with processing the items into the separate sub until there is
virtually nothing left in the main sub. Still no joy.
My code looks like this now, and its really slow. Any insights would
be
most
gratefully received.
Thanks again for your interest and help
Vaughan
Sub TransferMinutesToAccess()
On Error Resume Next
Dim objADOConn As Object
Dim objADORS As Object
Dim objMinItem As Object
Dim objMinItems As Outlook.Items
Dim objFolder As Object
strMinFolderPath = "Public Folders\All Public
Folders\Projects\Project
Details\Minutes"
Set objADOConn = New ADODB.Connection
objADOConn.Open "DSN=ProjectPacks"
Set objADORS = New ADODB.RecordSet
With objADORS
.Open "Select * From tbl_ExchangeMinutes", objADOConn,
adOpenStatic,
adLockOptimistic
If Not .BOF Then
.MoveFirst
While Not .EOF
.Delete
.MoveNext
Wend
End If
End With
objADORS.Close
Set objADORS = Nothing
objADOConn.Close
Set objADOConn = Nothing
Set objFolder = GetFolder(strMinFolderPath)
Set objMinItems = objFolder.Items
Set objMinItem = objMinItems.Find("[Message Class] <>
""IPM.Post.Meeting_Header""")
Do While Not objMinItem Is Nothing
Call GetRecordData(objMinItem)
Set objMinItem = objMinItems.FindNext
Loop
Set objMinItem = Nothing
Set objMinItems = Nothing
Set objFolder = Nothing
End Sub
Sub GetRecordData(ByVal objMinIt As Object)
On Error Resume Next
Dim arrMinItem(13) As Variant
Dim objCDOItem As Object
Dim objFields As Object
Dim objFlag As Object
Dim objFlagText As Object
Dim objUserProps As Object
Dim objADORS As Object
Dim objADOConn As Object
Dim n As Integer
DoCDOLogon
Set objCDOItem = GetCDOItemFromOL(objMinIt)
DoCDOLogoff
Set objFields = objCDOItem.Fields
Set objUserProps = objMinIt.UserProperties
Set arrMinItem(0) = Nothing
Set objADOConn = New ADODB.Connection
objADOConn.Open "DSN=ProjectPacks"
Set objADORS = New ADODB.RecordSet
objADORS.Open "Select * From tbl_ExchangeMinutes", objADOConn,
adOpenStatic, adLockOptimistic
arrMinItem(1) = objUserProps("Meeting Description")
arrMinItem(2) = objUserProps("Job")
arrMinItem(3) = objUserProps("MeetingDate")
arrMinItem(4) = objMinIt.Body
arrMinItem(5) = objMinIt.ConversationIndex
arrMinItem(6) = objUserProps("AssignedTo")
arrMinItem(7) = objUserProps("DueDate")
Set objFlag = objFields.Item(&H10900003)
If Err.Number <> 0 Then
arrMinItem(8) = 1000
Err.Clear
Else
arrMinItem(8) = objFlag.Value
End If
Set objFlagText = objFields.Item("0x8530",
"0820060000000000C000000000000046")
If Err.Number <> 0 Then
arrMinItem(9) = ""
Err.Clear
Else
arrMinItem(9) = objFlagText.Value
End If
arrMinItem(10) = objUserProps("MeetingThread")
arrMinItem(11) = objMinIt.ConversationTopic
arrMinItem(12) = objMinIt.MessageClass
objADORS.AddNew
For n = 0 To 12
objADORS(n) = arrMinItem(n)
Set arrMinItem(n) = Nothing
Next n
objADORS.Update
objADORS.Close
objADOConn.Close
Set objADORS = Nothing
Set objADOConn = Nothing
Set objUserProps = Nothing
Set objFlag = Nothing
Set objFlagText = Nothing
Set objFields = Nothing
Set objCDOItem = Nothing
Set objADORS = Nothing
Set objMinIt = Nothing
End Sub
:
Try to store the UserProperties collection in a separate variable:
set UserProperties = objMinItem.UserProperties
arrMinItem(1) = UserProperties("Meeting Description")
....
set UserProperties = Nothing
Or, better yet, move the item processing logic inside of the while
loop
into
a separate sub to make sure all local variables are properly
dereferenced
when the sub exits
Do While Not objMinItem Is Nothing
ProcessItem(objMinItem)
Set objMinItem = objMinItems.FindNext
Loop
Dmitry Streblechenko (MVP)
http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool
Sadly, Sue, the situation is still the same.
Reworked code is as follows. I would be eternally grateful for
some
more
help with this.
Sub TransferMinutesToAccess()
On Error Resume Next
Dim objADOConn As Object
Dim objADORS As Object
Dim objMinItem As Object
Dim objMinItems As Outlook.Items
Dim objFolder As Object
Dim arrMinItem(12) As Variant
Dim objFlag As Object
Dim objFlagText As Object
strMinFolderPath = "Public Folders\All Public
Folders\Projects\Project
Details\Minutes"
Set objADOConn = New ADODB.Connection
objADOConn.Open "DSN=ProjectPacks"
Set objADORS = New ADODB.RecordSet
With objADORS
.Open "Select * From tbl_ExchangeMinutes", objADOConn,
adOpenStatic,
adLockOptimistic
If Not .BOF Then
.MoveFirst
While Not .EOF
.Delete
.MoveNext
Wend
End If
End With
DoCDOLogon
Set objFolder = GetFolder(strMinFolderPath)
Set objMinItems = objFolder.Items
Set objMinItem = objMinItems.Find("[Message Class] <>
""IPM.Post.Meeting_Header""")
Do While Not objMinItem Is Nothing
Want to reply to this thread or ask your own question?
You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.