frmmain.frm

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

    If LsvSource.SelectedItem Is Nothing Then
        MsgBox "请选择一个点"
        Exit Sub
    End If
    SuperMap2.TrackingLayer.RemoveEvent LsvSource.SelectedItem.Index
    SuperMap2.TrackingLayer.Refresh
 
    LsvSource.ListItems.Remove LsvSource.SelectedItem.Index
    LsvSource.Refresh
End Sub

Private Sub CmdDelTarget_Click()
    If LsvTarget.ListItems.Count < 1 Then Exit Sub
    If LsvTarget.ListItems.Count < 1 Then Exit Sub
    If LsvTarget.SelectedItem Is Nothing Then
        MsgBox "请选择一个点"
        Exit Sub
    End If
    SuperMap1.TrackingLayer.RemoveEvent LsvTarget.SelectedItem.Index
    SuperMap1.TrackingLayer.Refresh
'    Debug.Print LsvTarget.SelectedItem.Index
    LsvTarget.ListItems.Remove LsvTarget.SelectedItem.Index
    LsvTarget.Refresh
End Sub

Private Sub CmdEditSource_Click()
    If LsvSource.ListItems.Count < 1 Then Exit Sub
    If LsvSource.SelectedItem Is Nothing Then Exit Sub
    SourceNew = False
    If CmdEditSource.Caption = "编辑" Then
        CmdEditSource.Caption = "保存"
        LsvSource.Enabled = False
        TxtSourceX.Text = LsvSource.SelectedItem.Text
        TxtSourceY.Text = LsvSource.SelectedItem.SubItems(1)
    Else
        CmdEditSource.Caption = "编辑"
        LsvSource.Enabled = True
        If IsNumeric(Val(TxtSourceX.Text)) Then
            If IsNumeric(Val(TxtSourceY.Text)) Then
                LsvSource.ListItems(LsvSource.SelectedItem.Index).Text = Val(TxtSourceX.Text)
                LsvSource.ListItems(LsvSource.SelectedItem.Index).SubItems(1) = Val(TxtSourceY.Text)
                SuperMap2.TrackingLayer.Event(LsvSource.SelectedItem.Index).MoveTo Val(TxtSourceX.Text), Val(TxtSourceY.Text)
                SuperMap2.TrackingLayer.Refresh
            End If
        End If
        TxtSourceX.Text = "0.000000"
        TxtSourceY.Text = "0.000000"
    End If
End Sub

Private Sub CmdEditTarget_Click()
    If LsvTarget.ListItems.Count < 1 Then Exit Sub
    If LsvTarget.SelectedItem Is Nothing Then Exit Sub
    TargetNew = False
    If CmdEditTarget.Caption = "编辑" Then
        LsvTarget.Enabled = False
        CmdEditTarget.Caption = "保存"
        TxtTargetX.Text = LsvTarget.SelectedItem.Text
        TxtTargetY.Text = LsvTarget.SelectedItem.SubItems(1)
    Else
        CmdEditTarget.Caption = "编辑"
        LsvTarget.Enabled = True
        If IsNumeric(Val(TxtTargetX.Text)) Then
            If IsNumeric(Val(TxtTargetY.Text)) Then
                LsvTarget.ListItems(LsvTarget.SelectedItem.Index).Text = Val(TxtTargetX.Text)
                LsvTarget.ListItems(LsvTarget.SelectedItem.Index).SubItems(1) = Val(TxtTargetY.Text)
                SuperMap1.TrackingLayer.Event(LsvTarget.SelectedItem.Index).MoveTo Val(TxtTargetX.Text), Val(TxtTargetY.Text)
                SuperMap1.TrackingLayer.Refresh
            End If
        End If
        TxtTargetX.Text = "0.000000"
        TxtTargetY.Text = "0.000000"
    End If
End Sub

Private Sub CmdNewSource_Click()
    SourceNew = True
    ReSampleSource = False
    SuperMap2.Action = scaNull
End Sub

Private Sub CmdNewTarget_Click() '新建配准点
    TargetNew = True
    ReSampleTarget = False
    SuperMap1.Action = scaNull
End Sub

Private Sub CmdRegister_Click() '配准
    Dim TransformMean As seTransformType
    Dim objMidPoint As New soPoint
    Dim objTransformation  As New soTransformation
    Dim i As Integer
    Dim iNodeNumber As Integer
    Dim strNewDatasetName As String
    Dim objerrors As soTransformErrors
    Dim bRegisterContinue As Boolean
    Dim objRect As New soRect
    Dim objDS As soDataSource
    Dim objDtRaster As soDatasetRaster
    Dim bResult As Boolean

    Select Case CmbType.ListIndex
        Case 0: iNodeNumber = 2
                TransformMean = sctRect
        Case 1: iNodeNumber = 3
                TransformMean = sctLinear
        Case 2: iNodeNumber = 7
                TransformMean = sctSquare
    End Select
    
    If LsvTarget.ListItems.Count < iNodeNumber Then
        MsgBox "目标点数目不够！  ", vbInformation
        Exit Sub
    End If
    
    For i = 1 To LsvTarget.ListItems.Count
        objMidPoint.x = Val(LsvTarget.ListItems(i).Text)
        objMidPoint.y = Val(LsvTarget.ListItems(i).SubItems(1))
        objTransformation.TargetControlPoints.Add objMidPoint
    Next
      
    If CmbType.ListIndex <> 0 Then
        If LsvSource.ListItems.Count < iNodeNumber Then
            MsgBox "配准源点数目不够！  ", vbInformation
            Exit Sub
        End If
        For i = 1 To LsvSource.ListItems.Count
            objMidPoint.x = Val(LsvSource.ListItems(i).Text)
            objMidPoint.y = Val(LsvSource.ListItems(i).SubItems(1))
             objTransformation.OriginalControlPoints.Add objMidPoint
        Next
        If objTransformation.TargetControlPoints.Count <> objTransformation.OriginalControlPoints.Count Then
            MsgBox "配准源点与目标点数目不一致！ ", vbCritical
            Exit Sub
        End If
    End If
    
    '取得要进行配准的影像数据集
    If SuperMap2.Layers.Item(1).Dataset.Vector = True Then
        MsgBox "没有栅格图数据集用来配准！ ", vbInformation
        Exit Sub
    Else
        Set objDtRaster = SuperMap2.Layers.Item(1).Dataset
    End If
    If objDtRaster Is Nothing Then
         MsgBox "打开影像数据集失败", vbInformation
    Else
         If CmbType.ListIndex = 0 Then
            objRect.Left = IIf(objTransformation.TargetControlPoints(1).x <= objTransformation.TargetControlPoints(2).x, objTransformation.TargetControlPoints(1).x, objTransformation.TargetControlPoints(2).x)
            objRect.Right = IIf(objTransformation.TargetControlPoints(1).x >= objTransformation.TargetControlPoints(2).x, objTransformation.TargetControlPoints(1).x, objTransformation.TargetControlPoints(2).x)
            objRect.Bottom = IIf(objTransformation.TargetControlPoints(1).y <= objTransformation.TargetControlPoints(2).y, objTransformation.TargetControlPoints(1).y, objTransformation.TargetControlPoints(2).y)
            objRect.Top = IIf(objTransformation.TargetControlPoints(1).y >= objTransformation.TargetControlPoints(2).y, objTransformation.TargetControlPoints(1).y, objTransformation.TargetControlPoints(2).y)
            bResult = objDtRaster.Register2(objRect)
            If bResult = False Then
                MsgBox "配准失败！", vbInformation
            Else
                MsgBox "配准成功！", vbInformation
                SuperMap1.Layers.AddDataset SuperWorkspace1.Datasources(1).Datasets("Raster"), True
                SuperMap1.Refresh
                SuperMap2.Refresh
            End If
            Exit Sub
         End If
         
         Set objerrors = objTransformation.GetErrors(TransformMean)
         If objerrors Is Nothing Then
            MsgBox "Error"
            Exit Sub
         End If
         bRegisterContinue = frmErrors.registerContinue(objerrors)
         If bRegisterContinue = False Then Exit Sub
         '获取配准数据源，以便重采样生成新数据集
         Set objDS = SuperWorkspace1.Datasources.Item(1)
         If objDS Is Nothing Then
             MsgBox "打开数据源出错！", vbInformation
             Exit Sub
         Else
             strNewDatasetName = InputBox("请输入新数据集名")
             Do While Not objDS.IsAvailableDatasetName(strNewDatasetName)
                MsgBox "数据集名非法！", vbInformation
                strNewDatasetName = InputBox("请输入新数据集名")
             Loop
             If Trim(strNewDatasetName) = "" Then Exit Sub
         End If
         Set objerrors = Nothing
    End If
        '重采样配准
        bResult = objTransformation.Rectify(objDtRaster, objDS, strNewDatasetName, RegisterType)
        If bResult = False Then
            MsgBox "配准失败！", vbInformation
        Else
            MsgBox "配准成功！", vbInformation
            SuperMap1.Layers.AddDataset SuperWorkspace1.Datasources(1).Datasets(strNewDatasetName), True
            SuperMap1.Refresh
            SuperMap2.Refresh
        End If
        
      Set objDS = Nothing
      Set objDtRaster = Nothing
      Set objTransformation = Nothing
      Set objMidPoint = Nothing
      Set objRect = Nothing
      Set objerrors = Nothing
End Sub

Private Sub CmdReRe_Click() '重新配准
    SuperMap1.TrackingLayer.ClearEvents
    SuperMap2.TrackingLayer.ClearEvents
    LsvTarget.ListItems.Clear
    LsvSource.ListItems.Clear
    LsvTarget.Refresh
    LsvSource.Refresh
    If SuperMap1.Layers.Count >= 2 Then
        Dim DtName As String
        DtName = SuperMap1.Layers(1).Dataset.Name
        SuperMap1.Layers.RemoveAt 1
        If DtName <> "raster" Then
           SuperWorkspace1.Datasources(1).DeleteDataset DtName
        End If
    End If
    SuperMap1.Refresh
    SuperMap2.Refresh
End Sub

Private Sub CmdRSamSource_Click()
    SourceNew = False
    ReSampleSource = True
End Sub

Private Sub CmdRSamTarget_Click()
    TargetNew = False
    ReSampleTarget = True
End Sub

Private Sub Command1_Click(Index As Integer)
      Select Case Index
            Case 1
                  SuperMap1.Action = scaPan
                  SuperMap2.Action = scaPan
            Case 4
                  SuperMap1.Action = scaZoomFree
                  SuperMap2.Action = scaZoomFree
            Case 5
                  SuperMap1.ViewEntire
                  SuperMap2.ViewEntire
            Case 6
                    Form_Unload 1
            Case 7
                  SuperMap1.Refresh
                  SuperMap2.Refresh
      End Select
End Sub

Private Sub Command2_Click()
    SuperMap1.TrackingLayer.ClearEvents
    SuperMap1.TrackingLayer.Refresh
    
    LsvTarget.ListItems.Clear
    LsvTarget.Refresh
    
    TxtTargetX.Text = "0.000000"
    TxtTargetY.Text = "0.000000"
End Sub

Private Sub Command3_Click()
    SuperMap2.TrackingLayer.ClearEvents
    SuperMap2.TrackingLayer.Refresh
    
    LsvSource.ListItems.Clear
    LsvSource.Refresh
    
    TxtSourceX.Text = "0.000000"
    TxtSourceY.Text = "0.000000"
End Sub

Private Sub Form_Load()
      SuperMap1.Connect SuperWorkspace1.Handle
      SuperMap2.Connect SuperWorkspace1.Handle
    
      Dim strAlias As String '数据源别名
      Dim nEngineType As seEngineType '数据引擎类型
      Dim strDataSourceName As String '数据源绝对路径名
      Dim objDataSource As soDataSource '数据源对象,指向打开的数据源
      Dim objLayer As soLayer '图层对象变量,指向将要打开的图层
      Dim i As Integer '循环变量
      
      nEngineType = sceSDBPlus  'SuperMap支持多种类型，此处为SDB类型
      strDataSourceName = App.Path & "\..\Data\Register\RegisterTest.sdb"   'CommonDialog1.FileName
      strAlias = "world"
      
      '打开数据源
      Set objDataSource = SuperWorkspace1.OpenDataSource(strDataSourceName, strAlias, nEngineType, False)
      If objDataSource Is Nothing Then
            MsgBox "打开数据源失败！", vbInformation
      Else
            '把数据源中的所有图层加入到SuperMap中
            Set objLayer = SuperMap1.Layers.AddDataset(objDataSource.Datasets.Item("world"), True)
            Set objLayer = SuperMap2.Layers.AddDataset(objDataSource.Datasets.Item("raster"), True)
      End If
      '刷新地图窗口
      If SuperMap1.Layers.Count <= 0 Then Exit Sub

      SuperMap1.Refresh
      SuperMap2.Refresh
      
      '释放内存
      Set objDataSource = Nothing
      Set objLayer = Nothing

      CmbType.ListIndex = 0
      '初始化lsvTraget、lstSource控件
      LsvTarget.ColumnHeaders.Add 1, , "X坐标", LsvTarget.Width / 2
      LsvTarget.ColumnHeaders.Add 2, , "Y坐标", LsvTarget.Width / 2
     
      LsvSource.ColumnHeaders.Add 1, , "X坐标", LsvSource.Width / 2
      LsvSource.ColumnHeaders.Add 2, , "Y坐标", LsvSource.Width / 2

End Sub

Private Sub Form_Unload(Cancel As Integer)
    If SuperMap1.Layers.Count >= 2 Then
        Dim DtName As String
        DtName = SuperMap1.Layers(1).Dataset.Name
        SuperMap1.Layers.RemoveAt 1
        If DtName <> "raster" Then
           SuperWorkspace1.Datasources(1).DeleteDataset DtName
        End If
    End If
    SuperMap1.Close
    SuperMap2.Close
    SuperMap1.Disconnect
    SuperMap2.Disconnect
    SuperWorkspace1.Close
    End
End Sub

Private Sub SuperMap1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
        Dim CoordX As Double
        Dim CoordY As Double
        CoordX = SuperMap1.PixelToMapX(ScaleX(x, vbTwips, vbPixels))
        CoordY = SuperMap1.PixelToMapY(ScaleY(y, vbTwips, vbPixels))
    If TargetNew = True Then
        Select Case CmbType.ListIndex
            Case 0: If SuperMap1.TrackingLayer.EventCount = 2 Then Exit Sub
            Case 1: If SuperMap1.TrackingLayer.EventCount = 3 Then Exit Sub
            Case 2: If SuperMap1.TrackingLayer.EventCount = 7 Then Exit Sub
        End Select
        
        Dim Style As New soStyle
        Style.SymbolStyle = 2
        Style.PenColor = vbBlue
        Style.SymbolSize = 20
        
        Dim GeoPoint As New soGeoPoint
        GeoPoint.x = CoordX
        GeoPoint.y = CoordY
                
        SuperMap1.TrackingLayer.AddEvent GeoPoint, Style, ""
        SuperMap1.TrackingLayer.Refresh

        LsvTarget.ListItems.Add , , Str(CoordX)
        LsvTarget.ListItems(LsvTarget.ListItems.Count).SubItems(1) = Str(CoordY)
        LsvTarget.Refresh
   '     LsvTarget.SetFocus
    End If
    If ReSampleTarget = True Then
        If SuperMap1.TrackingLayer.EventCount < 1 Then Exit Sub
        SuperMap1.TrackingLayer.Event(LsvTarget.SelectedItem.Index).MoveTo CoordX, CoordY
        LsvTarget.SelectedItem = Str(CoordX)
        LsvTarget.ListItems(LsvTarget.SelectedItem.Index).SubItems(1) = Str(CoordY)
        SuperMap1.Refresh
    End If
    
End Sub

Private Sub SuperMap2_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
        Dim CoordX As Double
        Dim CoordY As Double
        
        CoordX = SuperMap2.PixelToMapX(ScaleX(x, vbTwips, vbPixels))
        CoordY = SuperMap2.PixelToMapY(ScaleY(y, vbTwips, vbPixels))
    If SourceNew = True Then
        Select Case CmbType.ListIndex
            Case 0: If SuperMap2.TrackingLayer.EventCount = 2 Then Exit Sub
            Case 1: If SuperMap2.TrackingLayer.EventCount = 3 Then Exit Sub
            Case 2: If SuperMap2.TrackingLayer.EventCount = 7 Then Exit Sub
        End Select
        
        Dim Style As New soStyle
        Style.SymbolStyle = 2
        Style.PenColor = vbRed
        Style.SymbolSize = 20
        
        Dim GeoPoint As New soGeoPoint
        GeoPoint.x = CoordX
        GeoPoint.y = CoordY
                
        SuperMap2.TrackingLayer.AddEvent GeoPoint, Style, ""
        SuperMap2.TrackingLayer.Refresh

        LsvSource.ListItems.Add , , Str(CoordX)
        LsvSource.ListItems(LsvSource.ListItems.Count).SubItems(1) = Str(CoordY)
        LsvSource.Refresh
     End If
    If ReSampleSource = True Then
        If SuperMap2.TrackingLayer.EventCount < 1 Then Exit Sub
        SuperMap2.TrackingLayer.Event(LsvSource.SelectedItem.Index).MoveTo CoordX, CoordY
        LsvSource.SelectedItem = Str(CoordX)
        LsvSource.ListItems(LsvTarget.SelectedItem.Index).SubItems(1) = Str(CoordY)
        SuperMap2.Refresh
    End If
End Sub