VB6+Mo基础入门之地图放大、缩小、平移、漫游、全图、颜色修改等

本文链接：https://blog.csdn.net/qq_41441896/article/details/103700096

VB6+Mo基础入门之地图拉框放大、平移、固定放大、固定缩小、漫游、全图、颜色修改等

注意相关事件的添加，以及组件名称的修改！

界面预览
地图拉框放大与平移功能

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    '如果鼠标点击的是左键，就通过鼠标绘制的矩形窗口放大
  If Button = vbLeftButton Then
        Set Map1.Extent = Map1.TrackRectangle
    '如果鼠标点击的是右键，就平移地图
  ElseIf Button = vbRightButton Then
        Map1.Pan
  End If
End Sub

地图固定放大功能

	'首先定义一个活动矩形
	Dim r As MapObjects2.Rectangle
    Set r = Map1.Extent
    '设置比例系数为原视图范围(Extent)的二分之一
    r.ScaleRectangle 0.5
    Map1.Extent = r

地图固定缩小功能

	'首先定义一个活动矩形
	Dim r As MapObjects2.Rectangle
    Set r = Map1.Extent
    '设置比例系数为原视图范围(Extent)的二倍
    r.ScaleRectangle 2
    Map1.Extent = r

地图全图功能

	'设置当前地图范围为整个地图的最小外包矩形
	Set Map1.Extent = Map1.FullExtent
    Map1.Refresh

图层简单颜色变换功能

	'首先定义一个活动图层
	Dim currentLyr As New MapObjects2.MapLayer
	'把第一个图层赋值给当前活动图层currentLyr 
    Set currentLyr = Map1.Layers(0)
    '设置图层要素类颜色为随机色
    currentLyr.Symbol.Color = RGB(Int((255 - 0 + 1) * Rnd + 0), Int((255 - 0 + 1) * Rnd + 0), Int((255 - 0 + 1) * Rnd + 0))
    '设置图层要素外边框线颜色为随机色
    currentLyr.Symbol.OutlineColor = RGB(Int((255 - 0 + 1) * Rnd + 0), Int((255 - 0 + 1) * Rnd + 0), Int((255 - 0 + 1) * Rnd + 0))
    Map1.Refresh

总体实现代码：

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    '如果鼠标点击的是左键，就通过鼠标绘制的矩形放大
  If Button = vbLeftButton Then
        Set Map1.Extent = Map1.TrackRectangle
    '如果鼠标点击的是右键，就平移地图
  ElseIf Button = vbRightButton Then
        Map1.Pan
  End If
End Sub

Private Sub 固定放大_Click()
    '首先定义一个活动矩形
    Dim r As MapObjects2.Rectangle
    Set r = Map1.Extent
    '设置比例系数为原视图范围(Extent)的二分之一
    r.ScaleRectangle 0.5
    Map1.Extent = r
End Sub

Private Sub 固定缩小_Click()
    '首先定义一个活动矩形
    Dim r As MapObjects2.Rectangle
    Set r = Map1.Extent
    '设置比例系数为原视图范围(Extent)的二倍
    r.ScaleRectangle 2
    Map1.Extent = r
End Sub

Private Sub 全图_Click()
    '设置当前地图范围为整个地图的最小外包矩形
    Set Map1.Extent = Map1.FullExtent
    Map1.Refresh
End Sub

Private Sub 修改颜色_Click()
    On Error GoTo eTrap '防止有栅格图层报错
    '首先定义一个活动图层
    Dim currentLyr As New MapObjects2.MapLayer
    Dim i As Integer
    '遍历地图中的所有图层
    For i = 0 To Map1.Layers.Count - 1
    '把遍历的图层赋值给当前活动图层currentLyr
    Set currentLyr = Map1.Layers(i)
    '设置图层要素类颜色为随机色
    currentLyr.Symbol.Color = RGB(Int((255 - 0 + 1) * Rnd + 0), Int((255 - 0 + 1) * Rnd + 0), Int((255 - 0 + 1) * Rnd + 0))
    '设置图层要素外边框线颜色为随机色
    currentLyr.Symbol.OutlineColor = RGB(Int((255 - 0 + 1) * Rnd + 0), Int((255 - 0 + 1) * Rnd + 0), Int((255 - 0 + 1) * Rnd + 0))
    Next i
    Map1.Refresh
    Exit Sub
	eTrap:
        If Err.Number <> cdlCancel Then
             MsgBox Err.Description, vbCritical
        End If

End Sub