Public Function SetTableFieldProperty(DBName As String, TableName As String, TableFieldName As String, _
strPropertyName As String, intType As Integer, _
varValue As Variant, Optional ReturnError As String) As Boolean
[COLOR="DarkGreen"] ' -----------------------------------------------------------------------------
' Description:
' ===========
' Purpose:
' Set or change a Table Field Property, creating the property if necessary.
'
' Parameters:
' ==========
' DBName = Path and name of the Database which contains
' the table of the field property we want to
' modify (change or add). If a empty string is
' passed then the Database which calls this function
' is assumed to contain the specified Table.
' TableName = The of the Table which contains the field
' property we want to change.
' TableFieldName = The table Field whose property should be set.
' strPropertyName = The name of the property to set.
' intType = The type of property (needed for creating)
' {See: PROPERTIES FOR TABLE FIELD posted below}
' varValue = The value to set this property to.
' ReturnError = Allow you to supply an Custom Error message which is
' prefixed any error displayed.
'
' Syntax:
' ======
' MsgBox SetTableFieldProperty("", "Mailing List", "FirstName", "Decription", _
10, "The Users First Name")
'
' RETURNS:
' =======
' 0 = Failure - most likely due to an Error of some kind.
' -1 = Successfull
' -2 = The Existing Table (old table) specified can't be
' found in the specified database.
' -3 = The New Table name specified already exists within
' the specified Database.
' -----------------------------------------------------------------------------
'
' PROPERTIES FOR TABLE FIELD
' Property Name & Value Type
'=====================================
' Description Type: 10 (Text)
' Value Type: 10 (Text)
' Attributes Type: 4 (Long)
' CollatingOrder Type: 3 (Integer)
' Type Type: 3 (Integer)
' Name Type: 12 (Memo)
' OrdinalPosition Type: 3 (Integer)
' Size Type: 4 (Long)
' Format Type: 10 (Text)
' InputMask Type: 10 (Text)
' Indexed Type: 3 (Integer)
' SourceField Type: 12 (Memo)
' SourceTable Type: 12 (Memo)
' RowSource Type: 12 (Memo)
' ValidateOnSet Type: 1 (Boolean)
' DataUpdatable Type: 1 (Boolean)
' ForeignName Type: 12 (Memo)
' DefaultValue Type: 12 (Memo)
' ValidationRule Type: 12 (Memo)
' ValidationText Type: 12 (Memo)
' Required Type: 1 (Boolean)
' AllowZeroLength Type: 1 (Boolean)
' FieldSize Type: 4 (Long)
' OriginalValue Type: 10 (Text)
' VisibleValue Type: 10 (Text)
' Caption Type: 12 (Memo)
' BoundColumn Type: 3 (Integer)
' ColumnCount Type: 3 (Integer)
' ColumnWidth Type: 3 (Integer)
' ColumnOrder Type: 3 (Integer)
' ColumnHidden Type: 1 (Boolean)
' DisplayControl Type: 3 (Integer) In The LookUp Property Section
' (Set to 109 for TextBox)
' (Set to 110 for ListBox)
' (Set to 111 for ComboBox)
' UnicodeCompression Type: 1 (Boolean)
' IMEMode Type: 2 (Byte)
' 0 = No Control
' 1 = On
' 2 = Off
' 3 = Disable
' 4 = Hiragana
' 5 = Full pitch Katakana
' 6 = Half pitch Katakana
' 7 = Full pitch Alpha/Num
' 8 = Half pitch Alpha/Num
' 9 = HangulFull
' 10 = Hangul
' IMESentenceMode Type: 2 (Byte)
' 0 = Normal (Phrase Predict)
' 1 = Plural (Plural Clause)
' 2 = Speaking (Conversation)
' 3 = No Conversion (None)
' GUID Type: 9 (Binary)
' -----------------------------------------------------------------------[/COLOR]
On Error GoTo ErrHandler
Dim db As Database
Dim tDef As TableDef
Dim obj As Field
Dim idx As Index
If DBName <> "" Then
If DoesFileExist(DBName) = False Then Exit Function
Set db = OpenDatabase(DBName)
Else
Set db = CurrentDb
End If
Set tDef = db.TableDefs(TableName)
If DoesTableExist(TableName, DBName) = False Then Exit Function
For Each obj In tDef.Fields
If obj.Name = TableFieldName Then
' Set the Indexed property
If strPropertyName = "Indexed" Then
Set idx = tDef.CreateIndex(TableFieldName)
idx.Fields.Append idx.CreateField(TableFieldName)
Select Case varValue
Case 0 'Idexed property set to 'No'
idx.Unique = Null
Case 1 'Idexed property set to 'Yes (No Duplicates)'
idx.Unique = True
Case 2 'Idexed property set to 'Yes (Duplicates OK)'
idx.Unique = False
End Select
tDef.Indexes.Append idx
ElseIf TableFieldHasProperty(obj, strPropertyName) Then 'other properties
obj.Properties(strPropertyName) = varValue
Else
obj.Properties.Append obj.CreateProperty(strPropertyName, intType, varValue)
End If
SetTableFieldProperty = True
End If
Next obj
ExitHandler:
db.Close
Set db = Nothing
Set tDef = Nothing
Set obj = Nothing
Set idx = Nothing
Exit Function
ErrHandler:
ReturnError = ReturnError & obj.Name & "." & strPropertyName & _
" not set to " & varValue & ". Error " & Err.Number & " - " & _
Err.Description & vbCrLf
Resume ExitHandler
End Function
Public Function DoesFileExist(PathStrg As String) As Integer
Dim a$
On Error Resume Next
a$ = Dir(PathStrg, 14)
If a$ <> "" And Err = 0 Then DoesFileExist = -1 Else Err = 0
End Function
Public Function DoesTableExist(TableName As String, Optional DBName As String, Optional LogSuccess As String, _
Optional LogFailure As String) As Boolean
' ---------------------------------------------------------------------
' Returns:
' True (-1) if Table Exists (logged as [1]).
' False (0) if table does not Exist.
' ---------------------------------------------------------------------
Dim db As Database
Dim i As Integer
Dim tbl As String
If DBName <> "" Then
Set db = OpenDatabase(DBName)
Else
Set db = CurrentDb
End If
db.TableDefs.Refresh
tbl = Trim(TableName)
If Left$(tbl, 1) = "[" And Right$(tbl, 1) = "]" Then
tbl = Mid$(tbl, 2, Len(tbl) - 2)
End If
For i = 0 To db.TableDefs.Count - 1
If tbl = db.TableDefs(i).Name Then
'Table Exists
DoesTableExist = True
Exit For
End If
Next i
db.Close
Set db = Nothing
End Function
Public Function TableFieldHasProperty(obj As Object, strPropertyName As String) As Boolean
'Purpose: Return true if the object has the property.
Dim varDummy As Variant
On Error Resume Next
varDummy = obj.Properties(strPropertyName)
TableFieldHasProperty = (Err.Number = 0)
End Function
