gis 大虾转贴在讨论区的代码，使用后发现对与一些文件名长的shapefile有问题，稍微修改了一下。

这里是用dao实现的,有兴趣的可以用ado改写,本质一样
要求:只能对非加载的shape进行操作,对于加的,必须移除,并且与该层相关的对象必须清空.

Public Sub FieldAppender(dbPath As String, _
                        Filename As String, _
                        newFldname As String, _
                        NewFldType As String, _
                        newFldsize As Integer)
On Error GoTo ErrorHandler:
  Dim curFSYS As New Scripting.FileSystemObject
  Dim oldFileName As String
       
  ' 部分dbf文件名较长,DAO无法处理，所以对该数据进行处理
  If Len(Filename) > 8 Then
    curFSYS.CopyFile dbPath & Filename & ".dbf", dbPath & Left(Filename, 8) & ".dbf", True
  End If
  oldFileName = Filename
  Filename = Left(Filename, 8)
    
    
  Dim db As Database
  Dim tdf1 As TableDef, tdf2 As TableDef
  Dim ndx1 As Index, ndx2 As Index
  Dim fld1 As DAO.Field, fld2 As DAO.Field
  Dim sql As String
 
'  Set db = OpenDatabase(dbPath, False, False, "dBase IV;")
  Set db = OpenDatabase(dbPath, False, False, "dBase IV")
  Debug.Print db.Updatable
  Dim i As Integer
 
  For i = 0 To db.TableDefs.Count - 1
    If db.TableDefs(i).Name = Filename Then
      Set tdf1 = db.TableDefs(Filename)
    End If
    DoEvents
  Next i
  If tdf1 Is Nothing Then
    MsgBox "没有找到该shapefile文件。", vbOKOnly
    Exit Sub
  End If
   
  For i = 0 To db.TableDefs.Count - 1
    If db.TableDefs(i).Name = "SHENYU" Then
      sql = "Drop Table Shenyu"
      db.Execute sql
    End If
    DoEvents
  Next i
 
  Set tdf2 = New TableDef
  tdf2.Name = "Shenyu"
 
  For Each fld1 In tdf1.Fields
    Set fld2 = New DAO.Field
    fld2.Name = fld1.Name
    fld2.Type = fld1.Type
    fld2.Size = fld1.Size
    tdf2.Fields.Append fld2
    DoEvents
  Next fld1

  Set fld2 = New DAO.Field
 
  fld2.Name = newFldname
  fld2.Type = NewFldType
  fld2.Size = newFldsize
 
  tdf2.Fields.Append fld2
 
 
  db.TableDefs.Append tdf2
 
 
  sql = "Insert into Shenyu Select * from " & Filename
  db.Execute sql
 
  Set tdf1 = Nothing
 
  sql = "Drop Table " & Filename
  db.Execute sql
 
  tdf2.Name = Filename
  
  ' 将修改后的dbf覆盖原有的dbf
  If Len(oldFileName) > 8 Then
    curFSYS.CopyFile dbPath & Filename & ".dbf", dbPath & oldFileName & ".dbf", True
    curFSYS.DeleteFile dbPath & Filename & ".dbf", True
  End If
 
  db.Close
  Set db = Nothing
  Exit Sub
 
ErrorHandler:
  db.Close
  Set db = Nothing
  Exit Sub
End Sub

上一篇：设置图层的地图提示字段

下一篇：AO开发中的一些小技巧