Breaking News

Sunday, June 24, 2012

Ex11: VBA - Set default properties using DAO

Properties you always want set by default using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7


Function StandardProperties(strTableName As String)
'Purpose: Properties you always want set by default:
' TableDef: Subdatasheets off.
' Numeric fields: Remove Default Value.
' Currency fields: Format as currency.
' Yes/No fields: Display as check box. Default to No.
' Text/memo/hyperlink: AllowZeroLength off,
' UnicodeCompression on.
' All fields: Add a caption if mixed case.
'Argument: Name of the table.
'Note: Requires: SetPropertyDAO()
Dim db As DAO.Database 'Current database.
Dim tdf As DAO.TableDef 'Table nominated in argument.
Dim fld As DAO.Field 'Each field.
Dim strCaption As String 'Field caption.
Dim strErrMsg As String 'Responses and error messages.

'Initalize.
Set db = CurrentDb()
Set tdf = db.TableDefs(strTableName)

'Set the table's SubdatasheetName.
Call SetPropertyDAO(tdf, "SubdatasheetName", dbText, "[None]", _
strErrMsg)

For Each fld In tdf.Fields
'Handle the defaults for the different field types.
Select Case fld.Type
Case dbText, dbMemo 'Includes hyperlinks.
fld.AllowZeroLength = False
Call SetPropertyDAO(fld, "UnicodeCompression", dbBoolean, _
True, strErrMsg)
Case dbCurrency
fld.DefaultValue = 0
Call SetPropertyDAO(fld, "Format", dbText, "Currency", _
strErrMsg)
Case dbLong, dbInteger, dbByte, dbDouble, dbSingle, dbDecimal
fld.DefaultValue = vbNullString
Case dbBoolean
Call SetPropertyDAO(fld, "DisplayControl", dbInteger, _
CInt(acCheckBox))
End Select

'Set a caption if needed.
strCaption = ConvertMixedCase(fld.Name)
If strCaption <> fld.Name Then
Call SetPropertyDAO(fld, "Caption", dbText, strCaption)
End If

'Set the field's Description.
Call SetFieldDescription(tdf, fld, , strErrMsg)
Next

'Clean up.
Set fld = Nothing
Set tdf = Nothing
Set db = Nothing
If Len(strErrMsg) > 0 Then
Debug.Print strErrMsg
Else
Debug.Print "Properties set for table " & strTableName
End If
End Function

No comments:

Post a Comment

Designed By Published.. Blogger Templates