grid.cls

用vc+mapx制作的地理信息系统软件

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