如何画一个面，然后移动的代码[原创]

窗体中需要有一个map1，option1和option2控件，具体操作，应该能看懂吧？
Option Explicit
Dim poly1 As MapObjects2.Polygon
Dim poly2 As MapObjects2.Polygon
Dim polyBase As MapObjects2.Polygon
Dim sym1 As MapObjects2.Symbol
Dim sym2 As MapObjects2.Symbol
Dim ptGrab As MapObjects2.Point
Dim bDragging As Boolean

Private Sub Form_Load()

Set sym1 = New MapObjects2.Symbol
With sym1
.SymbolType = moFillSymbol
.Style = moTransparentFill
.OutlineColor = moBlue
.Size = 3
End With
Set sym2 = New MapObjects2.Symbol
With sym2
.SymbolType = moFillSymbol
.Style = moTransparentFill
.OutlineColor = moRed
.Size = 1
End With

bDragging = False

'Map1.TrackingLayerDrawing = moDrawSmooth


End Sub

Private Sub Map1_AfterTrackingLayerDraw(ByVal hDC As stdole.OLE_HANDLE)

If Not poly1 Is Nothing Then
  Map1.DrawShape poly1, sym1
End If
If bDragging Then
  Map1.DrawShape poly2, sym2
End If

End Sub

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

Dim poly As MapObjects2.Polygon

Select Case True
  Case Option1
    Set ptGrab = Nothing
    Set poly1 = Map1.TrackPolygon
  Case Option2
    Set ptGrab = Map1.ToMapPoint(X, Y)
    If poly1.IsPointIn(ptGrab) Then
      bDragging = True
      Set poly2 = CloneShape(poly1)
      Set polyBase = CloneShape(poly1)
    End If
End Select

Map1.TrackingLayer.Refresh True

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)

If bDragging Then
  Set poly2 = CloneShape(polyBase)
  poly2.Offset pt.X - ptGrab.X, pt.Y - ptGrab.Y
  Map1.TrackingLayer.Refresh True
End If

End Sub

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

If bDragging Then
  bDragging = False
  Set poly1 = CloneShape(poly2)
  Set poly2 = Nothing
  Set polyBase = Nothing
  Map1.TrackingLayer.Refresh True
End If

End Sub

Private Function CloneShape(shp As Object) As Object

On Error GoTo CloneFailed

Dim shpReturn As Object
Dim pts As MapObjects2.Points
Dim pt As MapObjects2.Point
Dim i As Integer, j As Long

Select Case True
  Case TypeOf shp Is MapObjects2.Polygon
    Set shpReturn = New MapObjects2.Polygon
    For i = 0 To shp.Parts.Count - 1
      Set pts = New MapObjects2.Points
      For j = 0 To shp.Parts(i).Count - 1
        Set pt = New MapObjects2.Point
        pt.Set shp.Parts(i)(j).X, shp.Parts(i)(j).Y
        pts.Add pt
      Next j
      shpReturn.Parts.Add pts
    Next i
  Case TypeOf shp Is MapObjects2.Line
    Set shpReturn = New MapObjects2.Line
    For i = 0 To shp.Parts.Count - 1
      Set pts = New MapObjects2.Points
      For j = 0 To shp.Parts(i).Count - 1
        Set pt = New MapObjects2.Point
        pt.Set shp.Parts(i)(j).X, shp.Parts(i)(j).Y
        pts.Add pt
      Next j
      shpReturn.Parts.Add pts
    Next i
  Case TypeOf shp Is MapObjects2.Point
    Set shpReturn = New MapObjects2.Point
    shpReturn.Set shp.X, shp.Y
  Case TypeOf shp Is MapObjects2.Rectangle
    Set shpReturn = New MapObjects2.Rectangle
    With shpReturn
      .Left = shp.Left
      .Right = shp.Right
      .Bottom = shp.Bottom
      .Top = shp.Top
    End With
  Case TypeOf shp Is MapObjects2.Ellipse
    Set shpReturn = New MapObjects2.Ellipse
    With shpReturn
      .Left = shp.Left
      .Right = shp.Right
      .Bottom = shp.Bottom
      .Top = shp.Top
    End With
  Case TypeOf shp Is MapObjects2.Points
    Set shpReturn = New MapObjects2.Points
    For i = 0 To shp.Count - 1
      Set pt = New MapObjects2.Point
      pt.Set shp.X, shp.Y
      shpReturn.Add pt
    Next i
  Case Else
    GoTo CloneFailed
End Select

Set CloneShape = shpReturn

Exit Function
CloneFailed:
  Set CloneShape = shpReturn

End Function
<img src="images/post/smile/dvbbs/em12.gif" />

好！

斑竹，你是画完多边形后在移动，我做得是正在画得同时移动图形，以便向屏幕看不到得图上画多边形。

你要是能把自动漫游和绘制图形两个贴结合起来，就解决了吧？