Hello All,
Is it possible to change table field lookup properties in code?
I've been able to change other field properties in code, however so far
no luck with field lookup properties. What I've done for test purposes
is use a text input file for the table field lookup properties. I
thought that I'd start first by just changing the 'Display Control'
property. Thanks to Allen Browne for some ideals per
http://groups.google.com/group/comp....43d398b766f1a0
See code and input below. Hopefully wrapping won't mess everything up.
Any ideals? Thanks!
=====================>Begin Code>===================================>
Sub OpenTxtTblPropFile2()
Const ForReading = 1, ForWriting = 2, ForAppending = 3
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Dim fs, f, ts, s
Dim lngNbrRec As Long, lngLnLength As Long, lngTilde1 As Long, _
lngTilde2 As Long, lngTilde3 As Long, lngTilde4 As Long, _
lngTilde5 As Long, lngTilde6 As Long, lngTilde7 As Long, _
lngTilde8 As Long, lngTilde9 As Long, lngTilde10 As Long, _
lngTilde11 As Long
Dim strLn As String, strTbl As String, strFld As String, _
strDispCntl As String, strRwSrcTyp As String, strRwSrc As
String, _
strBndCol As String, strColCnt As String, strColHds As String, _
strColWidths As String, strLstRw As String, strLstWdth As
String, _
strLmtToLst As String
Dim strErrMsg As String
Dim db As DAO.Database
Dim tbl As DAO.TableDef
Dim fld As DAO.Field
Dim prp As DAO.Property
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile("X:\My Documents\FileRef\Access\SQL Access to SQL
Server\Export\NWLookupProperties.txt")
Set ts = f.OpenAsTextStream(ForReading, TristateUseDefault)
Set db = CurrentDb()
Do While ts.AtEndOfStream <> True
lngNbrRec = lngNbrRec + 1
strLn = ts.ReadLine
lngLnLength = Len(strLn)
lngTilde1 = 0
lngTilde2 = 0
lngTilde3 = 0
lngTilde4 = 0
lngTilde5 = 0
lngTilde6 = 0
lngTilde7 = 0
lngTilde8 = 0
lngTilde9 = 0
lngTilde10 = 0
lngTilde11 = 0
lngTilde1 = InStr(1, strLn, Chr(126), vbTextCompare)
lngTilde2 = InStr(lngTilde1 + 1, strLn, Chr(126), vbTextCompare)
lngTilde3 = InStr(lngTilde2 + 1, strLn, Chr(126), vbTextCompare)
lngTilde4 = InStr(lngTilde3 + 1, strLn, Chr(126), vbTextCompare)
lngTilde5 = InStr(lngTilde4 + 1, strLn, Chr(126), vbTextCompare)
lngTilde6 = InStr(lngTilde5 + 1, strLn, Chr(126), vbTextCompare)
lngTilde7 = InStr(lngTilde6 + 1, strLn, Chr(126), vbTextCompare)
lngTilde8 = InStr(lngTilde7 + 1, strLn, Chr(126), vbTextCompare)
lngTilde9 = InStr(lngTilde8 + 1, strLn, Chr(126), vbTextCompare)
lngTilde10 = InStr(lngTilde9 + 1, strLn, Chr(126),
vbTextCompare)
lngTilde11 = InStr(lngTilde10 + 1, strLn, Chr(126),
vbTextCompare)
' Debug.Print strLn
' Debug.Print "Line Length: "; lngLnLength
' Debug.Print "1st, 2nd, 3rd, 4th Tilde Postn: "; lngTilde1 & " "
& _
' lngTilde2 & " " & lngTilde3 & " " & lngTilde4
' Debug.Print "5th, 6th, 7th, 8th Tilde Postn: "; lngTilde5 & " "
& _
' lngTilde6 & " " & lngTilde7 & " " & lngTilde8
' Debug.Print "9th, 10th, 11th Tilde Postn: "; lngTilde9 & " " &
_
' lngTilde10 & " " & lngTilde11
strTbl = Mid(strLn, 2, lngTilde1 - 3)
strFld = Mid(strLn, lngTilde1 + 2, lngTilde2 - lngTilde1 - 3)
strDispCntl = Mid(strLn, lngTilde2 + 2, lngTilde3 - lngTilde2 -
3)
strRwSrcTyp = Mid(strLn, lngTilde3 + 2, lngTilde4 - lngTilde3 -
3)
strRwSrc = Mid(strLn, lngTilde4 + 2, lngTilde5 - lngTilde4 - 3)
strBndCol = Mid(strLn, lngTilde5 + 2, lngTilde6 - lngTilde5 - 3)
strColCnt = Mid(strLn, lngTilde6 + 2, lngTilde7 - lngTilde6 - 3)
strColHds = Mid(strLn, lngTilde7 + 2, lngTilde8 - lngTilde7 - 3)
strColWidths = Mid(strLn, lngTilde8 + 2, lngTilde9 - lngTilde8 -
3)
strLstRw = Mid(strLn, lngTilde9 + 2, lngTilde10 - lngTilde9 - 3)
strLstWdth = Mid(strLn, lngTilde10 + 2, lngTilde11 - lngTilde10
- 3)
strLmtToLst = Mid(strLn, lngTilde11 + 2, lngLnLength -
lngTilde11 - 2)
' Debug.Print strLn
Debug.Print "Table: "; strTbl
Debug.Print "Field: "; strFld
Debug.Print "Display Control: "; strDispCntl
' Debug.Print "Row Source Type: "; strRwSrcTyp
' Debug.Print "Row Source: "; strRwSrc
' Debug.Print "Bound Column: "; strBndCol
' Debug.Print "Column Count: "; strColCnt
' Debug.Print "Column Heads: "; strColHds
' Debug.Print "Column Widths: "; strColWidths
' Debug.Print "Lists Rows: "; strLstRw
' Debug.Print "List Width: "; strLstWdth
' Debug.Print "Limit To List: "; strLmtToLst
Set tbl = db.TableDefs(strTbl)
Set fld = tbl.Fields(strFld)
Call SetPropertyDAO(fld, "DisplayControl", dbText, strDispCntl,
_
strErrMsg)
Loop
Debug.Print lngNbrRec
ts.Close
Set prp = Nothing
Set fld = Nothing
Set tbl = Nothing
Set db = Nothing
Application.RefreshDatabaseWindow
End Sub
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
=====================<End Code<=====================================<
=====================>Text File Input>==============================>
"Employees"~"TitleOfCourtesy"~"Combo Box"~"Value
List"~"Dr.;Mr.;Miss;Mrs.;Ms."~"1"~"1"~"No"~""~"8"~ "Auto"~"No"
"Employees"~"ReportsTo"~"Combo Box"~"Table/Query"~"SELECT
Employees.EmployeeID, [LastName] & ", " & [FirstName] AS Name FROM
Employees ORDER BY Employees.LastName, Employees.FirstName;
"~"1"~"2"~"No"~"0""~"8"~"Auto"~"Yes"
"Order Details"~"ProductID"~"Combo Box"~"Table/Query"~"SELECT
[ProductID], [ProductName] FROM Products ORDER BY [ProductName];
"~"1"~"2"~"No"~"0""~"8"~"Auto"~"Yes"
"Orders"~"CustomerID"~"Combo Box"~"Table/Query"~"SELECT [CustomerID],
[CompanyName] FROM Customers ORDER BY [CompanyName];
"~"1"~"2"~"No"~"0""~"8"~"Auto"~"Yes"
"Orders"~"EmployeeID"~"Combo Box"~"Table/Query"~"SELECT
Employees.EmployeeID, [LastName] & ", " & [FirstName] AS Name FROM
Employees ORDER BY Employees.LastName, Employees.FirstName;
"~"1"~"2"~"No"~"0""~"8"~"Auto"~"Yes"
"Orders"~"ShipVia"~"Combo Box"~"Table/Query"~"SELECT [ShipperID],
[CompanyName] FROM Shippers ORDER BY [CompanyName];
"~"1"~"2"~"No"~"0""~"8"~"Auto"~"Yes"
"Products"~"SupplierID"~"Combo Box"~"Table/Query"~"SELECT [SupplierID],
[CompanyName] FROM Suppliers ORDER BY [CompanyName];
"~"1"~"2"~"No"~"0""~"8"~"Auto"~"Yes"
"Products"~"CategoryID"~"Combo Box"~"Table/Query"~"SELECT [CategoryID],
[CategoryName] FROM Categories ORDER BY [CategoryName];
"~"1"~"2"~"No"~"0""~"8"~"Auto"~"Yes"
=====================<Text File Input<==============================<
--
Regards,
Greg Strong
