二、系统设计与开发
1．地图数据集的建立
MapX可以直接读取的是包含若干个表文件的地理数据集Gst文件，这里的目的就是有用户指定所需要的地图数据，然后自动生成合适的结果。MapX的安装程序附带了一个应用程序Geoset Manager，它可以将表文件集成为地理数据集Gst，但是考虑到所开发系统的独立性，系统将这一功能予以实现。
这一功能的入口是菜单“地图信息”的子项“新建”，直接对应的代码如下，程序中首先判断当前是否有打开的文档被修改过，如果是，则首先保存之，然后指定欲新建的数据集名称、存放位置，再调用数据层修改功能打开相应的若干表文件，最后将其保存并且初始化相关信息。
Private Sub mnuMapNew_Click()
Dim strFile As String
If(gbDocDirty=True)Then
'gbDocDirty为全局变量，在本章末尾给出定义。
If MsgBox("Save Project?"，vbYesNo+vbInformation)=vbYes Then
mnuMapSave_Click
End If
End If
strFile=GetFileName(0，True)
'获得一个数据集文件名，GetFileName的实现在本章末尾给出。
If(strFile＜＞"")Then
mpMain．Geoset=""
PrepareGUI
'初始化相关的交互信息，具体实现见后述。
mnuMapAlter_Click'表文件的管理
If(mpMain．Layers．Count＞0)Then
'若调入的表文件数目大于0则继续
mnuMapAlter．Enabled=True
Me．tlbMain．Buttons("layer")．Enabled=True
mpMain．SaveMapAsGeoset strFile，strFile
OpenAMap strFile
'打开数据集文件，具体实现见后述。
End If
End If
End Sub
过程中使用到MapX的属性Geoset，它指定待打开的数据集名称，如果赋给空字符串则清空当前数据集，还用到了MapX的方法SaveMapAsGeoset，其要求两个字符串类型的参数，第一个指定数据集的用户名称，第二个是待保存的文件名，这里都是用文件名代替，可以添加一段交互程序，为用户指定一个有一定意义、易于记忆的名称。
2．地图数据集的打开
打开是根据指定的地图数据集的文件名，将附属的表文件调入，这一功能的入口是菜单“地图信息”的子项“打开”，直接对应的代码如下。
Private Sub mnuMapOpen_Click()
Dim strNewGst As String
strNewGst=GetFileName(0)'获得一个数据集文件名
If IsFileExist(strNewGst)
Then OpenAMap strNewGst
'判断文件是否存在，如果存在则打开。
End Sub
3．数据集的修改与保存
数据集的修改是指对当前数据集中包含的表文件进行添加、删除和修改可视等属性，这一功能只在电子地图设计时使用，因此没有对它进行灵活性和应用性的考虑，而直接调用MapX内置的图层管理对话框，该对话框的使用与MapInfo中图层管理是一致的。
Private Sub mnuMapAlter_Click()
gbDocDirty=True'当前的层被修改了?
mpMain．Layers．LayersDlg'调用MapX内置的图层管理对话框
PrepareGUI'更新交互信息
End Sub
对当前操作的地图数据集的保存是通过调用前文述及的MapX的内置方法SaveMapAsGeoset完成的，保存之前要判断当前地图集中表文件数目(图层数)是否为空，因为方法SaveMapAsGeoset不能保存数目为0的数据集。
Private Sub mnuMapSave_Click()
Dim strFile As String
If(mpMain．Layers．Count＞0 And gbDocDirty=True)Then
'当前地图集中图层数不为0，并且被修改过
If(mpMain．Geoset="")Then strFile=GetFileName(0，True)
If(strFile＜＞"")Then
mpMain．SaveMapAsGeoset strFile，strFile
gbDocDirty=False
End If
End If
End Sub
4．视图管理
在计算机环境下传统地图的一览性受到了限制，必须通过一定的手段进行弥补。充分利用计算机可视化的灵活性、动态性，一方面，可以实现记录用户浏览电子地图过程中的视图轨迹，并且在需要时回退到某个状态。另一方面，通过提供一个缩小了的缩略图(索引图)，可以使得用户在使用电子地图过程中时刻清楚当前察看的视图在全图中的位置。
可以利用MapX设计这种功能，其中主要部分是在控件的MapViewChanged事件中进行处理，同时使用了一个自定义的类来管理用户浏览电子地图过程中的视图轨迹。
在HypMap中，缩略图是在MapX控件mpOverview上显示的，缩略图显示的数据集必须与主图显示的数据集相同。该功能的目标是，用户在主图区通过放大、缩小、漫游等功能改变视图时，用一个矩形框同时在缩略图mpOverview中标示出对应的区域;或者用户可以使用鼠标在缩略图mpOverview上画出一个矩形框，然后主图mpMain会调整当前视图，显示该框内的地图信息。有些时候用户可能希望直接在缩略图上拖动小矩形框来改变视图，而不是画出一个矩形，以实现此功能。
首先，在主图打开后，对缩略图进行初始化如下代码实现以及相关注释。
Private Sub InitialOverviewMap()
Dim tmpRect As MapXLib．Rectangle
Dim aRetFtre As MapXLib．Feature
Dim aLyer As MapXLib．Layer
mpOverview．Geoset=mpMain．Geoset'打开同一个数据集
If(mpOverview．Layers．Count＞0)Then
Set mpMain．NumericCoordSys=mpMain．Layers．Item(1)．CoordSys
Set mpOverview．NumericCoordSys=mpMain．NumericCoordSys
Set mpOverview．DisplayCoordSys=mpMain．DisplayCoordSys
'必须将主图的投影设置为图层中使用的投影，这里以第一个图层
'为准。同时缩略图的投影必须以主图为准。
For Each aLyer In mpOverview．Layers
aLyer．Selectable=False
aLyer．Editable=False
aLyer．AutoLabel=False
aLyer．ShowLineDirection=False
Next aLyer
'将缩略图的所有图层设置为只读，且不显示注记。
Set mpOverview．Bounds=mpOverview．Layers．Bounds
'缩略图全图显示所有要素。
Set tmpRect=mpOverview．Bounds
'获取缩略图显示范围。
Set aLyer=mpOverview．Layers．CreateLayer("Locate Rectangle"，，1)
'在缩略图中创建一个临时图层，并置于顶层。
aLyer．Editable=True'将临时图层设置为可编辑。
Set aRetFtre=GetRectFeature(tmpRect．xMin，tmpRect．yMin，_
tmpRect．xMax，tmpRect．yMax，mpOverview)
'将显示范围转换为一个矩形要素。
Set aRetFtre=mpOverview．Layers．Item("Locate Rectangle")．_
AddFeature(aRetFtre)
'将要素添加到缩略图的临时图层上。
mpOverview．Tag=aRetFtre．FeatureKey
'为了方便管理，记录该矩形要素的标识码(关键字)。
End If
End Sub
初始化缩略图的程序中，为了记录并显示标明范围的矩形框，使用到了函数GetRectFeature，其功能是在给定MapX控件上以给定的坐标范围创建一个矩形的面状要素，并作为返回值传递回来。具体实现代码如下。
Private Function GetRectFeature(xMin As Double，yMin As Double，_
xMax As Double，yMax As Double，_
fMapCtl As MapXLib．Map)As MapXLib．Feature
Dim pts As New MapXLib．Points，Pt As New MapXLib．Point
Dim rcEagleLocate As New MapXLib．Feature
Pt．Set xMin，yMin:pts．Add Pt
Pt．Set xMax，yMin:pts．Add Pt
Pt．Set xMax，yMax:pts．Add Pt
Pt．Set xMin，yMax:pts．Add Pt
'使用给定的坐标范围生成含有四个角顶点的点集。
rcEagleLocate．Attach fMapCtl'使用fMapCtl来校正要素的坐标空间。
rcEagleLocate．Type=miFeatureTypeRegion
rcEagleLocate．Parts．Add pts
'将点集添加到新生成的要素上，其为面状要素类型。
With rcEagleLocate．Style
．RegionBorderWidth=2
．RegionBorderColor=vbBlue
．RegionColor=vbRed
．RegionTransparent=True
．RegionPattern=miPatternNoFill'miPatternCross
End With'修改要素的符号样式。
Set GetRectFeature=rcEagleLocate
Set pts=Nothing
Set Pt=Nothing
Set rcEagleLocate=Nothing'显式释放内存空间。
End Function
当用户在缩略图中使用鼠标画出一个矩形框后，根据矩形框的位置调整主图的显示范围。其处理是在mpOverview的MapX的标准事件ToolUsed中进行的，首先根据事件传递过来的两个坐标点创建一个矩形框，然后将主图mpMain的显示范围设置为该矩形范围。其中使用的工具DRAGRECTANGLE为自定义工具。具体实现如下。
Private Sub mpOverview_ToolUsed(ByVal ToolNum As Integer，_
ByVal X1 As Double，ByVal Y1 As Double，_
ByVal X2 As Double，ByVal Y2 As Double，_
ByVal Distance As Double，_
ByVal Shift As Boolean，ByVal Ctrl As Boolean，_
EnableDefault As Boolean)
If(ToolNum=DRAGRECTANGLE)Then
Dim rcDrag As New MapXLib．Rectangle
rcDrag．Set X1，Y1，X2，Y2
Set mpMain．Bounds=rcDrag
Set rcDrag=Nothing
End If
End Sub
自定义工具DRAGRECTANGLE是miToolTypeMarquee类型的工具，它可以在MapX控件上画出一个虚线的矩形，该工具是在系统初始化中创建的，部分的相关代码如下。
Private Sub Form_Load()'
mpOverview．CreateCustomTool DRAGRECTANGLE，_
miToolTypeMarquee，miCrossCursor
mpOverview．CurrentTool=DRAGRECTANGLE
End Sub
前面的设计实现了由缩略图到主图的交互。另一方面，当主图的视图发生变化时，缩略图也要进行相应的调整，也即更新指示主图显示范围的矩形框。当主图显示范围大于或者等于实际地理范围时，缩略图中指示矩形框达到最大值，也即与当前数据集的图幅等大。
Private Sub mpMain_MapViewChanged()
If(mpMain．Geoset＜＞"")Then
Dim aRetFtre As MapXLib．Feature
Call EvwhtMap．Add(mpMain．Zoom，mpMain．CenterX，mpMain．CenterY)
If Not(mpMain．Bounds．Width＞mpMain．Layers．Bounds．Width Or_
mpMain．Bounds．Height＞mpMain．Layers．Bounds．Height)Then
'如果主图的显示范围小于实际的地理范围，进行如下处理。
mpOverview．Layers．Item("Locate Rectangle")．DeleteFeature_
mpOverview．Tag
'删除当前缩略图上的矩形框，mpOverview．Tag为其关键字。
With mpMain．Bounds
Set aRetFtre=GetRectFeature(．xMin，．yMin，．xMax，_
．yMax，mpOverview)
'根据主图当前的显示范围生成矩形面状要素。
Set aRetFtre=mpOverview．Layers．Item_
("Locate Rectangle")．AddFeature(aRetFtre)
'将要素添加到临时图层中。
End With
mpOverview．Tag=aRetFtre．FeatureKey
Else
'如果主图的显示范围大于或者等于实际的地理范围，进行如下处理。
Set aRetFtre=mpOverview．Layers．Item("Locate Rectangle")_
．GetFeatureByKey(mpOverview．Tag)
If(aRetFtre．Bounds．Width＜mpOverview．Layers．Bounds．Width Or_
aRetFtre．Bounds．Height＜mpOverview．Layers．Bounds．Height)Then
mpOverview．Layers．Item("Locate Rectangle")．DeleteFeature_
mpOverview．Tag
With mpOverview．Layers．Bounds
Set aRetFtre=GetRectFeature(．xMin，．yMin，_
．xMax，．yMax，mpOverview)
Set aRetFtre=mpOverview．Layers．Item_
("Locate Rectangle")．AddFeature(aRetFtre)
With
mpOverview．Tag=aRetFtre．FeatureKey
End If
End If
End If
End Sub
用户已经查看过的历史视图是通过自定义的类BViewHist来管理的。类的实现代码以及对应的说明如下:
Option Explicit
'自定义事件，当用户调用方法LastView、NextView，请求改变视图的参数时激发该事件，
'参数含义依次为所请求上一视图或者下一视图的显示比例尺、中心点的横坐标、中心点的纵坐标。
Public Event PopupViewFrame(fScale As Double，fX As Double，fY As Double)
'自定义结构，每一帧视图对应一个ViewParam，其成员分别记录该视图的
'显示比例尺、中心点的横坐标、中心点的纵坐标。
Private Type ViewParam
dScale As Double
dX As Double
dY As Double
End Type'
类属性
Dim sMapNm As String
Dim ViewPath()As ViewParam
Dim nViewFrm As Long，nCurrView As Long'
类初始化，初始化变量
Private Sub Class_Initialize()
nViewFrm=－1
nCurrView=－1
sMapNm=""
Erase ViewPath
End Sub
'类的结束处理
Private Sub Class_Terminate()
Erase ViewPath
'释放动态数组内存
End Sub
'获取对应的数据集名称
Public Property Get MapName()As String
MapName=sMapNm
End Property
'记录对应的数据集名称，如果与当前的数据集不同，则重新开始记录。
'留待后续系统扩展用，可以将数据集名称作为视图帧的属性，同时修改系统其他部分，
'以能返回到已经关闭的数据集。
Public Property Let MapName(fMapNm As String)
If(sMapNm＜＞fMapNm)Then
nCurrView=－1
nViewFrm=－1
Erase ViewPath
End If
sMapNm=fMapNm
End Property
'获取当前记录的视图帧的数目。
Public Property Get ViewFrame()As Long
ViewFrame=nViewFrm
End Property
'使用该方法请求上一帧视图的参数，激发自定义事件传递给外部处理。
Public Function LastView()As Boolean
If(sMapNm="")Then Exit Function
If(nCurrView＞=0)Then
LastView=nCurrView＜＞0
'如果已经是第一帧，则返回False，并且不激发事件。
If(LastView)Then
nCurrView=nCurrView－1
RaiseEvent PopupViewFrame(ViewPath(nCurrView)．dScale，_
ViewPath(nCurrView)．dX，ViewPath(nCurrView)．dY)
End If
End If
End Function
'使用该方法请求下一帧视图的参数，激发自定义事件传递给外部处理。
Public Function NextView()As Boolean
If(sMapNm="")Then Exit Function
If(nCurrView＜nViewFrm)Then
NextView=nCurrView＜＞nViewFrm
'如果已经是最后一帧，则返回False，并且不激发事件。
If(NextView)Then
nCurrView=nCurrView+1
RaiseEvent PopupViewFrame(ViewPath(nCurrView)．dScale，_
ViewPath(nCurrView)．dX，ViewPath(nCurrView)．dY)
End If
End If
End Function
'追加一帧视图，记录三个参数。
Public Sub Add(fScale As Double，fX As Double，fY As Double)
If(nCurrView＞=0)Then
'对于连续两帧视图，判断其比例尺、中心点是否相同。
'若是，则不添加新帧
If(CSng(ViewPath(nCurrView)．dScale)=CSng(fScale)And_
CSng(ViewPath(nCurrView)．dX)=CSng(fX)And_
CSng(ViewPath(nCurrView)．dY)=CSng(fY))Then
Exit Sub
End If
End If
nCurrView=nCurrView+1
ReDim Preserve ViewPath(nCurrView)
ViewPath(nCurrView)．dScale=fScale
ViewPath(nCurrView)．dX=fX
ViewPath(nCurrView)．dY=fY
nViewFrm=nCurrView
End Sub
有了这个类的定义后，创建一个实例，在合适的地方使用方法Add记录视图的变化，然后在需要时就可以通过调用两个方法LastView、NextView激发事件PopupViewFrame，即可向外部传递对应的视图帧的参数信息。
在系统主模块frmMain中声明事件变量:
Dim WithEvents EvwhtMap As BViewHist
然后在模块初始化中创建:
Private Sub Form_Load()
Set EvwhtMap=New BViewHist
End Sub
在打开地图数据集时，记录对应的数据集名称以及第一次调入时视图的状态参数:
Private Sub OpenAMap(fstrMapNm As String)
EvwhtMap．MapName=mpMain．Geoset
gstrUnitName=GetUnitName(mpMain．MapUnit)
Call EvwhtMap．Add(mpMain．Zoom，mpMain．CenterX，mpMain．CenterY)
End Sub
在主图的视图变化事件中记录变化后视图状态参数:
Private Sub mpMain_MapViewChanged()
Call EvwhtMap．Add(mpMain．Zoom，mpMain．CenterX，mpMain．CenterY)
End Sub
在与用户交互的地方调用上下视图方法:
Private Sub mnuViewHist_Click(Index As Integer)
If(Index=1)Then'last frame view
EvwhtMap．LastView
ElseIf(Index=2)Then
EvwhtMap．NextView
End If
End Sub
如果上下视图存在，则上面的函数会激发类BViewHist的事件:
Private Sub EvwhtMap_PopupViewFrame(fScale As Double，fX As Double，_ fY As Double)
mpMain．ZoomTo fScale，fX，fY
'调整主图的视图参数，等同于以下注释代码:
'mpMain．AutoRedraw=False
'mpMain．Zoom=fScale
'mpMain．CenterX=fX
'mpMain．CenterY=fY
'mpMain．AutoRedraw=True
End Sub
HypMap还提供了显示全图和显示选择两种功能。前者使用菜单mnuViewAll与用户交互。
Private Sub mnuViewAll_Click()
Set mpMain．Bounds=mpMain．Layers．Bounds
End Sub
后者使用mnuViewSelect与用户交互。
Private Sub mnuViewSelect_Click()
Dim rcSelectAs MapXLib．Rectangle
Dim aLayerAs MapXLib．Layer
Dim ftresSelAs MapXLib．Features
For Each aLayer In mpMain．Layers
Set ftresSel=aLayer．Selection．Clone
If ftresSel．Count＞0 Then
If(rcSelect Is Nothing)Then
Set rcSelect=ftresSel．Bounds
Else
If(rcSelect．xMin＞ftresSel．Bounds．xMin)Then
rcSelect．xMin=ftresSel．Bounds．xMin
End If
If(rcSelect．yMin＞ftresSel．Bounds．yMin)Then
rcSelect．yMin=ftresSel．Bounds．yMin
End If
If(rcSelect．xMax＜ftresSel．Bounds．xMax)Then
rcSelect．xMax=ftresSel．Bounds．xMax
End If
If(rcSelect．yMax＜ftresSel．Bounds．yMax)Then
rcSelect．yMax=ftresSel．Bounds．yMax
End If
End If
End If
Next
If Not rcSelect Is Nothing Then Set mpMain．Bounds=rcSelect
Set rcSelect=Nothing
Set ftresSel=Nothing
End Sub
5．量算功能
利用MapX控件进行地图的量测和量算是非常方便的。MapX已经提供了直线段的长度量测功能，也即其标准事件ToolUsed中的参数Distance。
Private Sub mpMain_ToolUsed(ByVal ToolNum As Integer，_
ByVal X1 As Double，ByVal Y1 As Double，ByVal X2 As Double，_
ByVal Y2 As Double，ByVal Distance As Double，_
ByVal Shift As Boolean，ByVal Ctrl As Boolean，EnableDefault As Boolean)
Debug．Print"The distance is:"＆CStr(Distance)
End Sub
由于实际应用中，直线段的量测用途有限，而且直线段是折线的特例，因此HypMap中提供了折线的长度量测和多边形的面积量算功能。首先将当前鼠标工具设置为量测状态，通过菜单实现，代码如下。
Private Sub mnuMeasDime_Click(Index As Integer)
If Not(m_CurrMouseMenu Is Nothing)Then
m_CurrMouseMenu．Checked=False
End If
If Not(m_CurrBtn Is Nothing)Then m_CurrBtn．Value=tbrUnpressed
If(Index=1)Then
mpMain．CurrentTool=POLYLINERULERID
ElseIf(Index=2)Then
mpMain．CurrentTool=REGIONAREAID
End If
Set m_CurrMouseMenu=mnuMeasDime(Index)
m_CurrMouseMenu．Checked=True
End Sub
自定义工具POLYLINERULERID是miToolTypePoly类型的，工具REGIONAREAID是mi-ToolTypePolygon类型的，其定义见后文。使用鼠标在mpMain控件上画出折线或者多边形过程中，会激发MapX的标准事件PolyToolUsed，该事件第一个参数指示使用的工具代码;第二个参数表示当前操作状态，为miPolyToolBegin表示鼠标在控件上点了第一个点，miPolyToolEnd表示鼠标双击MapX控件结束了操作，miPolyToolEndEscaped表示用户使用了键盘上的Esc键取消了操作或者使用BACKSPACE键删除的上一点是最后一点，miPolyToolInProgress表示其他状态;第三个参数是当前鼠标已经点击的点坐标数组，第四个和第五个参数指示键盘上Shift和Ctrl键的状态;最后一个是在使用MapX内置工具时确定是否执行其缺省的操作。我们在这个事件中根据前三个参数标示的状态来显示结果，其代码以及说明如下。
Private Sub mpMain_PolyToolUsed(ByVal ToolNum As Integer，_
ByVal Flags As Long，ByVal Points As Object，ByVal bShift As Boolean，_
ByVal bCtrl As Boolean，EnableDefault As Boolean)
Dim aPolygon As New MapXLib．Feature
Dim aTmpLyer As MapXLib．Layer
Dim iPt As Integer，sngSumDis As Double
Dim sx As Single，sy As Single
ptMeasureX=Points．Item(Points．Count)．x
ptMeasureY=Points．Item(Points．Count)．y
'ptMeasureX、ptMeasureY为模块变量，取最新一点坐标。
mpMain．ConvertCoord sx，sy，ptMeasureX，ptMeasureY，miMapToScreen
'将坐标转换为屏幕坐标。
If(Flags=miPolyToolBegin)Then
stBar．Panels("measure")．Text=""
'使用第一点定位显示结果的位置。
ctlMeasure．Move sx*Screen．TwipsPerPixelX，_
sy*Screen．TwipsPerPixelY
ctlMeasure．Tag=0
ElseIf(Flags＜＞miPolyToolBegin And_
Flags＜＞miPolyToolInProgress)Then
'如果结束则刷新屏幕显示。
mpMain．Refresh
ctlMeasure．Visible=False
End If
If(ToolNum=REGIONAREAID)Then
'量算多边形面积的工具，只在点数大于2的时候才计算。
If(Points．Count＞2 And Flags=miPolyToolInProgress)Then
ctlMeasure．Visible=True
Set aPolygon=New Feature
aPolygon．Attach mpMain
aPolygon．Type=miFeatureTypeRegion
aPolygon．Parts．Add Points
sx=aPolygon．Area
ctlMeasure．Tag=sx
ctlMeasure．Width=8*ctlMeasure．Font．Size*_
LenB(ctlMeasure．Tag＆gstrUnitName)
ctlMeasure．Text=sx＆gstrUnitName＆"^2"
stBar．Panels("measure")．Text=sx＆""＆gstrUnitName＆"^2" Else
ctlMeasure．Text=0
End If
ElseIf(ToolNum=POLYLINERULERID)Then
sngSumDis=0
If Points．Count＞1 And Flags=miPolyToolInProgress Then
'累计各段直线的长度即为折线长。
For iPt=2 To Points．Count
sngSumDis=sngSumDis+mpMain．Distance(_
Points．Item(iPt－1)．x，Points．Item(iPt－1)．y，_
Points．Item(iPt)．x，Points．Item(iPt)．y)
Next
ctlMeasure．Tag=sngSumDis
ctlMeasure．Width=8*ctlMeasure．FontSize*_
LenB(ctlMeasure．Tag＆gstrUnitName)
ctlMeasure．Text=sngSumDis＆gstrUnitName
ctlMeasure．Visible=True
stBar．Panels("measure")．Text=sngSumDis＆""＆_
gstrUnitName
End If
End If
End Sub
6.空间查询与分析
以下代码给出了“图元属性数据提取工具”InfoTool的实现。当用户使用该工具选择一个图元时，系统就显示该图元所有的属性数据。
首先定义属性数据提取工具标号。
Public Const InfoTool=120
在Form_Load事件中生成InfoTool。
Private Sub Form_Load()
MpMain．CreateCustomTool InfoTool，miToolTypePoint，miCrossCursor
End Sub
然后，在ToolUsed事件中获取选中的图元，查询属性数据并显示。图元属性数据的读取可通过图层的KeyField属性和图元的KeyValue属性来获得。
Private Sub mpMain_ToolUsed(ByVal ToolNum As Integer，_
ByVal Flags As Long，ByVal Points As Object，ByVal bShift As Boolean，_
ByVal bCtrl As Boolean，EnableDefault As Boolean)
…
Dim pnt As New Point
Dim pnts As New MapXLib．Points
Dim ftrs As Features
Dim ftr As Feature
Dim lyr As Layer
Dim strInfo As String
Dim flds As MapXLib．Fields
Dim fld As MapXLib．Field
Dim ds As MapXLib．Dataset
Select Case ToolNum
…
Case InfoTool
pnt．Set X1，Y1
For Each lyr In mpMain．Layers
Set ftrs=lyr．SearchAtPoint(pnt)
If ftrs．Count＞0 Then
strInfo="Layer name:"＆lyr．Name＆vbCrLf
strInfo=strInfo＆"Feature Name:"＆ftrs．Item(1)．Name＆vb_
CrLf
Set ds=mpMain．Datasets．Add(miDataSetLayer，lyr)
For Each fld In ds．Fields
strInfo=strInfo＆fld．Name＆":"
Set lyr．KeyField=fld
strInfo=strInfo＆ftrs．Item(1)．KeyValue＆vbCrLf
Next
MsgBox strInfo
Exit For
End If
Next
If ftrs．Count=0 Then
MsgBox'没有图元被选中
End If
End Select
End Sub
根据属性查询图元。MapX提供的Layer．Search方法允许用户进行单项和符合条件查询。利用它可以实现属性数据到空间数据的查询。
以下代码在图层“行政区域”中查询出区名为“RegionName”的图元，并将查询的结果在地
图上高亮显示。
Dim lyr As MapXLib．Layer
Dim ftrs As MapXLib．Features
Set lyr=mpMain．Layers("行政区域")
mpMain．Datasets．Add miDataSetLayer lyr
Set ftrs=lyr．Search("Region="RegionName"")
lyr．Selection．Replace ftrs
查询的结果作为图元可以用上面介绍的高亮方式表示出来，也可以利用定时器让这些图元进行闪烁，以便查看。所谓闪烁可以将查询的结果图元利用图层的Selection属性，分别反复地放入选择集合和清除出选择集合来实现。
下面代码是定位查询对象的函数，在这里设置定时器的开关为开始:
Private Function LocateQueryResult()
intBlinkCount=0
tmrFeatureBlink．Enabled=True'打开定时开关，开始闪烁
Exit Function
End Function
下面是定时器的事件，在这里设置闪烁方式，并根据闪烁的次数来停止闪烁:
'设置被查询定位的第五次闪烁
Private Sub tmrFeatureBlink_Timer()
Dim ftr As New Feature
Dim ftrs As Features
'设置闪烁的次数为5次
If intBlindCoun＜5 Then
'第一次闪烁，将目标放入Selection集合，还要完成查询结果目标的地图定位
If intBlinkCount=0 Then
mpMain．Layers．Item(strLocateLayerName)．KeyField=g_cntIDFieldName
Set ftrs=mpMain．Layers．Item(strLocateLayerName)．AllFeatures
For Each ftr In ftrs
If ftr．KeyValue=lngRecordSetID Then
mpMain．Layers．Item(strLocateLayerName)．Selection．ClearSelection
mpMain．Layers．Item(strLocateLayerName)．Selection．Add ftr
If bInLocate=True Then
mpMain．ZoomTo mpMain．Zoom，ftr．CenterX，ftr．CenterY
End If
Exit For
End If
Next ftr
Else
'在第2、第4次定时事件触发时，将目标放入Selection中
If intBlinkCount=2 Or intBlinkCount=4 Then
Map．Layers．Item(strLocateLayerName)．KeyField=g_cntIDFieldName
Set ftrs=Map．Layers．Item(strLocateLayerName)．AllFeatures
'针对选中的每一个图元进行闪烁
For Each ftr In ftrs
If ftr．KeyValue=lngRecordSetID Then
mpMain．Layers．Item(strLocateLayerName)．Selection．ClearSelection
mpMain．Layers．Item(strLocateLayerName)．Selection．Add ftr
Exit For
End If
Next ftr
Else
'在第1、3、5次定时事件触发时，将目标清楚Selection
Map．Layers．Item(strLocateLayerName)．Selection．ClearSelection
End If
End If
'计算闪烁的次数
intBlinkCount=intBlinkCount+1
Else
'闪烁的次数够了，停止计时和闪烁
intBlinkCount=0
tmrFeatureBlink．Enabled=False
End If
Exit Sub
End Sub
7.地图输出(打印)
MapX中提供了PrintMap方法实现地图的打印。但打印地图的范围是整个MapX控件窗口显示部分的内容，要将打印输出的地图按照比例尺打印，也就是在打印的地图上可以进行测量(例如图中1厘米对应实际的1公里)，这就是要进行地图打印比例尺的设置。
首先声明打印区域选择工具标号。
Public Const PrintMapTool=119
在窗体加载过程中生成打印区域选择工具:
Private Sub Form_Load()
…
'生成打印区域选择工具
mpMain．CreateCustomTool PrintMapTool，miToolTypeMarquee，miCrossCursor
End Sub
在ToolUsed事件中调用地图打印过程:
Private Sub mpMain_ToolUsed(ByVal ToolNum As Integer，_
ByVal Flags As Long，ByVal Points As Object，ByVal bShift As Boolean，_
ByVal bCtrl As Boolean，EnableDefault As Boolean)
Select Case ToolNum
…
Case PrintMapTool
PrintScaledMap X1，Y1，X2，Y2
End Select
End Sub
按比例打印指定的地图区域
Private Sub PrintScaledMap(ByVal X1 As Double，ByVal Y1 As Double，ByVal X2 As_
Double，ByVal Y2 As Double)
Dim sngXMin As Single
Dim sngYMin As Single
Dim sngXMax As Single
Dim sngYMax As Single
Dim sngWidth As Single
Dim sngHeight As Single
Dim newRect As New Rectangle
Dim oldRect As Rectangle
Dim dblZoom As Double
Dim dblScale As Double
Dim dblNewScale As Double
Dim sstrNewScale As String
Dim dblDistance As Double
'设置地图单位
mpMain．PaperUnit=miPaperUnitMillimeter
ScaleMode=vbMillimeters
'保存地图原有的边界
Set oldRect=mpMain．Bounds
'将地理坐标转化为屏幕坐标
mpMain．ConvertCoord sngXMin，sngYMin，X1，Y1，miMapToScreen
mpMain．ConvertCoord sngXMax，sngXMax，sngYMas，X2，Y2，miMapToScreen
sngWidth=Abs(sngXMax–sngXMin)
sngHeight=Abs(sngYMax–sngYMin)
'计算当前屏幕显示比例尺
mpMain．MapUnit=miUnitMillimeter
dblDistance=mpMain．Distance(X1，Y1，X2，Y2)
dblScale=dblDistance/sngWidth
'获取打印比例尺
strNewScale=InputBox("请设置打印比例尺1∶X"，"打印比例尺"，CStr(dblScale))
dblZoom=dblScale/CDbl(strNewScale)
'改变地图显示范围为指定打印区域
mpMain．Width=Me．ScaleX(sngWidth，vbPixels，vbMillimeters)
mpMain．Height=Me．ScaleY(sngHeight，vbPixels，vbMillimeters)
newRect．Set X1，Y1，X2，Y2
Set mpMain．Bounds=newRect
'显示打印机设置对话框
With CmnDlg
．CanceError=True
．Flags=cdlPDPrintSetup
．PrinterDefault=True
．ShowPrinter
End With
'打印地图
Printer．CurrentX=0
Printer．CurrentY=0
Printer．Print""
MpMain．PrintMap Printer．hdc，0，0，mpMain．Width*100*dblZoom，_
MpMain．Height*100*dblZoom
Printer．NewPage
Printer．EndDoc
'恢复地图显示
mpMain．Width=Me．ScaleWidth
mpMain．Height=Me．ScaleHeight
Set mpMain．Bounds=oldRect
Exit Sub
End Sub
通过以上步骤可以实现地图的按比例打印。其中，可以由用户指定地图打印的比例尺，例如1∶1 000 000等。
8.其他辅助功能函数
前面已经叙述了HypMap的重要功能模块，在此之外，还用到了大量的支持代码，例如一些常量的定义，常用函数的定义与实现以及界面元素的协调等。
HypMap的系统启动是定义在模块文件中主函数Main()，下面是该模块的内容和说明。
Option Explicit
'modFunc．bas
Public Declare Function mciSendString Lib"winmm．dll"Alias_
"mciSendStringA"(ByVal lpstrCommand As String，_
ByVal lpstrReturnString As String，_
ByVal uReturnLength As Long，ByVal hwndCallback As Long)As Long
Public Const MAX_PATH As Integer=260
Public Const DATABASE_DRIVER As String=_
"PROVIDER=Microsoft．Jet．OLEDB．4．0;Data Source="
Public Const DELIMITER As String="|"'
系统主函数。
Public Sub Main()
Load frmMain'加载主模块。
frmMain．Show
End Sub
'系统通用的错误输出处理函数，如果fbClearErr为真，则清除错误状况，
'如果参数fstrMsg非空，则以它为提示信息。
'不处理标准文件对话框“取消”按钮产生的错误(代码为32755)。
Public Function DefErrorOut(fbClearErr As Boolean，_
Optional fstrMsg As String)As Boolean
If(Err．Number=0 Or Err．Number=32755)Then
DefErrorOut=True
Else
DefErrorOut=False
If(fstrMsg＜＞"")Then'(Not IsMissing(fstrMsg))Then
MsgBox fstrMsg＆vbCrLf，vbInformation
Else
Dim strM As String
strM="不适当的操作，描述为:"
strM=strM＆Err．Number＆vbCrLf＆Err．Description
strM=strM＆vbCrLf
MsgBox strM，vbInformation
End If
If(fbClearErr)Then Err．Clear
Err．Clear
End If
End Function
'判断参数fstrFileName指示的文件是否存在，是则返回真值，否则为假。
Public Function IsFileExist(fstrFileName As String)As Boolean
On Error GoTo errGetOut
Dim hFile As Integer
If(fstrFileName="")Then
IsFileExist=False
Exit Function
Else
hFile=FreeFile()
Open fstrFileName For Input Access Read As#hFile
Close#hFile
End If
errGetOut:
IsFileExist=DefErrorOut(True)'，"IsFileExist"＆fstrFileName)
End Function
'获取一个文件名，参数Index为对话框出现时后缀，若fbSave为真则
'显示"保存"对话框，否则显示"打开"对话框
Public Function GetFileName(Index As Integer，_
Optional fbSave As Boolean=False)As String
On Error GoTo errCancel
Dim strTitle As String，strfilter As String
strTitle="指定目标文件"
If(Index=0)Then
strfilter="地图文件|*．gst|*．*|*．*"
ElseIf(Index＜5)Then
strfilter="文字文件|*．txt;*．rtf|图片文件|*．bmp;*．jpg;*．gif|" strfilter=strfilter＆"视频文件|*．avi|声音文件|*．wav;*．mid"
End If
With frmMain．cmnDialog
．Filter=strfilter
．FilterIndex=Index
．DialogTitle=strTitle
．FileName=""
If(fbSave)Then
．Flags=．Flags Or cdlOFNOverwritePrompt
．ShowSave
Else
．Flags=．Flags Or cdlOFNFileMustExist
．ShowOpen
End If
GetFileName=．FileName
End With
errCancel:
DefErrorOut False
End Function
'分解文件名为路径、标题、后缀。参数fFName为待分解的文件名。
Public Function GetFilePathAttr(fFName As String，Optional fstrPath As String，_
Optional fstrFName As String，Optional fstrExt As String)As Boolean
On Error GoTo lblGetFilePathAttr
fstrExt=RightLimitter$(fFName，"．")
fstrFName=RightLimitter$(fFName，"\")
fstrPath=Left$(fFName，Len(fFName)－Len(fstrFName))
fstrFName=Left$(fstrFName，Len(fstrFName)－Len(fstrExt)－1)
'GetFilePathAttr=fstrExt＆vbCrLf＆fstrFName＆vbCrLf＆fstrPath
lblGetFilePathAttr:
GetFilePathAttr=DefErrorOut(True)
End Function
'取字符串fstrSrc中fchrLim右边的部分。
Public Function RightLimitter(fstrSrc As String，fchrLim As String)As String
Dim iLoop As Integer，nstrLen As Integer
nstrLen=Len(fstrSrc)
For iLoop=nstrLen To 1 Step－1
If(Mid(fstrSrc，iLoop，1)=fchrLim)Then Exit For
Next iLoop
If(iLoop＞0)Then RightLimitter=Right$(fstrSrc，nstrLen－iLoop)
End Function
'取字符串fstrSrc中fchrLim左边的部分。
Public Function LeftLimitter(fstrSrc As String，fchrLim As String)As String
Dim iLoop As Integer，nstrLen As Integer
nstrLen=Len(fstrSrc)
For iLoop=1 To nstrLen
If(Mid(fstrSrc，iLoop，1)=fchrLim)Then Exit For
Next iLoop
If(iLoop＞0)Then LeftLimitter=Left$(fstrSrc，iLoop－1)
End Function
'根据MapX的地图量度单位代码确定其对应含义的字符串名。
Public Function GetUnitName(fInnerUnit As MapUnitConstants)As String
GetUnitName=Choose(fInnerUnit+1，"英里"，"公里"，"英寸"，_
"英尺"，"码"，"厘米"，"分米"，"米"，"测量英尺"，"海里"，_
"缇"，"点"，"字"，"度"，"令"，"链"，"杆")
End Function
'MapX控件的地图文件中图层lyr是否为非临时图层。
Public Function IsLayerPermanent(lyr As Layer)As Boolean
If(LCase$(Right$(lyr．Filespec，3))="tab")Then
IsLayerPermanent=True
ElseIf(LCase$(Right$(lyr．Filespec，3))="tmp")Then
IsLayerPermanent=False
End If
End Function
另外，在主窗体模块frmMain中有部分界面元素协调等功能的代码，具体实现以及相关说明如下:
'frmMain．frm
'Option Explicit
Private Const MAINMAP_WIDTH As Integer=5300
Private Const CLOSE_WIDTH As Integer=70
Private Const DRAGRECTANGLE As Integer=101
Private Const POLYLINERULERID As Integer=103
Private Const REGIONAREAID As Integer=104
Dim WithEvents EvwhtMap As BViewHist
Dim WithEvents EinfoGet As frmInf
Dim gbDocDirty As Boolean
Dim gstrUnitName As String
Dim m_CurrMouseMenu As Menu，m_CurrBtn As Button
Dim ptMeasureX As Double，ptMeasureY As Double
Dim ProjInf As BDBInf
'启动主窗体。
Private Sub Form_Load()
Call mnuInfoManipu_Click(1)
Set EvwhtMap=New BViewHist
Set EinfoGet=New=frmInf
gbDocDirty=False
mpMain．CreateCustomTool POLYLINERULERID，miToolTypePoly，_
miCrossCursor
mpMain．CreateCustomTool REGIONAREAID，miToolTypePolygon，_
miCrossCursor
mpOverview．CreateCustomTool DRAGRECTANGLE，_
miToolTypeMarquee，miCrossCursor
mpOverview．CurrentTool=DRAGRECTANGLE
End Sub
'窗体调整大小时的处理。
Private Sub Form_Resize()
If(Me．WindowState＜＞FormWindowStateConstants．vbMinimized)Then
Dim nHeight As Integer
With picSeparator
．Top=Me．ScaleTop+Me．tlbMain．Height
nHeight=Me．ScaleHeight－stBar．Height－tlbMain．Height
．Height=IIf(nHeight＜0，0，nHeight)
If(．Tag="")Then
．Left=Me．ScaleWidth*5/6
．Tag="00"
End If
If(．Left＞Me．ScaleWidth)Then
Me．mnuViewTree．Checked=False
End If
．Width=50
．BorderStyle=0'none fixed border
End With
Call InitInterface
End If
End Sub
'窗体卸载时，清理内存变量。
Private Sub Form_Unload(Cancel As Integer)
mnuExit_Click
Set frmMain=Nothing
Set EvwhtMap=Nothing
Set EinfoGet=Nothing
End
End Sub
Private Sub mnuExit_Click()
Dim aFrm As Form
mnuMapSave_Click
For Each aFrm In Forms
Unload aFrm
Next
End Sub
Private Sub mnuHelpAbout_Click()
MsgBox App．LegalCopyright，vbInformation
End Sub
'缩放漫游地图显示的鼠标状态。
Private Sub mnuViewChange_Click(Index As Integer)
If Not(m_CurrMouseMenu Is Nothing)Then
m_CurrMouseMenu．Checked=False
End If
If Not(m_CurrBtn Is Nothing)Then m_CurrBtn．Value=tbrUnpressed
Select Case Index
Case 1
mpMain．CurrentTool=miZoomInTool
Set m_CurrBtn=tlbMain．Buttons("zoomin")
Case 2
mpMain．CurrentTool=miZoomOutTool
Set m_CurrBtn=tlbMain．Buttons("zoomout")
Case 3
mpMain．CurrentTool=miPanTool
Set m_CurrBtn=tlbMain．Buttons("pan")
End Select
Set m_CurrMouseMenu=mnuViewChange(Index)
m_CurrMouseMenu．Checked=True
End Sub
Private Sub mpOverview_KeyDown(KeyCode As Integer，Shift As Integer)
If(KeyCode=vbKeyDelete)Then
mpOverview．Layers．ClearSelection
End If
End Sub
'用于表示当前图层列表的树视图控件的节点选项控制。
Private Sub trvLayer_NodeCheck(ByVal Node As MSComctlLib．Node)
Dim aNde As Node
If(Node．Key＜＞mpMain．Geoset)Then
mpMain．Layers．Item(Node．Text)．Visible=Node．Checked
Else'checking the root will affect all its children
For Each aNde In trvLayer．Nodes
If(aNde．Key＜＞mpMain．Geoset)Then
aNde．Checked=trvLayer．Nodes(mpMain．Geoset)．Checked
trvLayer_NodeCheck aNde
End If
Next
End If
End Sub
'关闭树视图显示。
Private Sub mnuViewTree_Click()
mnuViewTree．Checked=Not mnuViewTree．Checked
If(mnuViewTree．Checked)Then picSeparator．Left=Me．ScaleWidth*5/6
Call Me．InitInterface
End Sub
'容器大小变化时，调整地图控件。
Private Sub picFrame_Resize()
With Me．mpMain
．Left=Me．picFrame．ScaleLeft
．Top=Me．picFrame．ScaleTop
．Width=Me．picFrame．ScaleWidth
．Height=Me．picFrame．ScaleHeight
End With
End Sub
'调整树视图大小时的相关处理。
Private Sub picSeparator_MouseDown(Button As Integer，Shift As Integer，_
x As Single，y As Single)
Dim sTag As String
If(Button=vbLeftButton)Then
picSeparator．ZOrder 0
sTag=picSeparator．Tag
Mid(sTag，1，1)="1"
picSeparator．Tag=sTag
End If
End Sub
Private Sub picSeparator_MouseMove(Button As Integer，Shift As Integer，_
x As Single，y As Single)
Dim sTag As String
sTag=picSeparator．Tag
If(Button=MouseButtonConstants．vbLeftButton)And_
(Mid$(sTag，1，1)="1")Then
If(Mid$(sTag，2，1)="0")Then
Mid$(sTag，2，1)="0"
picSeparator．Tag=sTag
End If
piSeparator．Lefi=picSeparator．Left+x－1
End if
End Sub
Private Sub picSeparator_MouseUp(Button As Integer，Shift As Integer，_
x As Single，y As Single)
If(Button=vbLeftButton)Then
picSeparator．Tag="00"'picSeparator．BackColor=＆H8000000F'SystemColorConstants．vbMenuBar
Dim nMinWid As Integer
nMinWid=Me．ScaleWidth/2
Me．mnuViewTree．Checked=True
If(picSeparator．Left＞Me．ScaleWidth－CLOSE_WIDTH*4)Then
Me．mnuViewTree．Checked=False
ElseIf(picSeparator．Left＜nMinWid)Then picSeparator．Left=nMinWid
End If
Call InitInterface
End If
End Sub
'用户在工具栏上选择功能项时设置相应的状态。
Private Sub tlbMain_ButtonClick(ByVal Button As MSComctlLib．Button)
Select Case Button．Key
Case"new"
mnuMapNew_Click
Case"open"
mnuMapOpen_Click
Case"zoomin"
Call mnuViewChange_Click(1)
Case"zoomout"
Call mnuViewChange_Click(2)
Case"pan"
Call mnuViewChange_Click(3)
Case"ptselect"
If(tlbMain．Buttons("modify")．Value=tbrPressed)Then
Call mnuInfoManipu_Click(2)
Else
Call mnuInfoManipu_Click(1)
End If
Case"modify"
If(Button．Value=tbrPressed)Then
Call mnuInfoManipu_Click(2)
ElseIf(Button．Value=tbrUnpressed And_
tlbMain．Buttons("ptselect")．Value=tbrPressed)Then
Call mnuInfoManipu_Click(1)
End If
Case"zoomback"
mnuViewHist_Click 1
Case"zoomforward"
mnuViewHist_Click 2
Case"layer"
mnuMapAlter_Click
Case Else
DefErrorOut True，"Undefined Buttons!"
End Select
End Sub
'界面元素变化时，调整相关控件大小以及位置。
Public Sub InitInterface()
On Error Resume Next
If(Me．mnuViewTree．Checked=False)Then
picSeparator．Left=Me．ScaleWidth－picSeparator．Width
Me．tbsLayer．Left=Me．ScaleWidth
Me．framLayer．Left=Me．ScaleWidth
Me．framOver．Left=Me．ScaleWidth
Else
With Me．tbsLayer
．Visible=True
．Left=Me．picSeparator．Left
．Width=Me．ScaleWidth－picSeparator．Left
．Top=picSeparator．Top
．Height=picSeparator．Height
Me．framLayer．Top=．Top
Me．framLayer．Height=．ClientHeight/2
Me．framLayer．Left=．Left+picSeparator．Width
Me．framLayer．Width=．ClientWidth－picSeparator．Width
Me．trvLayer．Left=CLOSE_WIDTH
Me．trvLayer．Top=CLOSE_WIDTH*2
Me．trvLayer．Width=Me．framLayer．Width－CLOSE_WIDTH*2
Me．trvLayer．Height=Me．framLayer．Height－CLOSE_WIDTH*3
trvInf．Left=trvLayer．Left
trvInf．Top=trvLayer．Top
trvInf．Height=trvLayer．Height
trvInf．Width=trvLayer．Width
Me．framOver．Top=framLayer．Height+framLayer．Top
Me．framOver．Height=．ClientHeight/2
Me．framOver．Left=framLayer．Left
Me．framOver．Width=framLayer．Width
Me．mpOverview．Left=CLOSE_WIDTH
Me．mpOverview．Top=CLOSE_WIDTH*2
Me．mpOverview．Width=Me．framOver．Width－CLOSE_WIDTH*2
Me．mpOverview．Height=Me．framOver．Height－_
CLOSE_WIDTH*3
End With
End If
With Me．picFrame
．Left=Me．ScaleLeft
．Top=picSeparator．Top
．Width=Me．picSeparator．Left'Me．ScaleWidth－Me．tbsLayer．Width
．Height=picSeparator．Height
End With
Err．Clear
End Sub
'初始化界面显示
Public Sub PrepareGUI()
Dim aLyer As MapXLib．Layer
Dim aNde As Node，ndRoot As Node
Dim bOneVisible As Boolean
Me．trvLayer．Nodes．Clear
Me．trvInf．Nodes．Clear
If(mpMain．Layers．Count＞0)Then
Set ndRoot=trvLayer．Nodes．Add(，，mpMain．Geoset，mpMain．Title)
For Each aLyer In mpMain．Layers
Set aNde=trvLayer．Nodes．Add(ndRoot，tvwChild，_
aLyer．Filespec，aLyer．Name)
aNde．Checked=aLyer．Visible
If(aNde．Checked)Then bOneVisible=True
Next
If(bOneVisible)Then ndRoot．Checked=True
ndRoot．Expanded=True
End If
InitialOverviewMap
End Sub
免责声明：以上内容源自网络，版权归原作者所有，如有侵犯您的原创版权请告知，我们将尽快删除相关内容。
