Access date formatting

R

RB Smissaert

Is it possible in Access to format dates in a table when the data is defined
as dbDate?
I will have to do this in VBA, but I can't even see a way to do this in
DataSheet view or
design view. I am trying to get data from Excel in an Access table and
preserve the date
format. The Excel sheet data will be in the Excel integer (long) date
format, but formatted
as for example ddd dd/mmm/yyyy.
I know I could format the Access field as dbText, but then the data won't be
treated as dates anymore.
Thanks for any advice.

RBS
 
A

Allen Browne

Access also uses numbers for dates, and the dates should be compatible
unless you go back before 1901.

Dates in Access are actually a special type of number where the integer part
represents the date, and the fraction part the time of day. By default, the
dates are presented in the interface in accordance with your settings in the
Windows Control Panel (Regional Settings). You can specify a different
format in the Format property of the field of the table (lower pane in table
design view), or in the Format property of the text box (on a form or
report.)

Within a SQL clause, JET expects the date in the American format. Details
in:
International Date Formats in Access
at:
http://allenbrowne.com/ser-36.html

If you need to assign the Format property of the Field in the TableDef
programmatically, you need to use DAO code to CreateProperty() if it does
not already exist.
 
R

RB Smissaert

OK, thanks. I had a look at the .CreateProperty method, but couldn't get to
work.
This is the code I got, leaving out non-essential bits:

Sub Array2Access()

Dim Db1 As DAO.Database
Dim tdfNew As TableDef
Dim Rs1 As DAO.Recordset
Dim idxPatient As Index
Dim strField As String
Dim n As Long
Dim i As Long
Dim c As Long
Dim strAccessFile As String
Dim newFieldArray
Dim strDateFormat2 As String

strAccessFile = strLocalDrive & ":\RBSSynergyReporting\AddinTable.mdb"

'First, create the database.
Set Db1 = DBEngine.CreateDatabase(strAccessFile, dbLangGeneral)

'Create a new TableDef object.
Set tdfNew = Db1.CreateTableDef(strSheetName)

With tdfNew
' Create fields and append them to the new TableDef
' object. This must be done before appending the
' TableDef object to the TableDefs collection database.

.Fields.Append .CreateField("PATIENT_ID", dbLong)
.Fields("PATIENT_ID").Required = True

Set idxPatient = .CreateIndex("PatientIndex")
With idxPatient
.Fields.Append .CreateField("PATIENT_ID", dbLong)
.Primary = True
.Unique = True
End With
.Indexes.Append idxPatient

'remaining ID fields
For c = 2 To SeparatorArray(1, 1) - 1
If c > 255 Then
MsgBox "AN ACCESS TABLE CAN'T HAVE MORE THAN 255
FIELDS" & _
vbCrLf & vbCrLf & _
"CAN'T MAKE THIS TABLE", , _
"making Access table"
Db1.Close
Exit Sub
End If
strField = newFieldArray(c)
If InStr(1, strField, "age", vbTextCompare) > 0 Then
.Fields.Append .CreateField(strField, dbLong)
Else
If InStr(1, strField, "dob", vbTextCompare) > 0 Then
.Fields.Append .CreateField(strField, dbDate)
Else
.Fields.Append .CreateField(strField, dbText)
End If
End If
.Fields(strField).AllowZeroLength = True
Next

'non-ID fields or secondary ID fields
For c = SeparatorArray(1, 1) To FieldCount
If c > 255 Then
MsgBox "AN ACCESS TABLE CAN'T HAVE MORE THAN 255
FIELDS" & _
vbCrLf & vbCrLf & _
"CAN'T MAKE THIS TABLE", , _
"making Access table"
Db1.Close
Exit Sub
End If
strField = newFieldArray(c) & c
If InStr(1, strField, "systolic", vbTextCompare) > 0 Or _
InStr(1, strField, "diastolic", vbTextCompare) > 0 Then
.Fields.Append .CreateField(strField, dbLong)
Else
If InStr(1, strField, "date", vbTextCompare) > 0 Then
.Fields.Append .CreateField(strField, dbDate)
Else
If InStr(1, strField, "value", vbTextCompare) > 0 Then
.Fields.Append .CreateField(strField, dbDouble)
Else
.Fields.Append .CreateField(strField, dbText)
End If
End If
End If
.Fields(strField).AllowZeroLength = True
Next

'Append the new TableDef object database.
Db1.TableDefs.Append tdfNew
End With


So how do I get say the date format ddd dd/mmm/yyyy and still keep the
datatype for the field as a date?
A long or integer would be fine as well for the field datatype, but I think
text would be no good.
Thanks for the assistance.


RBS
 
A

Allen Browne

Here's the code we use to set these things.
It looks to see if the property exists.
If so, it sets it. If not it creates and sets it.

To use it on a fld (a Field variable):
Call SetPropertyDAO(fld, "Format", dbText, "ddd dd/mmm/yyyy")

To use it from the Immediate Window:
? SetPropertyDAO(dbEngine(0)(0).TableDefs("MyTable").Fields("MyDate"),
"Format", dbText, "ddd dd/mmm/yyyy")

Returns True if the property was set successfully.

-------------code starts-------------------------
Function SetPropertyDAO(obj As Object, strPropertyName As String, _
intType As Integer, varValue As Variant, Optional strErrMsg As String) As
Boolean
On Error GoTo ErrHandler
'Purpose: Set a property for an object, creating if necessary.
'Arguments: obj = the object whose property should be set.
' strPropertyName = the name of the property to set.
' intType = the type of property (needed for creating)
' varValue = the value to set this property to.
' strErrMsg = string to append any error message to.

If HasProperty(obj, strPropertyName) Then
obj.Properties(strPropertyName) = varValue
Else
obj.Properties.Append obj.CreateProperty(strPropertyName, intType,
varValue)
End If
SetPropertyDAO = True

ExitHandler:
Exit Function

ErrHandler:
strErrMsg = strErrMsg & obj.Name & "." & strPropertyName & " not set to
" & _
varValue & ". Error " & Err.Number & " - " & Err.Description &
vbCrLf
Resume ExitHandler
End Function

Public Function HasProperty(obj As Object, strPropName As String) As Boolean
'Purpose: Return true if the object has the property.
Dim varDummy As Variant

On Error Resume Next
varDummy = obj.Properties(strPropName)
HasProperty = (Err.Number = 0)
End Function
-------------code ends-------------------------
 
R

RB Smissaert

Thanks, that looks a useful function.
Call SetPropertyDAO(fld, "Format", dbText, "ddd dd/mmm/yyyy")
Click to expand...

As you have dbText here for the Type Property, will the data still be
handled as dates? For example will they still be sortable as dates?

RBS
 
D

Douglas J. Steele

The dbText in there refers to the data type of the Format property, not the
data type of the field itself.

Formatting a value doesn't change the value in any way, shape or form.
 
A

Allen Browne

Yes. You should still create the field as dbDate, as you correctly judged it
must be.

The Format property is dbText, i.e. the property holds string values such as
"ddd dd/mmm/yyyy".
 
R

RB Smissaert

OK, thanks for clearing that up.

RBS


Douglas J. Steele said:
The dbText in there refers to the data type of the Format property, not
the data type of the field itself.

Formatting a value doesn't change the value in any way, shape or form.
Click to expand...
 
R

RB Smissaert

Still can't work it out.
This is the full Sub that puts the Excel VBA array in an Access table:


Sub Array2Access()

Dim Db1 As DAO.Database
Dim tdfNew As TableDef
Dim Rs1 As DAO.Recordset
Dim idxPatient As Index
Dim strField As String
Dim n As Long
Dim i As Long
Dim c As Long
Dim strAccessFile As String
Dim newFieldArray
Dim strDateFormat2 As String
Dim strDate As String

strAccessFile = strLocalDrive & ":\RBSSynergyReporting\AddinTable.mdb"

'to get the real fieldcount and avoiding empty fields
'----------------------------------------------------
FieldCount = getLastRow1D(fieldArray)

'to leave the old fieldArray as it is
'------------------------------------
newFieldArray = fieldArray

'make sure we have valid names for the Access fields
'---------------------------------------------------
For i = 1 To FieldCount
newFieldArray(i) = MakeValidAccessFieldName(newFieldArray(i))
Next

'make sure the file is not there yet
If Len(Dir(strAccessFile)) > 0 Then
On Error GoTo ACCESS_OPEN
Kill strAccessFile
On Error GoTo 0
End If

'the Access date field won't for example accept ddd dd/mmm/yyyy
'--------------------------------------------------------------
If InStr(1, strDateFormat, " ", vbBinaryCompare) > 0 Or _
InStr(1, strDateFormat, ",", vbBinaryCompare) > 0 Or _
InStr(1, strDateFormat, ".", vbBinaryCompare) > 0 Or _
InStr(1, strDateFormat, "_", vbBinaryCompare) > 0 Or _
InStr(1, strDateFormat, "-", vbBinaryCompare) > 0 Or _
InStr(1, strDateFormat, "\", vbBinaryCompare) > 0 Or _
InStr(1, strDateFormat, "|", vbBinaryCompare) > 0 Or _
InStr(1, strDateFormat, "#", vbBinaryCompare) > 0 Then
'strDateFormat2 = "dd/mm/yyyy"
Else
'strDateFormat2 = strDateFormat
End If

'First, create the database.
Set Db1 = DBEngine.CreateDatabase(strAccessFile, dbLangGeneral)

'Create a new TableDef object.
Set tdfNew = Db1.CreateTableDef(strSheetName)

With tdfNew
' Create fields and append them to the new TableDef
' object. This must be done before appending the
' TableDef object to the TableDefs collection database.

.Fields.Append .CreateField("PATIENT_ID", dbLong)
.Fields("PATIENT_ID").Required = True

Set idxPatient = .CreateIndex("PatientIndex")
With idxPatient
.Fields.Append .CreateField("PATIENT_ID", dbLong)
.Primary = True
.Unique = True
End With
.Indexes.Append idxPatient

'remaining ID fields
For c = 2 To SeparatorArray(1, 1) - 1
If c > 255 Then
MsgBox "AN ACCESS TABLE CAN'T HAVE MORE THAN 255
FIELDS" & _
vbCrLf & vbCrLf & _
"CAN'T MAKE THIS TABLE", , _
"making Access table"
Db1.Close
Exit Sub
End If
strField = newFieldArray(c)
If InStr(1, strField, "age", vbTextCompare) > 0 Then
.Fields.Append .CreateField(strField, dbLong)
Else
If InStr(1, strField, "dob", vbTextCompare) > 0 Then
.Fields.Append .CreateField(strField, dbDate)
SetPropertyDAO .Fields(strField), "Format", dbText,
"dd/mmm/yyyy"
Else
.Fields.Append .CreateField(strField, dbText)
End If
End If
.Fields(strField).AllowZeroLength = True
Next

'non-ID fields or secondary ID fields
For c = SeparatorArray(1, 1) To FieldCount
If c > 255 Then
MsgBox "AN ACCESS TABLE CAN'T HAVE MORE THAN 255
FIELDS" & _
vbCrLf & vbCrLf & _
"CAN'T MAKE THIS TABLE", , _
"making Access table"
Db1.Close
Exit Sub
End If
strField = newFieldArray(c) & c
If InStr(1, strField, "systolic", vbTextCompare) > 0 Or _
InStr(1, strField, "diastolic", vbTextCompare) > 0 Then
.Fields.Append .CreateField(strField, dbLong)
Else
If InStr(1, strField, "date", vbTextCompare) > 0 Then
.Fields.Append .CreateField(strField, dbDate)
SetPropertyDAO .Fields(strField), "Format", dbText,
strDateFormat
Else
If InStr(1, strField, "value", vbTextCompare) > 0 Then
.Fields.Append .CreateField(strField, dbDouble)
Else
.Fields.Append .CreateField(strField, dbText)
End If
End If
End If
.Fields(strField).AllowZeroLength = True
Next

'Append the new TableDef object database.
Db1.TableDefs.Append tdfNew
End With

'Then, open the recordset.
Set Rs1 = Db1.OpenRecordset(strSheetName, dbOpenDynaset)

'Then write the data from the array to the recordset.
'Note that for each new record, you must first call Addnew
'then set the value property of the fields, and then call Update.
With Rs1
For i = 1 To URowCount
ShowProgressMessage strStatusIndent & _
"Making Access table, please wait ... "

.AddNew
.Fields("PATIENT_ID") = TableArray(i, 1)

'primary ID nodes
'----------------
For c = 2 To SeparatorArray(1, 1) - 1
strField = newFieldArray(c)
If InStr(1, fieldArray(c), "date", vbTextCompare) > 0 Or _
InStr(1, fieldArray(c), "dob", vbTextCompare) > 0 Then
On Error Resume Next 'to cover NULL values
'.Fields(strField) = Format(TableArray(i, c),
strDateFormat)
.Fields(strField) = TableArray(i, c)
On Error GoTo 0
Else
.Fields(strField) = TableArray(i, c)
End If
Next

'other nodes
'-----------
For c = SeparatorArray(1, 1) To FieldCount
strField = newFieldArray(c) & c
If InStr(1, fieldArray(c), "date", vbTextCompare) > 0 Then
On Error Resume Next 'to cover NULL values
'.Fields(strField) = Format(TableArray(i, c),
strDateFormat2)
.Fields(strField) = TableArray(i, c)
On Error GoTo 0
Else
.Fields(strField) = TableArray(i, c)
End If
Next

.Update

UpdateTimer 0, 0, 0, 0, False
MainForm.ProgressBar1.Value = ((i - 1) / URowCount) * 100
DoEvents
Next
End With

'Close the database.
Db1.Close

OpenAccessTable

Exit Sub
ACCESS_OPEN:

On Error GoTo 0
MsgBox "Can't delete the old file " & _
strAccessFile & " as it is open." & _
vbCrLf & vbCrLf & _
"Have to close it first.", _
vbExclamation, _
"making Access table"

End Sub


I keep getting dd/mm/yyyy
The reason is the function SetPropertyDAO gets an error Invalid operation at
the line:
obj.Properties.Append obj.CreateProperty(strPropertyName, intType, varValue)
The datevalues in TableArray(i, c) are Excel integer date numbers.

Must be overlooking something simple here and thanks for any advice.


RBS
 
R

RB Smissaert

OK, have worked this out now:


Sub Array2Access()

Dim Db1 As DAO.Database
Dim tdfNew As TableDef
Dim Rs1 As DAO.Recordset
Dim idxPatient As Index
Dim strField As String
Dim n As Long
Dim i As Long
Dim c As Long
Dim strAccessFile As String
Dim newFieldArray
Dim strDateFormat2 As String
Dim strDate As String
Dim arrDateFormat

strAccessFile = strLocalDrive & ":\RBSSynergyReporting\AddinTable.mdb"

'to get the real fieldcount and avoiding empty fields
'----------------------------------------------------
FieldCount = getLastRow1D(fieldArray)

'to keep track of the fields that need setting a date format
'-----------------------------------------------------------
ReDim arrDateFormat(1 To FieldCount) As String

'to leave the old fieldArray as it is
'------------------------------------
newFieldArray = fieldArray

'make sure we have valid names for the Access fields
'---------------------------------------------------
For i = 1 To FieldCount
newFieldArray(i) = MakeValidAccessFieldName(newFieldArray(i))
Next

'make sure the file is not there yet
If Len(Dir(strAccessFile)) > 0 Then
On Error GoTo ACCESS_OPEN
Kill strAccessFile
On Error GoTo 0
End If

'First, create the database.
Set Db1 = DBEngine.CreateDatabase(strAccessFile, dbLangGeneral)

'Create a new TableDef object.
Set tdfNew = Db1.CreateTableDef(strSheetName)

With tdfNew
' Create fields and append them to the new TableDef
' object. This must be done before appending the
' TableDef object to the TableDefs collection database.

.Fields.Append .CreateField("PATIENT_ID", dbLong)
.Fields("PATIENT_ID").Required = True

Set idxPatient = .CreateIndex("PatientIndex")
With idxPatient
.Fields.Append .CreateField("PATIENT_ID", dbLong)
.Primary = True
.Unique = True
End With
.Indexes.Append idxPatient

'remaining ID fields
For c = 2 To SeparatorArray(1, 1) - 1
If c > 255 Then
MsgBox "AN ACCESS TABLE CAN'T HAVE MORE THAN 255
FIELDS" & _
vbCrLf & vbCrLf & _
"CAN'T MAKE THIS TABLE", , _
"making Access table"
Db1.Close
Exit Sub
End If
strField = newFieldArray(c)
If InStr(1, strField, "age", vbTextCompare) > 0 Then
.Fields.Append .CreateField(strField, dbLong)
Else
If InStr(1, strField, "dob", vbTextCompare) > 0 Then
.Fields.Append .CreateField(strField, dbDate)
arrDateFormat(c) = newFieldArray(c)
Else
.Fields.Append .CreateField(strField, dbText)
End If
End If
.Fields(strField).AllowZeroLength = True
Next

'non-ID fields or secondary ID fields
For c = SeparatorArray(1, 1) To FieldCount
If c > 255 Then
MsgBox "AN ACCESS TABLE CAN'T HAVE MORE THAN 255
FIELDS" & _
vbCrLf & vbCrLf & _
"CAN'T MAKE THIS TABLE", , _
"making Access table"
Db1.Close
Exit Sub
End If
strField = newFieldArray(c) & c
If InStr(1, strField, "systolic", vbTextCompare) > 0 Or _
InStr(1, strField, "diastolic", vbTextCompare) > 0 Then
.Fields.Append .CreateField(strField, dbLong)
Else
If InStr(1, strField, "date", vbTextCompare) > 0 Then
.Fields.Append .CreateField(strField, dbDate)
arrDateFormat(c) = newFieldArray(c) & c
Else
If InStr(1, strField, "value", vbTextCompare) > 0 Then
.Fields.Append .CreateField(strField, dbDouble)
Else
.Fields.Append .CreateField(strField, dbText)
End If
End If
End If
.Fields(strField).AllowZeroLength = True
Next

'Append the new TableDef object database.
Db1.TableDefs.Append tdfNew
End With

'setting the custom date format
'------------------------------
For c = 2 To UBound(arrDateFormat)
If Len(arrDateFormat(c)) > 0 Then
SetPropertyDAO tdfNew.Fields(arrDateFormat(c)), _
"Format", _
dbText, _
strDateFormat
End If
Next

'Then, open the recordset.
Set Rs1 = Db1.OpenRecordset(strSheetName, dbOpenDynaset)

'Then write the data from the array to the recordset.
'Note that for each new record, you must first call Addnew
'then set the value property of the fields, and then call Update.
With Rs1
For i = 1 To URowCount
ShowProgressMessage strStatusIndent & _
"Making Access table, please wait ... "

.AddNew
.Fields("PATIENT_ID") = TableArray(i, 1)

'primary ID nodes
'----------------
For c = 2 To SeparatorArray(1, 1) - 1
strField = newFieldArray(c)
On Error Resume Next 'to cover NULL values
.Fields(strField) = TableArray(i, c)
On Error GoTo 0
Next

'other nodes
'-----------
For c = SeparatorArray(1, 1) To FieldCount
strField = newFieldArray(c) & c
On Error Resume Next 'to cover NULL values
.Fields(strField) = TableArray(i, c)
On Error GoTo 0
Next

.Update

UpdateTimer 0, 0, 0, 0, False
MainForm.ProgressBar1.Value = ((i - 1) / URowCount) * 100
DoEvents
Next
End With

'Close the database.
Db1.Close

OpenAccessTable

Exit Sub
ACCESS_OPEN:

On Error GoTo 0
MsgBox "Can't delete the old file " & _
strAccessFile & " as it is open." & _
vbCrLf & vbCrLf & _
"Have to close it first.", _
vbExclamation, _
"making Access table"

End Sub

I had to set the custom date format after appending the table to the DB.
Thanks again for the assistance.

Is there any way to Autofit the table columns in VBA?


RBS
 
Top