frmtrack.frm

都是基于VB所做的程序集合,值得大家作为实践的参考资料.

End Sub

Private Sub Form_Load()
      SuperMap1.Connect SuperWorkspace1.Object
           
      Dim strAlias As String                        '数据源别名
      Dim nEngineType As seEngineType               '数据引擎类型
      Dim strDataSourceName As String               '数据源绝对路径名
      Dim objDataSource As soDataSource             '数据源对象,指向打开的数据源
      Dim bReadOnly As Boolean                      '数据源里的数据是否只读
      Dim objLayer As soLayer                       '图层对象变量,指向将要打开的图层
      Dim bAddToHead As Boolean                     '是否加到最上面
      Dim i As Integer                              '循环变量
      
      nEngineType = sceSDBPlus                          'SuperMap支持多种类型，此处为SDB类型
      strDataSourceName = App.Path & "\..\data\world\world.sdb"
      strAlias = PathToName(strDataSourceName)
      bReadOnly = True                              '不以只读方式打开
      
      '打开数据源
      Set objDataSource = SuperWorkspace1.OpenDataSource(strDataSourceName, strAlias, nEngineType, bReadOnly)
      If objDataSource Is Nothing Then
            MsgBox "打开数据源失败！", vbInformation
      Else
            '把数据源中的所有图层加入到SuperMap中
            bAddToHead = True
            Set objLayer = SuperMap1.Layers.AddDataset(objDataSource.Datasets("Grid"), bAddToHead)
            Set objLayer = SuperMap1.Layers.AddDataset(objDataSource.Datasets("World"), bAddToHead)
      End If
      SuperMap1.MarginPanEnable = False              '关闭自动滚屏
      SuperMap1.Refresh                              '刷新地图窗口
      '设置风格
      objStyleTracking.PenColor = vbBlue
      objStyleTracking.PenWidth = 6
      '释放内存
      Set objDataSource = Nothing
      Set objLayer = Nothing
End Sub

Private Sub Form_Unload(Cancel As Integer)
      btnClose_Click
End Sub

Private Sub SuperMap1_GeometrySelected(ByVal nSelectedGeometryCount As Long)
      '开始选择跟踪
      Dim objGeoLine As New soGeoLine                '定义跟踪线变量
      Dim objGeoLineNew As New soGeoLine             '定义小段跟踪线变量
      Dim dLen As Double                             '定义跟踪线的长度变量
      Dim objRecordset As soRecordset                '定义选择纪录变量
      Dim objCurGeome As soGeometry                  '定义纪录几何对象接受变量
      Dim objCurReig As soGeoRegion                  '定义跟踪面变量
      Dim objStyle As New soStyle                    '定义跟踪线的风格变量

      If bTracking = True Then
            Set objRecordset = SuperMap1.selection.ToRecordset(True)   '获取记录集
            
            If objRecordset Is Nothing Then Exit Sub                   '记录集为空
            If objRecordset.RecordCount < 1 Then Exit Sub              '记录集没有记录
        
            SuperMap1.selection.RemoveAll                              '清楚跟踪层对象
            Set objCurGeome = objRecordset.GetGeometry                 '取得记录集中的几何对象

            If objCurGeome.Type = scgLine Then                         '如果是线的话，直接获取之
                  Set objGeoLine = objCurGeome
            ElseIf objCurGeome.Type = scgRegion Then                   '如果是面，转换成线
                  Set objCurReig = objCurGeome
                  Set objGeoLine = objCurGeome.ConvertToLine()
            ElseIf objCurGeome.Type = scgPoint Then                    '如果是点，显示之
                  objStyle.PenColor = vbRed
                  objStyle.SymbolSize = 96
                  objStyle.SymbolStyle = 1
                  
                  SuperMap1.TrackingLayer.ClearEvents
                  SuperMap1.TrackingLayer.AddEvent objCurGeome, objStyle, ""
                  SuperMap1.TrackingLayer.Refresh
            End If
            
            If Not (objGeoLine Is Nothing) Then                                   '如果获得的线不为空，进行跟踪
                  Set objGeoLineTracked = objGeoLine
                  dLen = objGeoLine.Length
                  Set objGeoLineNew = objGeoLine.ResampleEquidistantly(dLen / 40) '重采样，将线等距离分成40份
                  If Not (objGeoLineNew Is Nothing) Then
                        Set objPointsTracked = Nothing
                        Set objPointsTracked = objGeoLineNew.GetPartAt(1)
                        nCurPoint = 1
                        Timer1.Enabled = True                                     '启动Timer，循环取点跟踪
                  End If
            End If
      End If
      
      Set objStyle = Nothing
      Set objCurGeome = Nothing
      Set objCurReig = Nothing
      Set objGeoLineNew = Nothing
      Set objGeoLine = Nothing
      Set objRecordset = Nothing
End Sub

Private Sub SuperMap1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
      '根据按键状态进行不同的操作，如果是右键，结束视图定位，否则，定位到新视图
      If Button = vbRightButton Then
            SuperMap1.TrackingLayer.ClearEvents
            SuperMap1.Refresh
            bViewBnd = False
      End If
      '视图定位
      If bViewBnd = True Then
            SuperMap1.TrackingLayer.ClearEvents
            SuperMap1.ViewScale = SuperMap1.ViewScale * 6
            SuperMap1.CenterX = objGeoPointViewCenter.x
            SuperMap1.CenterY = objGeoPointViewCenter.y
      End If
End Sub

Private Sub SuperMap1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If bViewBnd = False Then Exit Sub
    '视图跟踪
    Dim xx As Double, yy As Double
    
    xx = SuperMap1.PixelToMapX(ScaleX(x, vbTwips, vbPixels))
    yy = SuperMap1.PixelToMapY(ScaleY(y, vbTwips, vbPixels))
    Dim pnt As New soGeoPoint, style As New soStyle, lin As New soGeoLine, bnd As soRect
    Dim part As New soPoints, cx As Double, cy As Double
    Set bnd = SuperMap1.ViewBounds
    cx = bnd.Width() / 12
    cy = bnd.Height() / 12
    
    '计算视图Bounds的点坐标
    part.Add2 xx - cx, yy + cy
    part.Add2 xx + cx, yy + cy
    part.Add2 xx + cx, yy - cy
    part.Add2 xx - cx, yy - cy
    part.Add2 xx - cx, yy + cy
    
    lin.AddPart part
    
    pnt.x = xx
    pnt.y = yy
    '
    objGeoPointViewCenter.x = xx
    objGeoPointViewCenter.y = yy
    '设置风格属性
    style.PenColor = 255
    style.SymbolSize = 50
    style.SymbolStyle = 1
    
   
    SuperMap1.TrackingLayer.ClearEvents                 '清除所有实例
    SuperMap1.TrackingLayer.AddEvent lin, style, ""     '增加线实例
    SuperMap1.TrackingLayer.AddEvent pnt, style, ""     '增加点实例
    SuperMap1.TrackingLayer.Refresh                     '刷新
End Sub

Private Sub SuperMap1_Tracked()
      Dim objLn As soGeoLine                           '定义线状几何接受变量
      Dim objLnNew As soGeoLine                        '定义线实例变量
      Dim dLen As Double                            '定义目标线的长度
      Dim objCurReig As soGeoRegion                    '定义面状几何接受变量
      Dim CurGeome As soGeometry                    '定义几何对象变量，用来接受几何对象
        
      Set CurGeome = SuperMap1.TrackedGeometry      '接受画线或面后的几何对象
      
      If CurGeome.Type = scgLine Then               '如果是线的话，直接获取之
            Set objLn = CurGeome
      ElseIf CurGeome.Type = scgRegion Then         '如果是面，转换为线
            Set objCurReig = CurGeome
            Set objLn = objCurReig.ConvertToLine
      End If
      If Not (objLn Is Nothing) Then
            Set objGeoLineTracked = objLn
            dLen = objLn.Length
            Set objLnNew = objLn.ResampleEquidistantly(dLen / 40)
            If Not (objLnNew Is Nothing) Then
                      Set objPointsTracked = Nothing
                      Set objPointsTracked = objLnNew.GetPartAt(1)
                      nCurPoint = 1
                      Timer1.Interval = 500
                      Timer1.Enabled = True
                      objGeoPointViewCenter.x = SuperMap1.CenterX
                      objGeoPointViewCenter.y = SuperMap1.CenterY
            End If
      End If
End Sub

Private Sub Timer1_Timer()
    If Not (objPointsTracked Is Nothing) Then
        If objPointsTracked.Count > nCurPoint Then
            Dim pnt As New soGeoPoint, style As New soStyle         '定义一个新的点实例变量和风格变量
            pnt.x = objPointsTracked.Item(nCurPoint).x                        '获取新的点实例的X坐标
            pnt.y = objPointsTracked.Item(nCurPoint).y                        '获取新的点实例的Y坐标
            '定义点实例的风格
            style.PenColor = 255
            style.SymbolSize = 96
            style.SymbolStyle = 1
            
            SuperMap1.TrackingLayer.ClearEvents                     '清除所有实例
            SuperMap1.TrackingLayer.AddEvent objGeoLineTracked, objStyleTracking, ""   '增加目标线实例
            SuperMap1.TrackingLayer.AddEvent pnt, style, ""         '增加点实例
            SuperMap1.TrackingLayer.Refresh                         '刷新
            nCurPoint = nCurPoint + 1                               '定位下一个点在点集合中的位置
        Else
            SuperMap1.TrackingLayer.ClearEvents                     '清除所有实例
            SuperMap1.CenterX = objGeoPointViewCenter.x                        '重新确定视图的中心X坐标
            SuperMap1.CenterY = objGeoPointViewCenter.y                        '重新确定视图的中心Y坐标
            SuperMap1.TrackingLayer.Refresh                         '刷新跟踪图层
            Timer1.Enabled = False                                  '停止点实例的跟踪
        End If
    End If
End Sub