[求助]如何获得shp格式多边形的所有顶点坐标?

<P>本人现在有已矢量化好的shp格式的多边形图层(面图层),现在想获得各个顶点的坐标,不知如何操作得到。望大家帮帮忙。</P>
<P>   用XTools工具可以获得点图层中各点的坐标，但对于面图层只能得到其质心的坐标。不知哪位大虾可否帮帮忙解决此问题。</P>
<P>   谢谢了。</P>

我想肯定有懂的朋友,请帮帮忙.我的QQ:88421251.
我继续顶..
谢谢了.

<DIV class=quote><B>以下是引用<I>wangjunjolly</I>在2004-5-8 12:18:56的发言：</B>
我想肯定有懂的朋友,请帮帮忙.我的QQ:88421251.
我继续顶..
谢谢了.</DIV>
<P>给个代码看看，希望你能稀饭，呵呵</P>
<P> </P>
<P>Option Explicit
Private recsOrigin As MapObjects2.Recordset
Private lnOrigin As MapObjects2.Line
Private lnDestination As MapObjects2.Line
Private lnDrag As MapObjects2.Line
Private ptsOrigin As MapObjects2.Points
Private ptsDestination As MapObjects2.Points
Private ptDrag As MapObjects2.Point
Private bDragging As Boolean
Private symOrigin As MapObjects2.Symbol
Private symDestination As MapObjects2.Symbol
Private symVertices As MapObjects2.Symbol
Private symLineDrag As MapObjects2.Symbol
Private symPtDrag As MapObjects2.Symbol
Private iShortPart As Integer
Private iShortVert As Long
Private iSelTol As Integer
Private iSnapTol As Integer</P>
<P>Private Sub Form_Load()</P>
<P>'Load shapefile as new layer
Dim dc As New MapObjects2.DataConnection
Dim mlyr As New MapObjects2.MapLayer
dc.Database = App.Path
dc.Connect
Set mlyr.GeoDataset = dc.FindGeoDataset("lines")
mlyr.Symbol.Color = moBlue
Map1.Layers.Add mlyr</P>
<P>'Zoom out a bit
Dim rect As MapObjects2.Rectangle
Set rect = Map1.FullExtent
rect.ScaleRectangle 1.1
Set Map1.FullExtent = rect
Set Map1.Extent = rect</P>
<P>'Symbology
Set symOrigin = New MapObjects2.Symbol
With symOrigin
  .SymbolType = moLineSymbol
  .Style = moSolidLine
  .Color = moGreen
  .Size = 2
End With
Set symDestination = New MapObjects2.Symbol
With symDestination
  .SymbolType = moLineSymbol
  .Style = moSolidLine
  .Color = moRed
  .Size = 2
End With
Set symVertices = New MapObjects2.Symbol
With symVertices
  .SymbolType = moPointSymbol
  .Style = moSquareMarker
  .Size = 5
End With</P>
<P>'Rubber band dragging line, and vertex
Map1.TrackingLayer.SymbolCount = 2
With Map1.TrackingLayer.Symbol(0)
  .SymbolType = moPointSymbol
  .Style = moBlack
  .Size = 5
End With
With Map1.TrackingLayer.Symbol(1)
  .SymbolType = moLineSymbol
  .Style = moSolidLine
  .Color = moBlack
  .Size = 1
End With</P>
<P>
End Sub</P>
<P>Private Sub Map1_AfterTrackingLayerDraw(ByVal hDC As stdole.OLE_HANDLE)</P>
<P>'If selected lines exist, draw them
If Not lnDestination Is Nothing Then
  Map1.DrawShape lnDestination, symDestination
  symVertices.Color = moRed
  Map1.DrawShape ptsDestination, symVertices
End If
If Not lnOrigin Is Nothing Then
  Map1.DrawShape lnOrigin, symOrigin
  symVertices.Color = moGreen
  Map1.DrawShape ptsOrigin, symVertices
End If</P>
<P>End Sub</P>
<P>Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)</P>
<P>Dim recsDestination As MapObjects2.Recordset
Dim pt As MapObjects2.Point
Dim tol As Double
Dim i As Long, j As Long</P>
<P>Set pt = Map1.ToMapPoint(X, Y)</P>
<P>'Get the selection tolerance; handle invalid input
If IsNumeric(txtSelTol.Text) Then
  If txtSelTol.Text > 32767 Then
    txtSelTol.Text = "3"
  End If
 Else
  txtSelTol.Text = "3"
End If
iSelTol = CInt(txtSelTol.Text)
  
tol = Map1.ToMapDistance(iSelTol * Screen.TwipsPerPixelX)</P>
<P>Select Case True
  Case Option1  'SELECT A LINE TO EDIT
    Set recsOrigin = Map1.Layers(0).SearchByDistance(pt, tol, "")
    If Not recsOrigin.EOF Then
      Set lnOrigin = recsOrigin.Fields("Shape").Value
      Set ptsOrigin = New MapObjects2.Points
      For i = 0 To lnOrigin.Parts.Count - 1
        For j = 0 To lnOrigin.Parts(i).Count - 1
          ptsOrigin.Add lnOrigin.Parts(i)(j)
        Next j
      Next i
     Else
      Set lnOrigin = Nothing
      Set ptsOrigin = Nothing
    End If
    Option2.Value = True
  Case Option2  'SELECT A LINE TO SNAP TO
    Set recsDestination = Map1.Layers(0).SearchByDistance(pt, tol, "")
    If Not recsDestination.EOF Then
      Set lnDestination = recsDestination.Fields("Shape").Value
      Set ptsDestination = New MapObjects2.Points
      For i = 0 To lnDestination.Parts.Count - 1
        For j = 0 To lnDestination.Parts(i).Count - 1
          ptsDestination.Add lnDestination.Parts(i)(j)
        Next j
      Next i
     Else
      Set lnDestination = Nothing
      Set ptsDestination = Nothing
    End If
    Option3.Value = True
  Case Option3  'MOVE A VERTEX TO CHANGE THE EDIT SHAPE
    bDragging = True
    Set lnDrag = New MapObjects2.Line
    Call FindClosestVertex(lnOrigin, pt)
End Select</P>
<P>Map1.Refresh
    
End Sub</P>
<P>Private Sub FindClosestVertex(ln As MapObjects2.Line, pt As MapObjects2.Point)</P>
<P>'Using "pt", find the closest vertex on "ln".  That closest
'vertex becomes "ptDrag"</P>
<P>Dim iShortPart As Integer
Dim dShortDist As Double, dThisDist As Double
Dim i As Integer, j As Long
Dim ptsShortPart As MapObjects2.Points
Dim ptsDrag As New MapObjects2.Points
Dim bFound As Boolean</P>
<P>bFound = False</P>
<P>'Get the selection tolerance; handle invalid input
If IsNumeric(txtSelTol.Text) Then
  If txtSelTol.Text > 32767 Then
    txtSelTol.Text = "3"
  End If
 Else
  txtSelTol.Text = "3"
End If
iSelTol = CInt(txtSelTol.Text)</P>
<P>'Find the closest vertex to the mouse click
dShortDist = Map1.ToMapDistance(iSelTol * Screen.TwipsPerPixelX)
For i = 0 To ln.Parts.Count - 1
  For j = 0 To ln.Parts(i).Count - 1
    dThisDist = pt.DistanceTo(ln.Parts(i)(j))
    If dThisDist < dShortDist Then
      bFound = True
      dShortDist = dThisDist
      iShortPart = i
      iShortVert = j
    End If
  Next j
Next i</P>
<P>If Not bFound Then
  bDragging = False
  Exit Sub
End If</P>
<P>Set ptDrag = ln.Parts(iShortPart)(iShortVert)</P>
<P>'Create a rubber band line
Set ptsShortPart = ln.Parts(iShortPart)
Select Case iShortVert
  Case 0
    ptsDrag.Add ptsShortPart(0)
    ptsDrag.Add ptsShortPart(1)
  Case ptsShortPart.Count - 1
    ptsDrag.Add ptsShortPart(iShortVert - 1)
    ptsDrag.Add ptsShortPart(iShortVert)
  Case Else
    ptsDrag.Add ptsShortPart(iShortVert - 1)
    ptsDrag.Add ptsShortPart(iShortVert)
    ptsDrag.Add ptsShortPart(iShortVert + 1)
End Select</P>
<P>lnDrag.Parts.Add ptsDrag</P>
<P>Map1.TrackingLayer.AddEvent ptDrag, 0
Map1.TrackingLayer.AddEvent lnDrag, 1</P>
<P>End Sub</P>
<P>Private Sub Map1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)</P>
<P>Dim pt As MapObjects2.Point
Set pt = Map1.ToMapPoint(X, Y)</P>
<P>Dim tl As MapObjects2.TrackingLayer
Set tl = Map1.TrackingLayer</P>
<P>'If dragging a vertex, change the rubber band shape
'to the mouse's new location.
If bDragging Then
  tl.Event(0).MoveTo pt.X, pt.Y
  tl.RemoveEvent 1
  lnDrag.Parts(0).Set 1, pt
  tl.AddEvent lnDrag, 1
  tl.Refresh True
End If</P>
<P>End Sub</P>
<P>Private Sub Map1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)</P>
<P>Dim pt As MapObjects2.Point
Set pt = Map1.ToMapPoint(X, Y)</P>
<P>'If currently dragging, then find the vertex on the destination
'which is closest to the mouse.  If that closest vertex is within
'30 PIXELS from the mouse, then snap the edit line's vertex to
'the destination line's vertex.
If bDragging Then
  lnOrigin.Parts(iShortPart).Set iShortVert, ClosestDestVertex(pt)
  recsOrigin.Edit
  Set recsOrigin.Fields("Shape").Value = lnOrigin
  recsOrigin.Update
  recsOrigin.StopEditing
  Set ptsOrigin = lnOrigin.Parts(iShortPart)
  Set lnDrag = Nothing
  Set ptDrag = Nothing
  bDragging = False
End If</P>
<P>Map1.TrackingLayer.ClearEvents
Map1.Refresh</P>
<P>End Sub</P>
<P>Private Function ClosestDestVertex(pt As MapObjects2.Point) As MapObjects2.Point</P>
<P>'Given "pt", find the closest point in "ptsDestination".
'Return the resulting point.   If no points in
'"ptsDestination" are within 30 PIXELS, then return the
'input point and edit the line, but do not snap.</P>
<P>Dim ptTemp As New MapObjects2.Point
Dim dThisDist As Double, dShortDist As Double
Dim i As Long</P>
<P>ptTemp.X = pt.X
ptTemp.Y = pt.Y</P>
<P>'Get the snapping tolerance; handle invalid input
If IsNumeric(txtSnapTol.Text) Then
  If txtSnapTol.Text > 32767 Then
    txtSnapTol.Text = "30"
  End If
 Else
  txtSnapTol.Text = "30"
End If
iSnapTol = CInt(txtSnapTol.Text)</P>
<P>'Convert snap tolerance in pixels into map units
dShortDist = Map1.ToMapDistance(iSnapTol * Screen.TwipsPerPixelX)</P>
<P>'Find the closest vertex inside the snapping tolerance, otherwise
'simply return the same point that was entered
For i = 0 To ptsDestination.Count - 1
  dThisDist = pt.DistanceTo(ptsDestination(i))
  If dThisDist < dShortDist Then
    dShortDist = dThisDist
    ptTemp.X = ptsDestination(i).X
    ptTemp.Y = ptsDestination(i).Y
  End If
Next i</P>
<P>Set ClosestDestVertex = ptTemp</P>
<P>End Function
</P>

在mo的例子edit里也有类似的功能了

<P>老大,谢谢了.我一直想着用已有的软件来解决问题,看来还是自己太懒了.这段代码以前看过,不过还是非常感谢你对我的启发.我希望能获取各点坐标并将各点坐标保存到EXCEL 或.TXT格式的文件中去.我想依据你的启发不难就会实现吧.</P>

<P>解决了可以给大家分享下，就好啦</P>