B
Bill Billmire
I have found that I need to use CDO to access the property tags for "custom"
items of post messages. I have read the documentation published at
"http://www.cdolive.com/cdo10.htm", but this doesn't cover accessing custom
property tags. I can determine the "name(s) and Hex Numbers" of the property
tags I need via "Outlookspy".
In my for... next... loop I need to obtain the data for the property tags...
0x8209
0x820A
0x820E
0x8210
0x8211
0x8213
0x8214
How do I accomplish this task?
Code Below...
Option Explicit
'---------------Exporting-----------------
Dim rst
Dim dbe
Dim wks
Dim dbs
Dim nms
Dim fld
Dim itm
Dim itms
Dim objMark1
Dim objProp
Dim objDate
Dim objPage
Dim ItemCount
Dim strKeyDate
Dim MyDate
Dim MyComp
Dim objItem
Dim objNS 'as NameSpace
Dim objFolder 'as MAPIFolder
Dim Namespace
Dim strAccessPath
Dim appAccess
Dim strFolder
Dim strDBEngine
Dim strDBName
Dim fFound
Sub cmdExport_Click()
Set objNS = Application.GetNamespace("MAPI")
Set objFolder = objNS.PickFolder
'Pick up path to Access database directory from Access SysCmd function
Set appAccess = Item.Application.CreateObject("Access.Application")
strAccessPath = appAccess.SysCmd(9)
'Get DAO version from DBEngine
strDBEngine = appAccess.Application.DBEngine.Version
'MsgBox "DBEngine version: " & strDBEngine
appAccess.Quit
If strDBEngine = "3.51" Then
'Office 97 DAO version
Set dbe = Item.Application.CreateObject("DAO.DBEngine.35")
strDBName = strAccessPath & "OSR.mdb"
ElseIf strDBEngine = "3.6" Then
'Office 2000 DAO version
Set dbe = Item.Application.CreateObject("DAO.DBEngine.36")
strDBName = strAccessPath & "OSR.mdb"
Else
MsgBox "Unknown Office version; canceling"
Exit Sub
End If
'MsgBox "DBName: " & strDBName
Set wks = dbe.Workspaces(0)
Set dbs = wks.OpenDatabase(strDBName)
'Open Access table containing contact data
Set rst = dbs.OpenRecordset("tblOSRData")
'Set up reference to Outlook folder of items to export
Set itms = objFolder.Items
ItemCount = itms.Count
If ItemCount = 0 Then
MsgBox "No OSR's to export"
Exit Sub
Else
MsgBox ItemCount & " OSR's to export"
End If
strKeyDate = "1/11/2005"
For Each itm in itms
objDate = Itm.SentOn
MyDate = Left(CStr(objDate),9)
' Msgbox Left(CStr(objDate),9)
MyComp = StrComp(strKeyDate, MyDate, 1)
If MyComp = -1 then
MsgBox "Exporting OLDER Items"
rst.AddNew
'Export the following items if "Assigned To"
rst.AssignedTo = itm.UserProperties("Assigned To")
rst.ClosedBy = itm.UserProperties("Closed By")
rst.DepartmentName = itm.UserProperties("DepartmentName")
rst.DepartmentNumber = itm.UserProperties("DepartmentNumber")
rst.FullName = itm.UserProperties("FullName")
rst.ITComments = itm.UserProperties("MISComments")
stop
Exit For
rst.OSRPriority = itm.UserProperties("Problem Priority")
rst.OSRStatus = itm.UserProperties("Problem Status")
rst.PhoneExtension = itm.UserProperties("Phone Extension")
rst.ProblemDescription = itm.UserProperties("ProblemDescription")
rst.ProductName = itm.UserProperties("Product Name")
rst.ProductVersion = itm.UserProperties("Product Version")
rst.Sent = CStr(itm.SentOn)
rst.TicketID = itm.UserProperties("TicketID")
rst.Update
Else
'MsgBox "Exporting NEWER Items"
'Stop
'Exit For
rst.AddNew
'Export the following items if "AssignedTo"
rst.AssignedTo = itm.UserProperties("AssignedTo")
rst.ClosedBy = itm.UserProperties("ClosedBy")
rst.DepartmentName = itm.UserProperties("DepartmentName")
rst.DepartmentNumber = itm.UserProperties("DepartmentNumber")
rst.FullName = itm.UserProperties("FullName")
rst.ITComments = itm.UserProperties("ITComments")
rst.OSRPriority = itm.UserProperties("OSRPriority")
rst.OSRStatus = itm.UserProperties("OSRStatus")
rst.PhoneExtension = itm.UserProperties("PhoneExtension")
rst.ProblemDescription = itm.UserProperties("ProblemDescription")
rst.ProductName = itm.UserProperties("ProductName")
rst.ProductVersion = itm.UserProperties("ProductVersion")
rst.Sent = CStr(itm.SentOn)
rst.TicketID = itm.UserProperties("TicketID")
rst.Update
End If
Next
rst.Close
MsgBox ItemCount & "All OSR's exported!"
End Sub
items of post messages. I have read the documentation published at
"http://www.cdolive.com/cdo10.htm", but this doesn't cover accessing custom
property tags. I can determine the "name(s) and Hex Numbers" of the property
tags I need via "Outlookspy".
In my for... next... loop I need to obtain the data for the property tags...
0x8209
0x820A
0x820E
0x8210
0x8211
0x8213
0x8214
How do I accomplish this task?
Code Below...
Option Explicit
'---------------Exporting-----------------
Dim rst
Dim dbe
Dim wks
Dim dbs
Dim nms
Dim fld
Dim itm
Dim itms
Dim objMark1
Dim objProp
Dim objDate
Dim objPage
Dim ItemCount
Dim strKeyDate
Dim MyDate
Dim MyComp
Dim objItem
Dim objNS 'as NameSpace
Dim objFolder 'as MAPIFolder
Dim Namespace
Dim strAccessPath
Dim appAccess
Dim strFolder
Dim strDBEngine
Dim strDBName
Dim fFound
Sub cmdExport_Click()
Set objNS = Application.GetNamespace("MAPI")
Set objFolder = objNS.PickFolder
'Pick up path to Access database directory from Access SysCmd function
Set appAccess = Item.Application.CreateObject("Access.Application")
strAccessPath = appAccess.SysCmd(9)
'Get DAO version from DBEngine
strDBEngine = appAccess.Application.DBEngine.Version
'MsgBox "DBEngine version: " & strDBEngine
appAccess.Quit
If strDBEngine = "3.51" Then
'Office 97 DAO version
Set dbe = Item.Application.CreateObject("DAO.DBEngine.35")
strDBName = strAccessPath & "OSR.mdb"
ElseIf strDBEngine = "3.6" Then
'Office 2000 DAO version
Set dbe = Item.Application.CreateObject("DAO.DBEngine.36")
strDBName = strAccessPath & "OSR.mdb"
Else
MsgBox "Unknown Office version; canceling"
Exit Sub
End If
'MsgBox "DBName: " & strDBName
Set wks = dbe.Workspaces(0)
Set dbs = wks.OpenDatabase(strDBName)
'Open Access table containing contact data
Set rst = dbs.OpenRecordset("tblOSRData")
'Set up reference to Outlook folder of items to export
Set itms = objFolder.Items
ItemCount = itms.Count
If ItemCount = 0 Then
MsgBox "No OSR's to export"
Exit Sub
Else
MsgBox ItemCount & " OSR's to export"
End If
strKeyDate = "1/11/2005"
For Each itm in itms
objDate = Itm.SentOn
MyDate = Left(CStr(objDate),9)
' Msgbox Left(CStr(objDate),9)
MyComp = StrComp(strKeyDate, MyDate, 1)
If MyComp = -1 then
MsgBox "Exporting OLDER Items"
rst.AddNew
'Export the following items if "Assigned To"
rst.AssignedTo = itm.UserProperties("Assigned To")
rst.ClosedBy = itm.UserProperties("Closed By")
rst.DepartmentName = itm.UserProperties("DepartmentName")
rst.DepartmentNumber = itm.UserProperties("DepartmentNumber")
rst.FullName = itm.UserProperties("FullName")
rst.ITComments = itm.UserProperties("MISComments")
stop
Exit For
rst.OSRPriority = itm.UserProperties("Problem Priority")
rst.OSRStatus = itm.UserProperties("Problem Status")
rst.PhoneExtension = itm.UserProperties("Phone Extension")
rst.ProblemDescription = itm.UserProperties("ProblemDescription")
rst.ProductName = itm.UserProperties("Product Name")
rst.ProductVersion = itm.UserProperties("Product Version")
rst.Sent = CStr(itm.SentOn)
rst.TicketID = itm.UserProperties("TicketID")
rst.Update
Else
'MsgBox "Exporting NEWER Items"
'Stop
'Exit For
rst.AddNew
'Export the following items if "AssignedTo"
rst.AssignedTo = itm.UserProperties("AssignedTo")
rst.ClosedBy = itm.UserProperties("ClosedBy")
rst.DepartmentName = itm.UserProperties("DepartmentName")
rst.DepartmentNumber = itm.UserProperties("DepartmentNumber")
rst.FullName = itm.UserProperties("FullName")
rst.ITComments = itm.UserProperties("ITComments")
rst.OSRPriority = itm.UserProperties("OSRPriority")
rst.OSRStatus = itm.UserProperties("OSRStatus")
rst.PhoneExtension = itm.UserProperties("PhoneExtension")
rst.ProblemDescription = itm.UserProperties("ProblemDescription")
rst.ProductName = itm.UserProperties("ProductName")
rst.ProductVersion = itm.UserProperties("ProductVersion")
rst.Sent = CStr(itm.SentOn)
rst.TicketID = itm.UserProperties("TicketID")
rst.Update
End If
Next
rst.Close
MsgBox ItemCount & "All OSR's exported!"
End Sub