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

本人现在有已矢量化好的shp格式的多边形图层(面图层),现在想获得各个顶点的坐标,不知如何操作得到。望大家帮帮忙。

  用XTools工具可以获得点图层中各点的坐标，但对于面图层只能得到其质心的坐标。不知哪位大虾可否帮帮忙解决此问题。

  谢谢了。

解决了可以给大家分享下，就好啦

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

给个代码看看，希望你能稀饭，呵呵

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

Private Sub Form_Load()

'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

'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

'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

'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

End Sub

Private Sub Map1_AfterTrackingLayerDraw(ByVal hDC As stdole.OLE_HANDLE)

'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

End Sub

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

Dim recsDestination As MapObjects2.Recordset Dim pt As MapObjects2.Point Dim tol As Double Dim i As Long, j As Long

Set pt = Map1.ToMapPoint(X, Y)

'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)

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

Map1.Refresh      End Sub

Private Sub FindClosestVertex(ln As MapObjects2.Line, pt As MapObjects2.Point)

'Using "pt", find the closest vertex on "ln".  That closest 'vertex becomes "ptDrag"

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

bFound = False

'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)

'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

If Not bFound Then   bDragging = False   Exit Sub End If

Set ptDrag = ln.Parts(iShortPart)(iShortVert)

'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

lnDrag.Parts.Add ptsDrag

Map1.TrackingLayer.AddEvent ptDrag, 0 Map1.TrackingLayer.AddEvent lnDrag, 1

End Sub

Private Sub Map1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

Dim pt As MapObjects2.Point Set pt = Map1.ToMapPoint(X, Y)

Dim tl As MapObjects2.TrackingLayer Set tl = Map1.TrackingLayer

'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

End Sub

Private Sub Map1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

Dim pt As MapObjects2.Point Set pt = Map1.ToMapPoint(X, Y)

'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

Map1.TrackingLayer.ClearEvents Map1.Refresh

End Sub

Private Function ClosestDestVertex(pt As MapObjects2.Point) As MapObjects2.Point

'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.

Dim ptTemp As New MapObjects2.Point Dim dThisDist As Double, dShortDist As Double Dim i As Long

ptTemp.X = pt.X ptTemp.Y = pt.Y

'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)

'Convert snap tolerance in pixels into map units dShortDist = Map1.ToMapDistance(iSnapTol * Screen.TwipsPerPixelX)

'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

Set ClosestDestVertex = ptTemp

End Function