Microsoft KB Archive/249682: Difference between revisions
m (Text replacement - ">" to ">") |
m (Text replacement - """ to """) |
||
(One intermediate revision by the same user not shown) | |||
Line 138: | Line 138: | ||
DBEngine(0).BeginTrans | DBEngine(0).BeginTrans | ||
Process = | Process = "Removing relations on [" & TableName & "]![" & FieldName & "]" | ||
SubProcess = | SubProcess = "" | ||
For R1 = db.Relations.Count - 1 To 0 Step -1 | For R1 = db.Relations.Count - 1 To 0 Step -1 | ||
Set R = db.Relations(R1) | Set R = db.Relations(R1) | ||
Line 147: | Line 147: | ||
If F.Name = FieldName Then | If F.Name = FieldName Then | ||
RecordRelationInfo R, colR | RecordRelationInfo R, colR | ||
SubProcess = | SubProcess = "Removing relation " & R.Name | ||
db.Relations.Delete R.Name | db.Relations.Delete R.Name | ||
Exit For | Exit For | ||
Line 157: | Line 157: | ||
If F.ForeignName = FieldName Then | If F.ForeignName = FieldName Then | ||
RecordRelationInfo R, colR | RecordRelationInfo R, colR | ||
SubProcess = | SubProcess = "Removing relation " & R.Name | ||
db.Relations.Delete R.Name | db.Relations.Delete R.Name | ||
Exit For | Exit For | ||
Line 171: | Line 171: | ||
DBEngine(0).BeginTrans | DBEngine(0).BeginTrans | ||
Process = | Process = "Removing indexes on [" & TableName & "]![" & FieldName & "]" | ||
SubProcess = | SubProcess = "" | ||
db.TableDefs.Refresh | db.TableDefs.Refresh | ||
Set td = db(TableName) | Set td = db(TableName) | ||
Line 183: | Line 183: | ||
If F.Name = FieldName Then | If F.Name = FieldName Then | ||
RecordIndexInfo I, colI | RecordIndexInfo I, colI | ||
SubProcess = | SubProcess = "Removing index " & I.Name | ||
td.Indexes.Delete I.Name | td.Indexes.Delete I.Name | ||
Exit For | Exit For | ||
Line 197: | Line 197: | ||
DBEngine(0).BeginTrans | DBEngine(0).BeginTrans | ||
Process = | Process = "Renaming field" | ||
SubProcess = | SubProcess = "" | ||
td.Fields.Refresh | td.Fields.Refresh | ||
Set F = td(FieldName) | Set F = td(FieldName) | ||
Line 207: | Line 207: | ||
Do | Do | ||
Suffix = Suffix + 1 | Suffix = Suffix + 1 | ||
TempFieldName = | TempFieldName = "XXX" & Suffix | ||
Loop While IsField(td, TempFieldName) | Loop While IsField(td, TempFieldName) | ||
' rename the field | ' rename the field | ||
SubProcess = | SubProcess = "to " & TempFieldName | ||
F.Name = TempFieldName | F.Name = TempFieldName | ||
Line 220: | Line 220: | ||
DBEngine(0).BeginTrans | DBEngine(0).BeginTrans | ||
Process = | Process = "Adding new field" | ||
SubProcess = | SubProcess = "" | ||
td.Fields.Refresh | td.Fields.Refresh | ||
Set F = td.CreateField(FieldName, NewType) | Set F = td.CreateField(FieldName, NewType) | ||
Line 237: | Line 237: | ||
DBEngine(0).BeginTrans | DBEngine(0).BeginTrans | ||
Process = | Process = "Copying data from " & TempFieldName & " to " & FieldName | ||
SubProcess = | SubProcess = "" | ||
db.Execute | db.Execute "UPDATE [" & TableName & "] SET [" & FieldName & "]=[" & _ | ||
TempFieldName & | TempFieldName & "]", dbFailOnError | ||
DBEngine(0).CommitTrans | DBEngine(0).CommitTrans | ||
Line 246: | Line 246: | ||
DBEngine(0).BeginTrans | DBEngine(0).BeginTrans | ||
Process = | Process = "Deleting temporary field " & TempFieldName | ||
SubProcess = | SubProcess = "" | ||
Set td = db(TableName) | Set td = db(TableName) | ||
td.Fields.Delete TempFieldName | td.Fields.Delete TempFieldName | ||
Line 255: | Line 255: | ||
DBEngine(0).BeginTrans | DBEngine(0).BeginTrans | ||
Process = | Process = "Adding indexes back into table" | ||
SubProcess = | SubProcess = "" | ||
Set td = db(TableName) | Set td = db(TableName) | ||
td.Fields.Refresh | td.Fields.Refresh | ||
td.Indexes.Refresh | td.Indexes.Refresh | ||
OldName = | OldName = "" | ||
Set I = Nothing | Set I = Nothing | ||
For Each Temp In colI | For Each Temp In colI | ||
If Temp(I_NAME) <> OldName Then | If Temp(I_NAME) <> OldName Then | ||
If Not (I Is Nothing) Then ' handle first time through case | If Not (I Is Nothing) Then ' handle first time through case | ||
SubProcess = | SubProcess = "Adding index " & I.Name | ||
td.Indexes.Append I | td.Indexes.Append I | ||
End If | End If | ||
Line 280: | Line 280: | ||
Next Temp | Next Temp | ||
If Not (I Is Nothing) Then ' handle case of no indexes | If Not (I Is Nothing) Then ' handle case of no indexes | ||
SubProcess = | SubProcess = "Adding index " & I.Name | ||
td.Indexes.Append I | td.Indexes.Append I | ||
End If | End If | ||
Line 291: | Line 291: | ||
DBEngine(0).BeginTrans | DBEngine(0).BeginTrans | ||
Process = | Process = "Adding relations back into database" | ||
SubProcess = | SubProcess = "" | ||
OldName = | OldName = "" | ||
db.Relations.Refresh | db.Relations.Refresh | ||
Set R = Nothing | Set R = Nothing | ||
Line 299: | Line 299: | ||
If Temp(I_NAME) <> OldName Then | If Temp(I_NAME) <> OldName Then | ||
If Not (R Is Nothing) Then ' handle first time through case | If Not (R Is Nothing) Then ' handle first time through case | ||
SubProcess = | SubProcess = "Adding relation " & R.Name | ||
db.Relations.Append R | db.Relations.Append R | ||
End If | End If | ||
Line 310: | Line 310: | ||
Next Temp | Next Temp | ||
If Not (R Is Nothing) Then ' if there are no indexes... | If Not (R Is Nothing) Then ' if there are no indexes... | ||
SubProcess = | SubProcess = "Adding relation " & R.Name | ||
db.Relations.Append R | db.Relations.Append R | ||
End If | End If | ||
Line 330: | Line 330: | ||
Err.Clear | Err.Clear | ||
On Error GoTo 0 | On Error GoTo 0 | ||
Err.Raise CFT_Failed, | Err.Raise CFT_Failed, "ChangeFieldType", E_Desc | ||
Exit Sub | Exit Sub | ||
CFT_Err: | CFT_Err: | ||
E_Desc = | E_Desc = "Error " & Process | ||
If SubProcess <> | If SubProcess <> "" Then E_Desc = E_Desc & vbCrLf & SubProcess | ||
If DBEngine.Errors.Count = 0 Then | If DBEngine.Errors.Count = 0 Then | ||
E_Desc = E_Desc & | E_Desc = E_Desc & vbCrLf & "Error " & Err.Number & " " & _ | ||
Err.Description | Err.Description | ||
Else | Else | ||
For Each E In DBEngine.Errors | For Each E In DBEngine.Errors | ||
E_Desc = E_Desc & | E_Desc = E_Desc & vbCrLf & "Error " & E.Number & " (" & _ | ||
E.Source & | E.Source & ") " & E.Description | ||
Next E | Next E | ||
End If | End If | ||
Line 403: | Line 403: | ||
Dim strDB As String | Dim strDB As String | ||
strDB = | strDB = "c:\Program Files\Microsoft Visual Studio\VB98\Nwind.mdb" | ||
Dim db As DAO.Database | Dim db As DAO.Database | ||
Set db = DBEngine(0).OpenDatabase(strDB) | Set db = DBEngine(0).OpenDatabase(strDB) | ||
ChangeFieldType db, | ChangeFieldType db, "Customers", "CustomerID", dbText, 8 | ||
db.Close | db.Close | ||
Latest revision as of 13:51, 21 July 2020
Article ID: 249682
Article Last Modified on 6/29/2004
APPLIES TO
- Microsoft Visual Basic 5.0 Professional Edition
- Microsoft Visual Basic 6.0 Professional Edition
- Microsoft Visual Basic 5.0 Enterprise Edition
- Microsoft Visual Basic 6.0 Enterprise Edition
This article was previously published under Q249682
SUMMARY
Microsoft Access allows you to modify an existing field's data type. To do so programmatically, Microsoft Jet 4.0 introduces the ALTER TABLE ALTER COLUMN DDL statement. However, there is no equivalent for Microsoft Jet 3.5.
This article demonstrates a method to alter a field's data type using DAO objects.
MORE INFORMATION
Modifying a field's data type requires the following steps:
- Rename the old field.
- Add a new field.
- Copying the data from the old field to the new field.
- Delete the old field.
If the table has any indexes or relations, the relationships and indexes must be dropped prior to performing the steps above, then re-established after completion of the steps above.
Microsoft Access handles indexes but not relationships when changing data types.
The Jet 4.0 ALTER TABLE ALTER COLUMN DDL statement has similar limitations.
The sample code provided handles both indexes and relationships. It also contains error handling to roll back the changes and report on any problems.
The main procedure is ChangeFieldType. It takes the following arguments:
- db - an open Database object where the table resides.
- TableName - the name of the table where the field resides.
- FieldName - the name of the field to be changed.
- NewType - the new data type for the field.
- NewAllowZeroLength - new value for the AllowZeroLength property.
- NewAllowNulls - used to set the Required property of the new field.
- NewAttributes - used to set the Attributes property of the new field.
Note: This procedure is for illustration purposes only. For example, the procedure copies only basic field properties. In addition to these basic field properties, other field properties might also have to be copied. These additional field properties include ValidationRule, ValidationText, DecimalPlaces, and others, depending on the field type. In addition, the procedure does not copy user-defined properties.
The other procedures, RecordRelationInfo, RecordIndexInfo, IsField, and MakeArray, are helper procedures used by the main function.
Sample Code
This sample changes the CustomerID field in the Customers table from a five character field to an eight character field.
The sample uses the Nwind database that comes with Visual Basic.
- In Visual Basic, create a new Standard EXE project.
Form1 is created by default. - Add a command button to Form1. Command1 is created by default.
- On the Project menu, select References.
In the References dialog, select the Microsoft DAO Object Library. - On the Project menu, select Add Module to add a Code Module.
Module1 is created by default. Paste the following code into the General Declarations section of Module1's Code Window:
Option Compare Text Option Explicit Const CFT_Failed As Long = 55555 Private Const R_NAME = 0, R_ATTRIBUTES = 1, R_TABLE = 2, R_FOREIGNTABLE = 3, R_FIELD = 4, R_FOREIGNFIELD = 5 Private Const I_NAME = 0, I_PRIMARY = 1, I_UNIQUE = 2, I_REQUIRED = 3, I_IGNORENULLS = 4, I_CLUSTERED = 5, I_FIELD = 6, I_FIELDATTRIBUTES = 7 Public Sub ChangeFieldType(db As Database, _ ByVal TableName As String, _ ByVal FieldName As String, _ ByVal NewType As Integer, _ Optional NewSize As Long, _ Optional NewAllowZeroLength As Boolean = False, _ Optional NewAllowNulls As Boolean = True, _ Optional NewAttributes As Long) ' User-defined properties are not maintained Dim td As TableDef, I As Index, R As Relation, F As Field ' loop iterators for Indexes, Fields, and Relations collections: Dim I1 As Long, F1 As Long, R1 As Long Dim colR As Collection, colI As Collection Dim E_Desc As String, Process As String, SubProcess As String, E As Error Dim TempFieldName As String, Suffix As Long, OldName As String Dim Temp As Variant Dim OrdinalPosition As Long Set colI = New Collection Set colR = New Collection On Error GoTo CFT_Err DBEngine(0).BeginTrans ' Enumerate relations and save/remove them DBEngine(0).BeginTrans Process = "Removing relations on [" & TableName & "]![" & FieldName & "]" SubProcess = "" For R1 = db.Relations.Count - 1 To 0 Step -1 Set R = db.Relations(R1) If R.Table = TableName Then For F1 = 0 To R.Fields.Count - 1 Set F = R.Fields(F1) If F.Name = FieldName Then RecordRelationInfo R, colR SubProcess = "Removing relation " & R.Name db.Relations.Delete R.Name Exit For End If Next F1 ElseIf R.ForeignTable = TableName Then For F1 = 0 To R.Fields.Count - 1 Set F = R.Fields(F1) If F.ForeignName = FieldName Then RecordRelationInfo R, colR SubProcess = "Removing relation " & R.Name db.Relations.Delete R.Name Exit For End If Next F1 End If Next R1 Set F = Nothing Set R = Nothing DBEngine(0).CommitTrans ' Enumerate indices and save/remove them DBEngine(0).BeginTrans Process = "Removing indexes on [" & TableName & "]![" & FieldName & "]" SubProcess = "" db.TableDefs.Refresh Set td = db(TableName) td.Indexes.Refresh For I1 = td.Indexes.Count - 1 To 0 Step -1 Set I = td.Indexes(I1) If I.Foreign <> True Then For F1 = 0 To I.Fields.Count - 1 Set F = I.Fields(F1) If F.Name = FieldName Then RecordIndexInfo I, colI SubProcess = "Removing index " & I.Name td.Indexes.Delete I.Name Exit For End If Next F1 End If Next I1 Set F = Nothing Set I = Nothing DBEngine(0).CommitTrans ' Rename Field DBEngine(0).BeginTrans Process = "Renaming field" SubProcess = "" td.Fields.Refresh Set F = td(FieldName) OrdinalPosition = F.OrdinalPosition ' save this value ' determine a field name not in use Suffix = 0 Do Suffix = Suffix + 1 TempFieldName = "XXX" & Suffix Loop While IsField(td, TempFieldName) ' rename the field SubProcess = "to " & TempFieldName F.Name = TempFieldName Set F = Nothing DBEngine(0).CommitTrans ' Add new Field DBEngine(0).BeginTrans Process = "Adding new field" SubProcess = "" td.Fields.Refresh Set F = td.CreateField(FieldName, NewType) If NewSize Then F.Size = NewSize F.AllowZeroLength = NewAllowZeroLength F.Required = Not NewAllowNulls F.Attributes = NewAttributes F.OrdinalPosition = OrdinalPosition td.Fields.Append F Set F = Nothing Set td = Nothing DBEngine(0).CommitTrans ' Copy data DBEngine(0).BeginTrans Process = "Copying data from " & TempFieldName & " to " & FieldName SubProcess = "" db.Execute "UPDATE [" & TableName & "] SET [" & FieldName & "]=[" & _ TempFieldName & "]", dbFailOnError DBEngine(0).CommitTrans ' Delete temporary field DBEngine(0).BeginTrans Process = "Deleting temporary field " & TempFieldName SubProcess = "" Set td = db(TableName) td.Fields.Delete TempFieldName DBEngine(0).CommitTrans ' Add back Indices DBEngine(0).BeginTrans Process = "Adding indexes back into table" SubProcess = "" Set td = db(TableName) td.Fields.Refresh td.Indexes.Refresh OldName = "" Set I = Nothing For Each Temp In colI If Temp(I_NAME) <> OldName Then If Not (I Is Nothing) Then ' handle first time through case SubProcess = "Adding index " & I.Name td.Indexes.Append I End If Set I = td.CreateIndex(Temp(I_NAME)) I.Primary = Temp(I_PRIMARY) I.Unique = Temp(I_UNIQUE) I.Required = Temp(I_REQUIRED) I.IgnoreNulls = Temp(I_IGNORENULLS) I.Clustered = Temp(I_CLUSTERED) End If Set F = I.CreateField(Temp(I_FIELD)) F.Attributes = Temp(I_FIELDATTRIBUTES) ' to handle descending index I.Fields.Append F Next Temp If Not (I Is Nothing) Then ' handle case of no indexes SubProcess = "Adding index " & I.Name td.Indexes.Append I End If Set F = Nothing Set I = Nothing Set td = Nothing DBEngine(0).CommitTrans ' Add back relations DBEngine(0).BeginTrans Process = "Adding relations back into database" SubProcess = "" OldName = "" db.Relations.Refresh Set R = Nothing For Each Temp In colR If Temp(I_NAME) <> OldName Then If Not (R Is Nothing) Then ' handle first time through case SubProcess = "Adding relation " & R.Name db.Relations.Append R End If Set R = db.CreateRelation(Temp(R_NAME), Temp(R_TABLE), _ Temp(R_FOREIGNTABLE), Temp(R_ATTRIBUTES)) End If Set F = R.CreateField(Temp(R_FIELD)) F.ForeignName = Temp(R_FOREIGNFIELD) R.Fields.Append F Next Temp If Not (R Is Nothing) Then ' if there are no indexes... SubProcess = "Adding relation " & R.Name db.Relations.Append R End If Set F = Nothing Set R = Nothing DBEngine(0).CommitTrans ' Commit all pending chhanges DBEngine(0).CommitTrans Exit Sub CFT_Abort: On Error Resume Next Set F = Nothing Set td = Nothing DBEngine(0).Rollback DBEngine(0).Rollback Err.Clear On Error GoTo 0 Err.Raise CFT_Failed, "ChangeFieldType", E_Desc Exit Sub CFT_Err: E_Desc = "Error " & Process If SubProcess <> "" Then E_Desc = E_Desc & vbCrLf & SubProcess If DBEngine.Errors.Count = 0 Then E_Desc = E_Desc & vbCrLf & "Error " & Err.Number & " " & _ Err.Description Else For Each E In DBEngine.Errors E_Desc = E_Desc & vbCrLf & "Error " & E.Number & " (" & _ E.Source & ") " & E.Description Next E End If Debug.Print E_Desc Resume CFT_Abort End Sub Private Sub RecordRelationInfo(ByVal R As Relation, colR As Collection) ' Records information regarding the relationship and its fields ' in the colR collection. Dim F1 As Long, F As Field For F1 = 0 To R.Fields.Count - 1 Set F = R.Fields(F1) colR.Add MakeArray(R.Name, R.Attributes, R.Table, R.ForeignTable, _ F.Name, F.ForeignName) Next F1 End Sub Private Sub RecordIndexInfo(ByVal I As Index, colI As Collection) ' Records information about fields in the index and about the index itself ' into the colI collection. Dim F1 As Long, F As Field For F1 = 0 To I.Fields.Count - 1 Set F = I.Fields(F1) colI.Add MakeArray(I.Name, I.Primary, I.Unique, I.Required, _ I.IgnoreNulls, I.Clustered, F.Name, F.Attributes) Next F1 End Sub Private Function IsField(td As TableDef, ByVal FieldName As String) _ As Boolean ' Returns TRUE if a field exists in the table with the same name as ' specified in FieldName. ' Returns FALSE otherwise. Dim F As Field Err.Clear On Error Resume Next Set F = td(FieldName) IsField = Err.Number = 0 Err.Clear End Function Private Function MakeArray(ParamArray X() As Variant) As Variant ' Does the same thing as the Array() function in VB6 MakeArray = X End Function
- If necessary, change the CFT_Failed constant to use an error number that conforms to your company's standards.
Paste the following code into the General Declarations section of Form1's Code Window:
Private Sub Command1_Click() Dim strDB As String strDB = "c:\Program Files\Microsoft Visual Studio\VB98\Nwind.mdb" Dim db As DAO.Database Set db = DBEngine(0).OpenDatabase(strDB) ChangeFieldType db, "Customers", "CustomerID", dbText, 8 db.Close End Sub
- If necessary, modify strDB to use your Nwind database.
- Run the sample project.
Click the command button.
End the project. - Examine the table in Microsoft Access or the Visual Basic Visual Database Manager add-in.
Note that the field has been resized.
REFERENCES
For additional information, please see the following article in the Microsoft Knowledge Base:
217011 How To Copy a DAO Tabledef Including User-Defined Properties
Additional query words: kbdsupport kbgrpvbdb
Keywords: kbhowto kbjet KB249682