[转帖]对shape文件添加属性字段

<TABLE border=0 cellPadding=0 cellSpacing=0 height=98 width="100%">

<TR>
<TD class=summary-title height=18>
<DIV align=center>对shape文件添加属性字段 </DIV></TD></TR>
<TR>
<TD height=4 style="PADDING-BOTTOM: 5px; PADDING-LEFT: 10px; PADDING-RIGHT: 10px; PADDING-TOP: 5px">
<DIV align=right>作者： gis </DIV></TD></TR>
<TR>
<TD height=26 style="PADDING-BOTTOM: 5px; PADDING-LEFT: 10px; PADDING-RIGHT: 10px; PADDING-TOP: 5px">　
<P>gis 大虾转贴在讨论区的代码，使用后发现对与一些文件名长的shapefile有问题，稍微修改了一下。</P>
<P>这里是用dao实现的,有兴趣的可以用ado改写,本质一样
要求:只能对非加载的shape进行操作,对于加的,必须移除,并且与该层相关的对象必须清空.</P>
<P>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</P>
<P>
  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</P></TD></TR>
<TR>
<TD height=4 style="PADDING-BOTTOM: 5px; PADDING-LEFT: 10px; PADDING-RIGHT: 10px; PADDING-TOP: 5px"> </TD></TR>
<TR>
<TD height=4 style="PADDING-BOTTOM: 5px; PADDING-LEFT: 10px; PADDING-RIGHT: 10px; PADDING-TOP: 5px">
<DIV align=left>（作者联系方式： ）</DIV></TD></TR></TABLE>

谢谢了

<P>非常感谢</P><img src="images/post/smile/dvbbs/em01.gif" />

<img src="images/post/smile/dvbbs/em01.gif" />