Difference between revisions of "Microsoft KB Archive/249682"

From BetaArchive Wiki
m (Text replacement - "&" to "&")
m (Text replacement - """ to """)
 
Line 138: Line 138:
  
 
   DBEngine(0).BeginTrans
 
   DBEngine(0).BeginTrans
   Process = "Removing relations on [" & TableName & "]![" & FieldName & "]"
+
   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 = "Removing relation " & R.Name
+
           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 = "Removing relation " & R.Name
+
           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 = "Removing indexes on [" & TableName & "]![" & FieldName & "]"
+
   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 = "Removing index " & I.Name
+
           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 = "Renaming field"
+
   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 = "XXX" & Suffix
+
     TempFieldName = "XXX" & Suffix
 
   Loop While IsField(td, TempFieldName)
 
   Loop While IsField(td, TempFieldName)
  
 
   ' rename the field
 
   ' rename the field
   SubProcess = "to " & TempFieldName
+
   SubProcess = "to " & TempFieldName
 
   F.Name = TempFieldName
 
   F.Name = TempFieldName
  
Line 220: Line 220:
  
 
   DBEngine(0).BeginTrans
 
   DBEngine(0).BeginTrans
   Process = "Adding new field"
+
   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 = "Copying data from " & TempFieldName & " to " & FieldName
+
   Process = "Copying data from " & TempFieldName & " to " & FieldName
   SubProcess = ""
+
   SubProcess = ""
   db.Execute "UPDATE [" & TableName & "] SET [" & FieldName & "]=[" & _
+
   db.Execute "UPDATE [" & TableName & "] SET [" & FieldName & "]=[" & _
               TempFieldName & "]", dbFailOnError
+
               TempFieldName & "]", dbFailOnError
 
   DBEngine(0).CommitTrans
 
   DBEngine(0).CommitTrans
  
Line 246: Line 246:
  
 
   DBEngine(0).BeginTrans
 
   DBEngine(0).BeginTrans
   Process = "Deleting temporary field " & TempFieldName
+
   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 = "Adding indexes back into table"
+
   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 = &quot;Adding index &quot; & I.Name
+
         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 = &quot;Adding index &quot; & I.Name
+
     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 = &quot;Adding relations back into database&quot;
+
   Process = "Adding relations back into database"
   SubProcess = &quot;&quot;
+
   SubProcess = ""
   OldName = &quot;&quot;
+
   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 = &quot;Adding relation &quot; & R.Name
+
         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 = &quot;Adding relation &quot; & R.Name
+
     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, &quot;ChangeFieldType&quot;, E_Desc
+
   Err.Raise CFT_Failed, "ChangeFieldType", E_Desc
 
   Exit Sub
 
   Exit Sub
 
    
 
    
 
CFT_Err:
 
CFT_Err:
   E_Desc = &quot;Error &quot; & Process
+
   E_Desc = "Error " & Process
   If SubProcess <> &quot;&quot; Then E_Desc = E_Desc & vbCrLf & 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 & vbCrLf & &quot;Error &quot; & Err.Number & &quot; &quot; & _
+
     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 & vbCrLf & &quot;Error &quot; & E.Number & &quot; (&quot; & _
+
       E_Desc = E_Desc & vbCrLf & "Error " & E.Number & " (" & _
               E.Source & &quot;) &quot; & E.Description
+
               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 = &quot;c:\Program Files\Microsoft Visual Studio\VB98\Nwind.mdb&quot;
+
     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, &quot;Customers&quot;, &quot;CustomerID&quot;, dbText, 8
+
     ChangeFieldType db, "Customers", "CustomerID", dbText, 8
 
     db.Close
 
     db.Close
 
   
 
   

Latest revision as of 13:51, 21 July 2020

Knowledge Base


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:

  1. Rename the old field.
  2. Add a new field.
  3. Copying the data from the old field to the new field.
  4. 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.

  1. In Visual Basic, create a new Standard EXE project.
    Form1 is created by default.
  2. Add a command button to Form1. Command1 is created by default.
  3. On the Project menu, select References.
    In the References dialog, select the Microsoft DAO Object Library.
  4. On the Project menu, select Add Module to add a Code Module.
    Module1 is created by default.
  5. 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
                            
  6. If necessary, change the CFT_Failed constant to use an error number that conforms to your company's standards.
  7. 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
                            
  8. If necessary, modify strDB to use your Nwind database.
  9. Run the sample project.
    Click the command button.
    End the project.
  10. 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