Import to Access errors out

B

bear

Hello,

I have this code that imports a custom form into Access.

Can not figure out why it errors out on Set prp = TotalM line.

Thanks for any help

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 <> olAppointment 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 = "s:\form.mdb"
strDBNameAndPath = 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("TransportDate2")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!TransportDate = prp.Value
End If
End If


Set prp = ups.Find("Start1")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!Appointmentstarttime = prp.Value
End If
End If



Dim TotalM As Variant

TotalM = Format((DateDiff("n", ups.Find("Start1"), ups.Find("End2")) / 60), "#,##0.00")

ERROR ---- Set prp = TotalM
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!LengthofAppt = prp.Value
End If
End If.
Submitted using http://www.outlookforums.com
 
S

Sue Mosher [MVP]

That statement tries to set a UserProperty object variable to a string.
Can't be done, which is why you get an error. Your other Set prp statements
show the correct approach.
 
B

bear

Thank you for response. How would I assign TotalM string to prp?



suemvp wrote on Mon, 21 December 2009 21:2
 
S

Sue Mosher [MVP]

The same way you would assign a value to any other object string property:

prp.Value = TotalM
 
B

bear

That work, thank you.
As I am trying to convert minutes into hours. It errors after prp.Value = TotalH, not sure why:


Dim TotalH As Variant
Dim TotalM As Variant



TotalM = DateDiff("n", ups.Find("Start1"), ups.Find("End2"))
TotalH = Format((TotalM / 60), "#,##0.00")
prp.Value = TotalH
Error-- If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!LengthofAppt = prp.Value
End If
End If



suemvp wrote on Tue, 22 December 2009 20:2
The same way you would assign a value to any other object string property:

prp.Value = TotalM
--
Sue Mosher, Outlook MVP
Author of Microsoft Outlook 2007 Programming:
Jumpstart for Power Users and Administrators
http://www.outlookcode.com/article.aspx?id=54


bear said:
Thank you for response. How would I assign TotalM string to prp?

suemvp wrote on Mon, 21 December 2009 21:24
That statement tries to set a UserProperty object variable to a string.
Can't be done, which is why you get an error. Your other Set prp
statements show the correct approach.

"bear" <swin_1234[at]yahoo[dot]com> wrote in message
Hello,

I have this code that imports a custom form into Access.

Can not figure out why it errors out on Set prp = TotalM line.

Thanks for any help

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 <> olAppointment 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 = "s:\form.mdb"
strDBNameAndPath = 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("TransportDate2")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!TransportDate = prp.Value
End If
End If
Set prp = ups.Find("Start1")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!Appointmentstarttime = prp.Value
End If
End If
Dim TotalM As Variant
TotalM = Format((DateDiff("n", ups.Find("Start1"),
ups.Find("End2")) / 60), "#,##0.00")

ERROR ---- Set prp = TotalM
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!LengthofAppt = prp.Value
End If
End If. Submitted using http://www.outlookforums.com
Click to expand...


Submitted using http://www.outlookforums.com
Click to expand...
Click to expand...
 
S

Sue Mosher [MVP]

What is the error? In any case, your logic seems to be backwards. It would
more sense to check whether a property exists *before* you try to set its
value. And the preferred way to check for the existence of an object looks
like this:

On Error Resume Next
If Not prp Is Nothing Then
prp.Value = TotalH
End If

Your code also seems confused about whether prp is a numeric or string
property.
 
B

bear

Thank you for your help, I am somewhat confused about numeric and string operations.

I can not figure out why in prp.Value = TotalH, if TotalH is 0.02, prp.Value is being #12/24/2009 9:49:00 AM#.

For rst!Appointmentstarttime = prp.Value, rst!Appointmentstarttime is 0 while prp.Value is being #12/24/2009 9:49:00 AM#.

I have:

Dim TotalH As Variant
Dim TotalM As Variant


TotalM = DateDiff("n", ups.Find("Start1"), ups.Find("End2"))
TotalH = Format((TotalM / 60), "#,##0.00")

On Error Resume Next
If Not prp Is Nothing Then
prp.Value(value shows #12/24/2009 9:49:00 AM#) =
TotalH(value shows 0.02)
End If
rst!LengthofAppt(value shows 0) =
prp.Value(value shows #12/24/2009 9:49:00 AM#)

Set prp = ups.Find("Start1")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!Appointmentstarttime(value shows 0) = prp.Value(valueshows #12/24/2009 9:49:00 AM#)
End If
End If


Thank you for your help







suemvp wrote on Wed, 23 December 2009 22:4
 
S

Sue Mosher [MVP]

It would be very helpful to know the data type for the property in
question -- string, numeric, integer, date, etc. Your latest comment
suggests it's a date/time field, in which case your TotalH value is
inappropriate, because it is not a date/time value.
--
Sue Mosher, Outlook MVP
Author of Microsoft Outlook 2007 Programming:
Jumpstart for Power Users and Administrators
http://www.outlookcode.com/article.aspx?id=54
 
B

bear

I must be not declaring prp correctly. The prp is not set and I am not sure how to set it to TotalH.
Here is what I have so far: It does not like line Set prp = TotalH.UserProperty. Skips to Error handler.



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 <> olAppointment 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 = "s:\form.mdb"
strDBNameAndPath = 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

Dim TotalH As Variant
Dim TotalM As Variant


TotalM = DateDiff("n", ups.Find("Start1"), ups.Find("End2"))
TotalH = Format((TotalM / 60), "#,##0.00")
Set prp = TotalH.UserProperty
On Error Resume Next
If Not prp Is Nothing Then
prp.Value = TotalH
End If
rst!LengthofAppt = prp.Value

Set prp = ups.Find("Start1")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!Appointmentstarttime = prp.Value
End If
End If

More Code .........



suemvp wrote on Mon, 28 December 2009 01:3
It would be very helpful to know the data type for the property in
question -- string, numeric, integer, date, etc. Your latest comment
suggests it's a date/time field, in which case your TotalH value is
inappropriate, because it is not a date/time value.
--
Sue Mosher, Outlook MVP
Author of Microsoft Outlook 2007 Programming:
Jumpstart for Power Users and Administrators
http://www.outlookcode.com/article.aspx?id=54


bear said:
Thank you for your help, I am somewhat confused about numeric and string
operations.

I can not figure out why in prp.Value = TotalH, if TotalH is 0.02,
prp.Value is being #12/24/2009 9:49:00 AM#.
For rst!Appointmentstarttime = prp.Value, rst!Appointmentstarttime is 0
while prp.Value is being #12/24/2009 9:49:00 AM#.
I have:

Dim TotalH As Variant
Dim TotalM As Variant
TotalM = DateDiff("n", ups.Find("Start1"), ups.Find("End2"))
TotalH = Format((TotalM / 60), "#,##0.00")
On Error Resume Next
If Not prp Is Nothing Then
prp.Value(value shows #12/24/2009 9:49:00 AM#) = TotalH(value shows
0.02)
End If
rst!LengthofAppt(value shows 0) = prp.Value(value shows #12/24/2009
9:49:00 AM#) Set prp = ups.Find("Start1")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!Appointmentstarttime(value shows 0) = prp.Value(valueshows
#12/24/2009 9:49:00 AM#)
End If
End If
Click to expand...
suemvp wrote on Wed, 23 December 2009 22:43
What is the error? In any case, your logic seems to be backwards. It
would more sense to check whether a property exists *before* you try to
set its value. And the preferred way to check for the existence of an
object looks like this:

On Error Resume Next
If Not prp Is Nothing Then
prp.Value = TotalH
End If

Your code also seems confused about whether prp is a numeric or string
property.
--
Sue Mosher, Outlook MVP
Author of Microsoft Outlook 2007 Programming:
Jumpstart for Power Users and Administrators
http://www.outlookcode.com/article.aspx?id=54


"bear" <swin_1234[at]yahoo[dot]com> wrote in message
That work, thank you.
As I am trying to convert minutes into hours. It errors after prp.Value
= TotalH, not sure why:


Dim TotalH As Variant
Dim TotalM As Variant
TotalM = DateDiff("n", ups.Find("Start1"), ups.Find("End2"))
TotalH = Format((TotalM / 60), "#,##0.00")
prp.Value = TotalH
Error-- If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!LengthofAppt = prp.Value
End If
End If
Click to expand...


Submitted using http://www.outlookforums.com
Click to expand...
Click to expand...
 
K

Ken Slovak - [MVP - Outlook]

Set prp = TotalH.UserProperty

TotalH is a variant that's containing a date value. It has no UserProperty
property. If prp is supposed to be a user property of con then you need to
set it that way, if it's supposed to be part of ups then it needs to be set
that way. From the code I'm not sure what you're intending.

The Set prp = ups.Find("Start1") line is more in line with what I'd expect.
You can then set prp = TotalH.
 
B

bear

Hello Ken,

I am trying to assign the difference in hours and minutes between start date and end date to prp(Start1 and End2) and import that time value into access database in a form hh:mm. I think it should be part of con

Here is complete code:
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
Private TotalH As Variant
Private TotalM As Variant



Public Sub SaveContactToAccess()

On Error GoTo ErrorHandler

Set ins = Application.ActiveInspector
Set itm = ins.CurrentItem

If itm.Class <> olAppointment 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 = "s:\form.mdb"
strDBNameAndPath = 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

TotalM = DateDiff("n", ups.Find("Start1"), ups.Find("End2"))
TotalH = Format((TotalM / 60), "#,##0.00")

Set prp = TotalH
On Error Resume Next
If Not prp Is Nothing Then
prp.Value = TotalH
End If
rst!LengthofAppt = prp.Value

Set prp = ups.Find("Start1")
If TypeName(prp) <> "Nothing" Then
If prp <> 0 Then
rst!Appointmentstarttime = prp
End If
End If

Set prp = ups.Find("End2")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!EndTimeTop = prp.Value
End If
End If

Set prp = ups.Find("TransportDate2")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!TransportDate = prp.Value
End If
End If

Set prp = ups.Find("droplocation")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!LocationTop = prp.Value
End If
End If

Set prp = ups.Find("DestinationandAddr")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!DestinationandAddr = prp.Value
End If
End If

Set prp = ups.Find("drop9")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!StatusTop = prp.Value
End If
End If

Set prp = ups.Find("drop8")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!DepartmentTop = prp.Value
End If
End If

Set prp = ups.Find("drop3")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!ApptMadeBy = prp.Value
End If
End If

Set prp = ups.Find("TransportDate3")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!DateScheduled = prp.Value
End If
End If

Set prp = ups.Find("PatientName")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!PatientName = prp.Value
End If
End If

Set prp = ups.Find("HRNTop")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!HRNTop = prp.Value
End If
End If


Set prp = ups.Find("Minor")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!Minor = prp.Value
End If
End If


Set prp = ups.Find("ParentGuardian")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!ParentGuardian = prp.Value
End If
End If

Set prp = ups.Find("NumberOfRiders")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!NumberOfRiders = prp.Value
End If
End If

Set prp = ups.Find("PatientPhone")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!PatientPhone = prp.Value
End If
End If

Set prp = ups.Find("AltPhone")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!AltPhone = prp.Value
End If
End If

Set prp = ups.Find("PatientAddress")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!PatientAddress = prp.Value
End If
End If

Set prp = ups.Find("drop5")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!GrindstoneAddress = prp.Value
End If
End If

Set prp = ups.Find("drop7")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!Insurance = prp.Value
End If
End If

Set prp = ups.Find("drop6")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!DriverName = prp.Value
End If
End If

Set prp = ups.Find("drop4")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!Vehicle = prp.Value
End If
End If

Set prp = ups.Find("Start2")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!DepartureTime = prp.Value
End If
End If

Set prp = ups.Find("End3")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!EndingTime = prp.Value
End If
End If

Set prp = ups.Find("TotalTm")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!TotalTime = prp.Value
End If
End If

Set prp = ups.Find("MileageStarting")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!MileageStarting = prp.Value
End If
End If


Set prp = ups.Find("MileageEnding")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!MileageEnding = prp.Value
End If
End If


Set prp = ups.Find("TotalMileage")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!TotalMileage = prp.Value
End If
End If

Set prp = ups.Find("CompletedStatus2")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!CompletedStatus = prp.Value
End If
End If

Set prp = ups.Find("DriverComments")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!DriverComments = 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


kenslovak wrote on Mon, 28 December 2009 14:37
 
K

Ken Slovak - [MVP - Outlook]

Whatever object the prp variable is a UserProperty of is up to you. I was
answering why you were getting an error in assigning the prp variable. You
assign a UserProperty variable in this way:

Set prp = myItem.UserProperties.Find("MyUserPropertyName")

You then set the value of that UserProperty:

prp.Value = hTime ' or whatever

The logic of the code is up to you.
 
B

bear

Thanks Ken.
Line Set prp = myItem.UserProperties.Find("MyUserPropertyName")would assume I want an item on my form. TotalH is not on a form and I can not get to it using Find, right? I guess I do not understand how to grab value of TotalH since it is not one of the fields on the form.
Thank you




kenslovak wrote on Mon, 28 December 2009 17:35
Whatever object the prp variable is a UserProperty of is up to you. I was
answering why you were getting an error in assigning the prp variable. You
assign a UserProperty variable in this way:

Set prp = myItem.UserProperties.Find("MyUserPropertyName")

You then set the value of that UserProperty:

prp.Value = hTime ' or whatever

The logic of the code is up to you.
Click to expand...


Submitted using http://www.outlookforums.com
 
K

Ken Slovak - [MVP - Outlook]

A UserProperty may be bound to a form control, but it's not required and a
UserProperty can exist on an item without a custom form being involved at
all. All I was showing you is how to get the UserProperty and how to set it
to your date/time value or a calculated value.

I thought your TotalH was a calculation of some sort, if you don't know what
it is and how to get it no one else would.
 
B

bear

In this example:
Set rst = dbs.OpenRecordset("Form")
rst.AddNew

Set ups = con.UserProperties

TotalM = DateDiff("n", ups.Find("Start1"), ups.Find("End2"))
TotalH = Format((TotalM / 60), "#,##0.00")

rst!LengthofAppt = TotalH


If TotalH is 1.02, why does rst!LengthofAppt becomes 1, instead of 1.02?

Thank you


kenslovak wrote on Tue, 29 December 2009 15:0
 
S

Sue Mosher [MVP]

Maybe because LengthofAppt is set up in the database as an Integer field? In
any case, Format() returns a string, so if LengthofAppt is a numeric field
of any kind, you should use a converter method like CDbl() or CSng() to
convert that string into a numeric value.
 
B

bear

Hello Sue,

My Access table takes in Numeric value in a fixed format 0.000.

I tied both methods, or combination of, you suggested, still no luck.
For rst!LengthofAppt = CDbl(TotalH), even if CDbl(TotalH) 5.01, rst!LengthofAppt is 5.

A

Set ups = con.UserProperties

TotalM = DateDiff("n", ups.Find("Start1"), ups.Find("End2"))
TotalH = CSng(Format((TotalM / 60), "#,##0.00"))


rst!LengthofAppt = CDbl(TotalH)

B

Set ups = con.UserProperties

TotalM = DateDiff("n", ups.Find("Start1"), ups.Find("End2"))
TotalH = CSng(Format((TotalM / 60), "#,##0.00"))


rst!LengthofAppt = CSng(TotalH)

Comple code:

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
Private TotalH As Variant
Private TotalM As Variant



Public Sub SaveContactToAccess()

On Error GoTo ErrorHandler

Set ins = Application.ActiveInspector
Set itm = ins.CurrentItem

If itm.Class <> olAppointment 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 = "s:\form.mdb"
strDBNameAndPath = 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

TotalM = DateDiff("n", ups.Find("Start1"), ups.Find("End2"))
TotalH = CSng(Format((TotalM / 60), "#,##0.00"))


rst!LengthofAppt = CDbl(TotalH)

Set prp = ups.Find("Start1")
If TypeName(prp) <> "Nothing" Then
If prp <> 0 Then
rst!Appointmentstarttime = prp
End If
End If

Set prp = ups.Find("End2")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!EndTimeTop = prp.Value
End If
End If

Set prp = ups.Find("TransportDate2")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!TransportDate = prp.Value
End If
End If

Set prp = ups.Find("droplocation")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!LocationTop = prp.Value
End If
End If

Set prp = ups.Find("DestinationandAddr")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!DestinationandAddr = prp.Value
End If
End If

Set prp = ups.Find("drop9")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!StatusTop = prp.Value
End If
End If

Set prp = ups.Find("drop8")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!DepartmentTop = prp.Value
End If
End If

Set prp = ups.Find("drop3")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!ApptMadeBy = prp.Value
End If
End If

Set prp = ups.Find("TransportDate3")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!DateScheduled = prp.Value
End If
End If

Set prp = ups.Find("PatientName")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!PatientName = prp.Value
End If
End If

Set prp = ups.Find("HRNTop")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!HRNTop = prp.Value
End If
End If


Set prp = ups.Find("Minor")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!Minor = prp.Value
End If
End If


Set prp = ups.Find("ParentGuardian")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!ParentGuardian = prp.Value
End If
End If

Set prp = ups.Find("NumberOfRiders")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!NumberOfRiders = prp.Value
End If
End If

Set prp = ups.Find("PatientPhone")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!PatientPhone = prp.Value
End If
End If

Set prp = ups.Find("AltPhone")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!AltPhone = prp.Value
End If
End If

Set prp = ups.Find("PatientAddress")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!PatientAddress = prp.Value
End If
End If

Set prp = ups.Find("drop5")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!GrindstoneAddress = prp.Value
End If
End If

Set prp = ups.Find("drop7")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!Insurance = prp.Value
End If
End If

Set prp = ups.Find("drop6")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!DriverName = prp.Value
End If
End If

Set prp = ups.Find("drop4")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!Vehicle = prp.Value
End If
End If

Set prp = ups.Find("Start2")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!DepartureTime = prp.Value
End If
End If

Set prp = ups.Find("End3")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!EndingTime = prp.Value
End If
End If

Set prp = ups.Find("TotalTm")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!TotalTime = prp.Value
End If
End If

Set prp = ups.Find("MileageStarting")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!MileageStarting = prp.Value
End If
End If


Set prp = ups.Find("MileageEnding")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!MileageEnding = prp.Value
End If
End If


Set prp = ups.Find("TotalMileage")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!TotalMileage = prp.Value
End If
End If

Set prp = ups.Find("CompletedStatus2")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!CompletedStatus = prp.Value
End If
End If

Set prp = ups.Find("DriverComments")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!DriverComments = 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



suemvp wrote on Fri, 01 January 2010 13:16
Maybe because LengthofAppt is set up in the database as an Integer field? In
any case, Format() returns a string, so if LengthofAppt is a numeric field
of any kind, you should use a converter method like CDbl() or CSng() to
convert that string into a numeric value.
--
Sue Mosher, Outlook MVP
Author of Microsoft Outlook 2007 Programming:
Jumpstart for Power Users and Administrators
http://www.outlookcode.com/article.aspx?id=54
Click to expand...


Submitted using http://www.outlookforums.com
 
S

Sue Mosher [MVP]

I don't understand why you're using Format() at all in this scenario. If you
want to round the hour value to two decimal points, just use Round().

In any case, if the database isn't accepting or reporting the correct value,
that sounds like an Access issue, not an Outlook issue. I can't help you
with that.
 
B

bear

Hello Sue,

I was trying to get certain format, but you right, I do not need it:


Set rst = dbs.OpenRecordset("Form")
rst.AddNew

Set ups = con.UserProperties

TotalM = DateDiff("n", ups.Find("Start1"), ups.Find("End2"))
TotalH = CSng(TotalM / 60)


rst!LengthofAppt = CDbl(TotalH)

If CDbl(TotalH) is 4.683333, rst!LengthofAppt is rounded up to 5.

Anywhere else in the code rst! value can be anything such 0.003 or 111#$23. I do not think it has to do with Access as fields in the table are all the same.

Anything else you might sudgest?

Thank you

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
Private TotalH As Variant
Private TotalM As Variant



Public Sub SaveContactToAccess()

On Error GoTo ErrorHandler

Set ins = Application.ActiveInspector
Set itm = ins.CurrentItem

If itm.Class <> olAppointment 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 = "s:\form.mdb"
strDBNameAndPath = 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

TotalM = DateDiff("n", ups.Find("Start1"), ups.Find("End2"))
TotalH = CSng(TotalM / 60)


rst!LengthofAppt = CDbl(TotalH)

Set prp = ups.Find("Start1")
If TypeName(prp) <> "Nothing" Then
If prp <> 0 Then
rst!Appointmentstarttime = prp
End If
End If

Set prp = ups.Find("End2")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!EndTimeTop = prp.Value
End If
End If

Set prp = ups.Find("TransportDate2")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!TransportDate = prp.Value
End If
End If

Set prp = ups.Find("droplocation")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!LocationTop = prp.Value
End If
End If

Set prp = ups.Find("DestinationandAddr")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!DestinationandAddr = prp.Value
End If
End If

Set prp = ups.Find("drop9")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!StatusTop = prp.Value
End If
End If

Set prp = ups.Find("drop8")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!DepartmentTop = prp.Value
End If
End If

Set prp = ups.Find("drop3")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!ApptMadeBy = prp.Value
End If
End If

Set prp = ups.Find("TransportDate3")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!DateScheduled = prp.Value
End If
End If

Set prp = ups.Find("PatientName")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!PatientName = prp.Value
End If
End If

Set prp = ups.Find("HRNTop")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!HRNTop = prp.Value
End If
End If


Set prp = ups.Find("Minor")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!Minor = prp.Value
End If
End If


Set prp = ups.Find("ParentGuardian")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!ParentGuardian = prp.Value
End If
End If

Set prp = ups.Find("NumberOfRiders")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!NumberOfRiders = prp.Value
End If
End If

Set prp = ups.Find("PatientPhone")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!PatientPhone = prp.Value
End If
End If

Set prp = ups.Find("AltPhone")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!AltPhone = prp.Value
End If
End If

Set prp = ups.Find("PatientAddress")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!PatientAddress = prp.Value
End If
End If

Set prp = ups.Find("drop5")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!GrindstoneAddress = prp.Value
End If
End If

Set prp = ups.Find("drop7")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!Insurance = prp.Value
End If
End If

Set prp = ups.Find("drop6")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!DriverName = prp.Value
End If
End If

Set prp = ups.Find("drop4")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!Vehicle = prp.Value
End If
End If

Set prp = ups.Find("Start2")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!DepartureTime = prp.Value
End If
End If

Set prp = ups.Find("End3")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!EndingTime = prp.Value
End If
End If

Set prp = ups.Find("TotalTm")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!TotalTime = prp.Value
End If
End If

Set prp = ups.Find("MileageStarting")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!MileageStarting = prp.Value
End If
End If


Set prp = ups.Find("MileageEnding")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!MileageEnding = prp.Value
End If
End If


Set prp = ups.Find("TotalMileage")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!TotalMileage = prp.Value
End If
End If

Set prp = ups.Find("CompletedStatus2")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!CompletedStatus = prp.Value
End If
End If

Set prp = ups.Find("DriverComments")
If TypeName(prp) <> "Nothing" Then
If prp.Value <> 0 Then
rst!DriverComments = 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




suemvp wrote on Mon, 04 January 2010 21:09
I don't understand why you're using Format() at all in this scenario. If you
want to round the hour value to two decimal points, just use Round().

In any case, if the database isn't accepting or reporting the correct value,
that sounds like an Access issue, not an Outlook issue. I can't help you
with that.
--
Sue Mosher, Outlook MVP
Author of Microsoft Outlook 2007 Programming:
Jumpstart for Power Users and Administrators
http://www.outlookcode.com/article.aspx?id=54


bear said:
Hello Sue,

My Access table takes in Numeric value in a fixed format 0.000.
I tied both methods, or combination of, you suggested, still no luck.
For rst!LengthofAppt = CDbl(TotalH), even if CDbl(TotalH) 5.01,
rst!LengthofAppt is 5.
A

Set ups = con.UserProperties
TotalM = DateDiff("n", ups.Find("Start1"), ups.Find("End2"))
TotalH = CSng(Format((TotalM / 60), "#,##0.00"))
rst!LengthofAppt = CDbl(TotalH)

B

Set ups = con.UserProperties
TotalM = DateDiff("n", ups.Find("Start1"), ups.Find("End2"))
TotalH = CSng(Format((TotalM / 60), "#,##0.00"))
rst!LengthofAppt = CSng(TotalH)


suemvp wrote on Fri, 01 January 2010 13:16
Maybe because LengthofAppt is set up in the database as an Integer field?
In any case, Format() returns a string, so if LengthofAppt is a numeric
field of any kind, you should use a converter method like CDbl() or
CSng() to convert that string into a numeric value.

"bear" <swin_1234[at]yahoo[dot]com> wrote in message
In this example:
Set rst = dbs.OpenRecordset("Form")
rst.AddNew
Set ups = con.UserProperties
TotalM = DateDiff("n", ups.Find("Start1"),
ups.Find("End2"))
TotalH = Format((TotalM / 60), "#,##0.00")
rst!LengthofAppt = TotalH


If TotalH is 1.02, why does rst!LengthofAppt becomes 1, instead of
1.02?
Click to expand...


Submitted using http://www.outlookforums.com
Click to expand...
Click to expand...


Submitted using http://www.outlookforums.com
 
S

Sue Mosher [MVP]

I disagree. If you set a database field to a certain value, but read out a
different value from the same field, then the cause would seem to lie in the
database. Nothing else has touched the data. It's certainly not an Outlook
issue. I have no idea what in Access could cause this other than having the
wrong data type for the field. If you pursuse this on an Access forum, which
I would recommend, be sure to reduce the code you share down to a specific
snippet that deals just with the raw vaues, not with Outlook properties.
Mentioning Outlook will only distract the Access experts from your real
issue.

Also, there is no need to use both CSng() and CDbl() on the value that
DateDiff returns. Use whichever is more appropriate to your expected data.
--
Sue Mosher, Outlook MVP
Author of Microsoft Outlook 2007 Programming:
Jumpstart for Power Users and Administrators
http://www.outlookcode.com/article.aspx?id=54


bear said:
Hello Sue,

I was trying to get certain format, but you right, I do not need it:


Set rst = dbs.OpenRecordset("Form")
rst.AddNew
Set ups = con.UserProperties
TotalM = DateDiff("n", ups.Find("Start1"), ups.Find("End2"))
TotalH = CSng(TotalM / 60)
rst!LengthofAppt = CDbl(TotalH)

If CDbl(TotalH) is 4.683333, rst!LengthofAppt is rounded up to 5.
Anywhere else in the code rst! value can be anything such 0.003 or
111#$23. I do not think it has to do with Access as fields in the table
are all the same.

suemvp wrote on Mon, 04 January 2010 21:09
I don't understand why you're using Format() at all in this scenario. If
you want to round the hour value to two decimal points, just use Round().

In any case, if the database isn't accepting or reporting the correct
value, that sounds like an Access issue, not an Outlook issue. I can't
help you with that.

bear said:
Hello Sue,

My Access table takes in Numeric value in a fixed format 0.000.
I tied both methods, or combination of, you suggested, still no luck.
For rst!LengthofAppt = CDbl(TotalH), even if CDbl(TotalH) 5.01,
rst!LengthofAppt is 5.
A

Set ups = con.UserProperties
TotalM = DateDiff("n", ups.Find("Start1"),
ups.Find("End2"))
TotalH = CSng(Format((TotalM / 60), "#,##0.00"))
rst!LengthofAppt = CDbl(TotalH)

B

Set ups = con.UserProperties
TotalM = DateDiff("n", ups.Find("Start1"),
ups.Find("End2"))
TotalH = CSng(Format((TotalM / 60), "#,##0.00"))
rst!LengthofAppt = CSng(TotalH)


suemvp wrote on Fri, 01 January 2010 13:16
Maybe because LengthofAppt is set up in the database as an Integer
field? In any case, Format() returns a string, so if LengthofAppt is a
numeric field of any kind, you should use a converter method like
CDbl() or CSng() to convert that string into a numeric value.

"bear" <swin_1234[at]yahoo[dot]com> wrote in message
In this example:
Set rst = dbs.OpenRecordset("Form")
rst.AddNew
Set ups = con.UserProperties
TotalM = DateDiff("n", ups.Find("Start1"),
ups.Find("End2"))
TotalH = Format((TotalM / 60), "#,##0.00")
rst!LengthofAppt = TotalH


If TotalH is 1.02, why does rst!LengthofAppt becomes 1, instead of
1.02?
Click to expand...
Click to expand...
Click to expand...
 

Ask a Question

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.

Ask a Question

Similar Threads

Form into access 2
Outlook 2007 form into access field format 9
Error: 3033 when trying to OpenDatabase using DAO 3
OLK2K3: CDO and access to item property tags. 3
I need a vba code to download attachments from Outlook which are sent daily 1
importing in access outlook custom forms 11
Determine recipients of the message being replied to 1
Problem with access acImportDelim importing csv with headers 1

Top