VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "SnappingGrid"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Private Declare Function SetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long

Public Spacing As Double  '網格的邊長
Public Color As Long      '網格的顏色

'顯示網格
Sub Draw(Map As MapObjects2.Map, hDC As Long)
  If Spacing = 0 Then Exit Sub
  
  '若網格太密，則不顯示網格
  spacingC = Map.FromMapDistance(Spacing)
  spacingP = Map.Parent.ScaleX(spacingC, vbTwips, vbPixels)
  
  If spacingP < 4 Then Exit Sub
  
  Set ext = Map.Extent
  Set fext = Map.FullExtent
  
  Dim xCount As Integer, yCount As Integer
  Dim xFirst As Integer, yFirst As Integer
  
  '計算第一個可見的網格標志
  xFirst = (ext.Left - fext.Left) / Spacing
  yFirst = (ext.Bottom - fext.Bottom) / Spacing
  
  '計算網格標志數量
  xCount = ext.Width / Spacing
  yCount = ext.Height / Spacing
    
  '計算左下和右上網格標志的坐標
  Dim p1 As New MapObjects2.Point
  Dim p2 As New MapObjects2.Point
  p1.x = fext.Left + (Spacing * xFirst)
  p1.y = fext.Bottom + (Spacing * yFirst)
  p2.x = fext.Left + (Spacing * (xFirst + xCount))
  p2.y = fext.Bottom + (Spacing * (yFirst + yCount))
  
  '將第一個和最后一個網格標志坐標轉換為窗體坐標
  Dim xc1 As Single, xc2 As Single, yc1 As Single, yc2 As Single
  Dim xp1 As Integer, xp2 As Integer, yp1 As Integer, yp2 As Integer
  Map.FromMapPoint p1, xc1, yc1
  Map.FromMapPoint p2, xc2, yc2
  
  xp1 = Map.Parent.ScaleX(xc1, vbTwips, vbPixels) ' pixels
  yp1 = Map.Parent.ScaleY(yc1, vbTwips, vbPixels) ' pixels
  xp2 = Map.Parent.ScaleX(xc2, vbTwips, vbPixels) ' pixels
  yp2 = Map.Parent.ScaleY(yc2, vbTwips, vbPixels) ' pixels
    
  '計算網格標志間的距離，單位是pixel
  Dim xFact As Double, yFact As Double
  xFact = CDbl(xp2 - xp1) / xCount
  yFact = CDbl(yp2 - yp1) / yCount
  
  For x = 0 To xCount - 1
    For y = 0 To yCount - 1
      SetPixel hDC, xp1 + x * xFact, yp1 + y * yFact, Color
    Next y
  Next x
End Sub

Sub SnapPoint(pt As MapObjects2.Point, Map As MapObjects2.Map)
  If Spacing = 0 Then Exit Sub
  
  Set fext = Map.FullExtent
  
  '計算網格點坐標
  Dim xGrid As Integer, yGrid As Integer
  xGrid = (pt.x - fext.Left) / Spacing
  yGrid = (pt.y - fext.Bottom) / Spacing
  
  '計算出此網格點的地圖坐標系上的坐標
  Dim xM As Double, yM As Double
  xM = fext.Left + Spacing * xGrid
  yM = fext.Bottom + Spacing * yGrid
  
  '若pt坐標和此網格點標志距離小于網格點間距離，則將其靠攏網格標志
  '否則靠攏下一個網格標志
  If (pt.x - xM) < (Spacing / 2) Then
    pt.x = xM
  Else
    pt.x = xM + Spacing
  End If
  
  If (pt.y - yM) < (Spacing / 2) Then
    pt.y = yM
  Else
    pt.y = yM + Spacing
  End If
End Sub

Function SnapPolygon(Poly As MapObjects2.Polygon, Map As MapObjects2.Map) As MapObjects2.Polygon
  '將多邊形轉化為適應當前網格
  Dim SnapPoly As New MapObjects2.Polygon
  Dim SnapPts As New MapObjects2.Points
  
  Dim pts As MapObjects2.Points
  Set pts = Poly.Parts(0)
  
  Dim p As MapObjects2.Point
  For Each p In pts
    SnapPoint p, Map
    SnapPts.Add p
  Next p
  
  SnapPoly.Parts.Add SnapPts
  Set SnapPolygon = SnapPoly
End Function

Private Sub Class_Initialize()
  Spacing = 0
End Sub