frmmain.frm

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

'          增加一个点实例。
'
'
'===================================SuperMap Objects示范工程说明结束=====================================

Option Explicit
Dim bAddPoint As Boolean                  '定义是否增加点实例的控制变量
Dim objPointsEvent As New soPoints          '定义用来管理点实例的点集合变量
Dim objPointEvent As New soPoint            '定义用来接受新的点实例的变量
Dim objCurPoint As New soGeoPoint           '定义用来在TrackingLayer上增加实例的点变量
Dim objCurStyle As New soStyle              '定义TrackingLayer上点实例的特征变量


Public Function PathToName(ByVal strPath As String) As String
'=====================================================
'自定义函数 , 将文件全路径名转化为文件名(无路径名, 无扩展名)
'=====================================================
    Dim iLength As Integer      '字符串长度
    Dim i As Integer
    Dim strTemp As String
    Dim strTemp1 As String
    Dim iPosition As Integer

    iPosition = 999
    If InStr(strPath, ".") <> 0 Then
        strTemp = Left(strPath, Len(strPath) - 4)
    Else
        strTemp = strPath
    End If

    iLength = Len(strTemp)
    For i = Len(strPath) To 1 Step -1
        If Mid$(strTemp, i, 1) = "\" Then
            iPosition = i
            Exit For
        End If
    Next
    If iPosition = 999 Then
        PathToName = strTemp
    Else
        PathToName = Right(strTemp, iLength - iPosition)
    End If
End Function

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub cmdPan_Click()
    SuperMap1.Action = scaPan
End Sub

Private Sub cmdRefresh_Click()
    SuperMap1.Refresh
End Sub

Private Sub cmdSelect_Click()
    SuperMap1.Action = scaSelect
End Sub

Private Sub cmdViewEntire_Click()
    SuperMap1.ViewEntire
End Sub

Private Sub cmdZoomIn_Click()
    SuperMap1.Action = scaZoomIn
End Sub

Private Sub cmdZoomOut_Click()
    SuperMap1.Action = scaZoomOut
End Sub

Private Sub cmdAdd_Click()
    '开始增加点实例,给控制变量 bAddPoint赋值为True
    SuperMap1.Action = scaNull
    bAddPoint = True
End Sub

Private Sub cmdClearAll_Click()
    SuperMap1.TrackingLayer.ClearEvents     '清除TrackingLayer上的所有点实例
    SuperMap1.TrackingLayer.Refresh         '刷新TrackingLayer层
    lvwPoint.ListItems.Clear                '清除坐标记录
    objPointsEvent.RemoveAll                '清除点对象集合中的所有点的信息
    Timer1.Enabled = False                  '停止点实例的移动
    cmdGps.Caption = "GPS演示"              '回到初始状态
End Sub

Private Sub cmdDelete_Click()
    On Error Resume Next
    '没有选中的点可供删除
    If lvwPoint.SelectedItem Is Nothing Then Exit Sub
    '删除选中的点
    If lvwPoint.SelectedItem.Index >= 1 And lvwPoint.SelectedItem.Index < lvwPoint.ListItems.Count + 1 Then
        SuperMap1.TrackingLayer.RemoveEvent lvwPoint.SelectedItem.Index     '删除点实例
        SuperMap1.TrackingLayer.Refresh                                     '刷新TrackingLayer
        lvwPoint.ListItems.Remove lvwPoint.SelectedItem.Index               '删除点的坐标记录
        '判断点实例的个数，决定下面的操作状态
        If lvwPoint.ListItems.Count < 1 Then
            Timer1.Enabled = False
            cmdGps.Caption = "GPS演示"
        End If
        objPointsEvent.Remove lvwPoint.SelectedItem.Index, 1                '从点实例集合中删除相应测点对象
        If lvwPoint.ListItems.Count >= 1 Then
            Set lvwPoint.SelectedItem = lvwPoint.ListItems(lvwPoint.ListItems.Count)
            lvwPoint.SetFocus
            lvwPoint.Refresh
        End If
    
    End If
    If lvwPoint.ListItems.Count = 0 Then
        objPointsEvent.RemoveAll
    End If
End Sub

Private Sub cmdGps_Click()
    If objPointsEvent.Count < 1 Then Exit Sub               'TrackingLayer上没有点实例
    Set objDataset = SuperMap1.Layers(1).Dataset            '给公共变量dst赋值，用来获取点移动的范围
    If cmdGps.Caption = "GPS演示" Then                      '开始跟踪点实例
        cmdGps.Caption = "STOP演示"
        Timer1.Enabled = True
    Else                                                    '停止跟踪点实例
        cmdGps.Caption = "GPS演示"
        Timer1.Enabled = False
    End If
End Sub

Private Sub cmdLocation_Click() '根据指定的坐标点在图上增加一个点实例
    Dim x As Double
    Dim y As Double
    If IsNumeric(Val(txtX.Text)) Then
        x = Val(txtX.Text)
        If IsNumeric(Val(txtY.Text)) Then
            y = Val(txtY.Text)
            Dim soRect As soRect
            Set soRect = SuperMap1.Layers(1).Dataset.Bounds
            
            If x < soRect.Left Then
               MsgBox "X坐标小于地图左边界，不能增加实例！  ", vbInformation, "错误："
               Exit Sub
            End If
            
            If x > soRect.Right Then
               MsgBox "X坐标大于地图左边界，不能增加实例！  ", vbInformation, "错误："
               Exit Sub
            End If
            
            If y < soRect.Bottom Then
               MsgBox "Y坐标小于地图左边界，不能增加实例！  ", vbInformation, "错误："
               Exit Sub
            End If
            
            If y > soRect.Top Then
               MsgBox "Y坐标大于地图左边界，不能增加实例！  ", vbInformation, "错误："
               Exit Sub
            End If

            objCurPoint.x = Val(txtX.Text)
            objCurPoint.y = Val(txtY.Text)
            SuperMap1.TrackingLayer.AddEvent objCurPoint, objCurStyle, ""
            
            objPointEvent.x = objCurPoint.x
            objPointEvent.y = objCurPoint.y
            objPointsEvent.Add objPointEvent
            
            lvwPoint.ListItems.Add , , txtX.Text
            lvwPoint.ListItems(lvwPoint.ListItems.Count).SubItems(1) = txtY.Text
            SuperMap1.TrackingLayer.Refresh
        Else
            MsgBox "Y坐标中还有非数值型字符", vbCritical, "错误："
        End If
    Else
        MsgBox "X坐标中还有非数值型字符", vbCritical, "错误："
    End If
                   
End Sub

Private Sub cmdStopAdd_Click()
    bAddPoint = False
End Sub

Private Sub Form_Load()
    SuperMap1.Connect SuperWorkspace1.Object
      
    Dim objDS As soDataSource
    Dim strDsName As String
    Dim strDsAlias As String
    Dim i As Integer
      
    strDsName = App.Path & "\..\data\World\World.sdb"
    strDsAlias = PathToName(strDsName)
    Set objDS = Me.SuperWorkspace1.OpenDataSource(strDsName, strDsAlias, sceSDBPlus, True)
    If objDS Is Nothing Then
        MsgBox "数据源打开失败！", vbInformation
    Else
        SuperMap1.Layers.AddDataset objDS.Datasets("Grid"), True
        SuperMap1.Layers.AddDataset objDS.Datasets("world"), True
        SuperMap1.Layers(1).Dataset.ComputeBounds
        SuperMap1.Refresh
    End If
    SuperMap1.Action = scaSelect
    SuperMap1.MarginPanEnable = False
    Set objDS = Nothing
    
    bAddPoint = False          '设置不增加点实例
    objCurStyle.PenColor = vbBlue
    objCurStyle.SymbolSize = 50
    objCurStyle.SymbolStyle = 2
    
    lvwPoint.ColumnHeaders.Add , , "X坐标", lvwPoint.Width / 2
    lvwPoint.ColumnHeaders.Add , , "Y坐标", lvwPoint.Width / 2
    
    '初始化随机数
    Randomize
    Rnd
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    SuperMap1.Width = Me.ScaleWidth - SuperMap1.Left - 10
    SuperMap1.Height = Me.ScaleHeight - SuperMap1.Top - 10
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Timer1.Enabled = False
    Set objCurPoint = Nothing
    Set objDataset = Nothing
    Set objPointsEvent = Nothing
    Set objPointEvent = Nothing
    Set objCurPoint = Nothing
    Set objCurStyle = Nothing
    SuperMap1.Close
    SuperMap1.Disconnect
    SuperWorkspace1.Close
End Sub

Private Sub SuperMap1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If bAddPoint = True Then
        objCurPoint.x = SuperMap1.PixelToMapX(ScaleX(x, vbTwips, vbPixels))
        objCurPoint.y = SuperMap1.PixelToMapY(ScaleY(y, vbTwips, vbPixels))
        SuperMap1.TrackingLayer.AddEvent objCurPoint, objCurStyle, ""
        SuperMap1.TrackingLayer.Refresh
        
        objPointEvent.x = objCurPoint.x
        objPointEvent.y = objCurPoint.y
        objPointsEvent.Add objPointEvent
     
        lvwPoint.ListItems.Add , , objCurPoint.x
        lvwPoint.ListItems(lvwPoint.ListItems.Count).SubItems(1) = Str(objCurPoint.y)
    End If
     
End Sub

Private Sub SuperMap1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim objCurPoint1 As New soGeoPoint
    objCurPoint1.x = SuperMap1.PixelToMapX(ScaleX(x, vbTwips, vbPixels))
    objCurPoint1.y = SuperMap1.PixelToMapY(ScaleY(y, vbTwips, vbPixels))
    labCoord.Caption = "X:" & Format(objCurPoint1.x, "#.####") & "  Y:" & Format(objCurPoint1.y, "#.####")
End Sub

Private Sub Timer1_Timer()
    If objPointsEvent.Count < 1 Then
        Timer1.Enabled = False
        cmdGps.Caption = "GPS演示"
        Exit Sub
    End If
    Location objPointsEvent, SuperMap1

End Sub