B
bear
Thank you in advance for any help.
I have this code as an example that imports contact into access. Second code is an attempt to enter existing appointment from a calendar into access. Can not pass MsgBox "The active Inspector is not a contact item; exiting" error. Code A works fine for contacts.
Code A:
Option Explicit
Private ins As Outlook.Inspector
Private itm As Object
Private con As Outlook.ContactItem
Private appAccess As Access.Application
Private fso As Scripting.FileSystemObject
Private fld As Scripting.Folder
Private strAccessPath As String
Private dbe As DAO.DBEngine
Private strDBName As String
Private strDBNameAndPath As String
Private wks As DAO.Workspace
Private dbs As DAO.Database
Private rst As DAO.Recordset
Private ups As Outlook.UserProperties
Private fil As Scripting.File
Private prp As Outlook.UserProperty
Private msg As Outlook.MailItem
Public Sub SaveContactToAccess()
On Error GoTo ErrorHandler
Set ins = Application.ActiveInspector
Set itm = ins.CurrentItem
If itm.Class <> olContact Then
MsgBox "The active Inspector is not a contact item; exiting"
GoTo ErrorHandlerExit
Else
Set con = itm
'Pick up path to Access database directory from Access SysCmd function
Set appAccess = CreateObject("Access.Application")
strAccessPath = appAccess.SysCmd(acSysCmdAccessDir)
strAccessPath = strAccessPath & "Outlook Data\"
Debug.Print "Access database path: " & strAccessPath
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strAccessPath)
Set dbe = CreateObject("DAO.DBEngine.36")
strDBName = "Personal 2000.mdb"
strDBNameAndPath = strAccessPath & strDBName
Debug.Print "Database name: " & strDBNameAndPath
Set fil = fso.GetFile(strDBNameAndPath)
Set wks = dbe.Workspaces(0)
Set dbs = wks.OpenDatabase(strDBNameAndPath)
Set rst = dbs.OpenRecordset("tblContacts")
rst.AddNew
If con.Title <> "" Then
rst!Title = con.Title
End If
rst.Update
rst.Close
dbs.Close
Set wks = Nothing
Set dbe = Nothing
Set appAccess = Nothing
MsgBox con.FirstName & " " & con.LastName & "'s data exported to tblContacts"
End If
ErrorHandlerExit:
Exit Sub
ErrorHandler:
If Err.Number = 76 Then
Set fld = fso.CreateFolder(strAccessPath)
MsgBox strAccessPath & _
" folder created; please copy the appropriate Access database to it and try again"
GoTo ErrorHandlerExit
Else
MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
Resume ErrorHandlerExit
End If
End Sub
Code B:
Option Explicit
Private ins As Outlook.Inspector
Private itm As Object
Private con As Outlook.AppointmentItem
Private appAccess As Access.Application
Private fso As Scripting.FileSystemObject
Private fld As Scripting.Folder
Private strAccessPath As String
Private dbe As DAO.DBEngine
Private strDBName As String
Private strDBNameAndPath As String
Private wks As DAO.Workspace
Private dbs As DAO.Database
Private rst As DAO.Recordset
Private ups As Outlook.UserProperties
Private fil As Scripting.File
Private prp As Outlook.UserProperty
Private msg As Outlook.MailItem
Public Sub SaveContactToAccess()
On Error GoTo ErrorHandler
Set ins = Application.ActiveInspector
Set itm = ins.CurrentItem
If itm.Class <> olAppointmentItem Then
MsgBox "The active Inspector is not a contact item; exiting"
GoTo ErrorHandlerExit
Else
Set con = itm
Set appAccess = CreateObject("Access.Application")
strAccessPath = appAccess.SysCmd(acSysCmdAccessDir)
strAccessPath = strAccessPath & "Outlook Data\"
Debug.Print "Access database path: " & strAccessPath
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strAccessPath)
Set dbe = CreateObject("DAO.DBEngine.36")
strDBName = "Personal 2000.mdb"
strDBNameAndPath = strAccessPath & strDBName
Debug.Print "Database name: " & strDBNameAndPath
Set fil = fso.GetFile(strDBNameAndPath)
Set wks = dbe.Workspaces(0)
Set dbs = wks.OpenDatabase(strDBNameAndPath)
Set rst = dbs.OpenRecordset("Form")
rst.AddNew
Set ups = con.UserProperties
Set prp = ups.Find("TransportDate")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!TransportDate = prp.Value
End If
End If
rst.Update
rst.Close
dbs.Close
Set wks = Nothing
Set dbe = Nothing
Set appAccess = Nothing
MsgBox con.FirstName & " " & con.LastName & "'s data exported to tblContacts"
End If
ErrorHandlerExit:
Exit Sub
ErrorHandler:
If Err.Number = 76 Then
Set fld = fso.CreateFolder(strAccessPath)
MsgBox strAccessPath & _
" folder created; please copy the appropriate Access database to it and try again"
GoTo ErrorHandlerExit
Else
MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
Resume ErrorHandlerExit
End If
End Sub
Submitted using http://www.outlookforums.com
I have this code as an example that imports contact into access. Second code is an attempt to enter existing appointment from a calendar into access. Can not pass MsgBox "The active Inspector is not a contact item; exiting" error. Code A works fine for contacts.
Code A:
Option Explicit
Private ins As Outlook.Inspector
Private itm As Object
Private con As Outlook.ContactItem
Private appAccess As Access.Application
Private fso As Scripting.FileSystemObject
Private fld As Scripting.Folder
Private strAccessPath As String
Private dbe As DAO.DBEngine
Private strDBName As String
Private strDBNameAndPath As String
Private wks As DAO.Workspace
Private dbs As DAO.Database
Private rst As DAO.Recordset
Private ups As Outlook.UserProperties
Private fil As Scripting.File
Private prp As Outlook.UserProperty
Private msg As Outlook.MailItem
Public Sub SaveContactToAccess()
On Error GoTo ErrorHandler
Set ins = Application.ActiveInspector
Set itm = ins.CurrentItem
If itm.Class <> olContact Then
MsgBox "The active Inspector is not a contact item; exiting"
GoTo ErrorHandlerExit
Else
Set con = itm
'Pick up path to Access database directory from Access SysCmd function
Set appAccess = CreateObject("Access.Application")
strAccessPath = appAccess.SysCmd(acSysCmdAccessDir)
strAccessPath = strAccessPath & "Outlook Data\"
Debug.Print "Access database path: " & strAccessPath
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strAccessPath)
Set dbe = CreateObject("DAO.DBEngine.36")
strDBName = "Personal 2000.mdb"
strDBNameAndPath = strAccessPath & strDBName
Debug.Print "Database name: " & strDBNameAndPath
Set fil = fso.GetFile(strDBNameAndPath)
Set wks = dbe.Workspaces(0)
Set dbs = wks.OpenDatabase(strDBNameAndPath)
Set rst = dbs.OpenRecordset("tblContacts")
rst.AddNew
If con.Title <> "" Then
rst!Title = con.Title
End If
rst.Update
rst.Close
dbs.Close
Set wks = Nothing
Set dbe = Nothing
Set appAccess = Nothing
MsgBox con.FirstName & " " & con.LastName & "'s data exported to tblContacts"
End If
ErrorHandlerExit:
Exit Sub
ErrorHandler:
If Err.Number = 76 Then
Set fld = fso.CreateFolder(strAccessPath)
MsgBox strAccessPath & _
" folder created; please copy the appropriate Access database to it and try again"
GoTo ErrorHandlerExit
Else
MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
Resume ErrorHandlerExit
End If
End Sub
Code B:
Option Explicit
Private ins As Outlook.Inspector
Private itm As Object
Private con As Outlook.AppointmentItem
Private appAccess As Access.Application
Private fso As Scripting.FileSystemObject
Private fld As Scripting.Folder
Private strAccessPath As String
Private dbe As DAO.DBEngine
Private strDBName As String
Private strDBNameAndPath As String
Private wks As DAO.Workspace
Private dbs As DAO.Database
Private rst As DAO.Recordset
Private ups As Outlook.UserProperties
Private fil As Scripting.File
Private prp As Outlook.UserProperty
Private msg As Outlook.MailItem
Public Sub SaveContactToAccess()
On Error GoTo ErrorHandler
Set ins = Application.ActiveInspector
Set itm = ins.CurrentItem
If itm.Class <> olAppointmentItem Then
MsgBox "The active Inspector is not a contact item; exiting"
GoTo ErrorHandlerExit
Else
Set con = itm
Set appAccess = CreateObject("Access.Application")
strAccessPath = appAccess.SysCmd(acSysCmdAccessDir)
strAccessPath = strAccessPath & "Outlook Data\"
Debug.Print "Access database path: " & strAccessPath
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strAccessPath)
Set dbe = CreateObject("DAO.DBEngine.36")
strDBName = "Personal 2000.mdb"
strDBNameAndPath = strAccessPath & strDBName
Debug.Print "Database name: " & strDBNameAndPath
Set fil = fso.GetFile(strDBNameAndPath)
Set wks = dbe.Workspaces(0)
Set dbs = wks.OpenDatabase(strDBNameAndPath)
Set rst = dbs.OpenRecordset("Form")
rst.AddNew
Set ups = con.UserProperties
Set prp = ups.Find("TransportDate")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!TransportDate = prp.Value
End If
End If
rst.Update
rst.Close
dbs.Close
Set wks = Nothing
Set dbe = Nothing
Set appAccess = Nothing
MsgBox con.FirstName & " " & con.LastName & "'s data exported to tblContacts"
End If
ErrorHandlerExit:
Exit Sub
ErrorHandler:
If Err.Number = 76 Then
Set fld = fso.CreateFolder(strAccessPath)
MsgBox strAccessPath & _
" folder created; please copy the appropriate Access database to it and try again"
GoTo ErrorHandlerExit
Else
MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
Resume ErrorHandlerExit
End If
End Sub
Submitted using http://www.outlookforums.com