frmmain.frm

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

VERSION 5.00
Object = "{03ED3B1E-ED1B-4A2E-8FE3-D8D1A673F5D4}#5.2#0"; "SuperMap.ocx"
Begin VB.Form frmMain 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "Move"
   ClientHeight    =   6090
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   8745
   Icon            =   "frmMain.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   6090
   ScaleWidth      =   8745
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  'Windows Default
   Begin SuperMapLib.SuperMap SuperMap1 
      Height          =   5595
      Left            =   60
      TabIndex        =   5
      Top             =   480
      Width           =   8655
      _Version        =   327682
      _ExtentX        =   15266
      _ExtentY        =   9869
      _StockProps     =   160
      Appearance      =   1
   End
   Begin SuperMapLib.SuperWorkspace SuperWorkspace1 
      Left            =   6300
      Top             =   1260
      _Version        =   327682
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
   End
   Begin VB.CommandButton cmdExit 
      Caption         =   "关闭"
      Height          =   420
      Left            =   4200
      TabIndex        =   4
      Top             =   15
      Width           =   885
   End
   Begin VB.CommandButton cmdViewEn 
      Caption         =   "全幅显示"
      Height          =   420
      Left            =   1848
      TabIndex        =   3
      Top             =   15
      Width           =   1095
   End
   Begin VB.CommandButton cmdSelMove 
      Caption         =   "选择移动点"
      Height          =   420
      Left            =   2940
      TabIndex        =   2
      Top             =   15
      Width           =   1260
   End
   Begin VB.CommandButton cmdZoomOut 
      Caption         =   "缩小"
      Height          =   420
      Left            =   972
      TabIndex        =   1
      Top             =   15
      Width           =   870
   End
   Begin VB.CommandButton cmdZoomIn 
      Caption         =   "放大"
      Height          =   420
      Left            =   75
      TabIndex        =   0
      Top             =   15
      Width           =   900
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'====================================Supermap Objects 程序说明开始================================
'本程序实现移动点图层的点对象时，带动与该点对象相连的线图层上的所有线对象一起移动
'====================================Supermap Objects程序说明结束================================

Option Explicit
Dim objds As soDataSource
Dim objRsLine As soRecordset
Dim bFlag As Boolean
Dim objPtMove As New soPoint '要移动的点
Dim bCreatePoint As Boolean

Private Sub cmdZoomIn_Click() '放大
    frmMain.SuperMap1.Action = scaZoomIn
End Sub

Private Sub cmdZoomOut_Click() '缩小
    frmMain.SuperMap1.Action = scaZoomOut
End Sub

Private Sub cmdSelMove_Click() '选择,移动点
    frmMain.SuperMap1.Layers.SetEditableLayer ("dot@rotate")
    frmMain.SuperMap1.Layers.Item("dot@rotate").Selectable = True
    frmMain.SuperMap1.Action = scaSelect
    bFlag = True
End Sub

Private Sub cmdViewEn_Click() '全幅显示
    frmMain.SuperMap1.ViewEntire
End Sub

Private Sub cmdExit_Click() '关闭
    Set objds = Nothing
    frmMain.SuperMap1.Disconnect
    frmMain.SuperMap1.Close
    frmMain.SuperWorkspace1.Close
    Unload Me
End Sub

Private Sub Form_Load()
    Dim dsname As String
    Dim i As Integer
    Dim objlayer As soLayer
    Dim objstyle As soStyle
    
    frmMain.SuperMap1.Connect frmMain.SuperWorkspace1.Handle
    dsname = App.Path & "\..\Data\Move\rotate.sdb"
    
    Set objds = frmMain.SuperWorkspace1.OpenDataSource(dsname, "rotate", sceSDBPlus, False)
      
    If objds Is Nothing Then
        MsgBox "打开数据源失败", vbInformation
        Exit Sub
    Else
        For i = 1 To objds.Datasets.Count
            If frmMain.SuperWorkspace1.Datasources(1).Datasets(i).Type <> scdCAD Then
              Set objlayer = frmMain.SuperMap1.Layers.AddDataset(objds.Datasets(i), True)
            End If
        Next i
        
        frmMain.SuperMap1.Layers.SetEditableLayer ("dot@rotate")
    
        frmMain.SuperMap1.Layers.Item("dot@rotate").Selectable = True
        frmMain.SuperMap1.Layers.Item("dot@rotate").Snapable = True
        frmMain.SuperMap1.Layers.Item("line@rotate").Selectable = False
    
        Set objstyle = frmMain.SuperMap1.Layers.Item("dot@rotate").Style
        objstyle.PenColor = vbBlue
        objstyle.SymbolSize = 80
        objstyle.SymbolStyle = 1410
        frmMain.SuperMap1.ViewEntire
        frmMain.SuperMap1.Refresh
    End If
    
    bFlag = False
    Set objRsLine = Nothing
    
    Set objlayer = Nothing
    Set objstyle = Nothing
 
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set objds = Nothing
    Set objRsLine = Nothing
    frmMain.SuperMap1.Disconnect
    frmMain.SuperMap1.Close
    frmMain.SuperWorkspace1.Close
End Sub

Private Sub SuperMap1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button <> 1 Then Exit Sub
    Dim objRs  As soRecordset
    Dim objGeoPt As soGeoPoint
    
    Set objRs = SuperMap1.selection.ToRecordset(False)
    
    If objRs Is Nothing Then Exit Sub
    
    Set objGeoPt = objRs.GetGeometry
    
    objPtMove.x = objGeoPt.x '把所选的点对象的坐标赋给要称动的点对象
    objPtMove.y = objGeoPt.y
    
    If Not objGeoPt Is Nothing Then
        Dim objDtv As soDatasetVector
        
        Set objDtv = SuperWorkspace1.Datasources(1).Datasets("line")
        
        If objDtv Is Nothing Then
            Dim objerror As New soError
            MsgBox objerror.LastErrorMsg
        Else
            Set objRsLine = objDtv.QueryByDistance(objGeoPt, 50, "") '找出与所选点对象相连的线对象
            
            If Not objRsLine Is Nothing Then
                
                Dim objLine As soGeoLine
                Dim i As Integer
                Dim j As Integer
                Dim objPts As soPoints
                Dim objPt As soPoint
                
                objRsLine.MoveFirst
       
                While Not objRsLine.IsEOF
                    Set objLine = objRsLine.GetGeometry
                    For i = 1 To objLine.PartCount
                        'MsgBox objLine.PartCount
                        
                        Set objPts = objLine.GetPartAt(i)
                        For j = 1 To objPts.Count
                            Set objPt = objPts.Item(j)
                            If objPt.x = objPtMove.x And objPt.y = objPtMove.y Then
                            '把鼠标按下去所在缇转化为地理坐标赋给所选点对象相连的线对象的一端点
                                objPt.x = SuperMap1.PixelToMapX(x / Screen.TwipsPerPixelX)
                                objPt.y = SuperMap1.PixelToMapY(y / Screen.TwipsPerPixelY)
                                Set objPts.Item(j) = objPt
                            End If
                        Next
                        objLine.SetPartAt i, objPts   '重新把这些点集赋给线对象
                        objRsLine.Edit
                        objRsLine.SetGeometry objLine '把线对象加到记录集中
                        objRsLine.Update
                    Next
                    objRsLine.MoveNext
                Wend
                '把鼠标按下去所在缇转化为地理坐标赋给要移动的点对象
                objPtMove.x = SuperMap1.PixelToMapX(x / Screen.TwipsPerPixelX)
                objPtMove.y = SuperMap1.PixelToMapY(y / Screen.TwipsPerPixelY)
                
                bFlag = True
            End If
        End If
    End If
    Set objRs = Nothing

End Sub

Private Sub SuperMap1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
   If bFlag = False Then Exit Sub
    If objRsLine Is Nothing Then Exit Sub
     If (Button And vbLeftButton) > 1 Then

        Dim objLine As soGeoLine
        Dim objPt As soPoint
        Dim objPts As soPoints
        Dim i As Integer
        Dim j As Integer

        Dim objGeoPt As soGeoPoint
        Dim objRs As soRecordset
        Dim objEr As New soError
        Dim objSel As soSelection
        Set objSel = SuperMap1.selection
        If objSel Is Nothing Then
            bFlag = False
            Exit Sub
        End If
        Set objRs = SuperMap1.selection.ToRecordset(False)

        If objRs Is Nothing Then
            MsgBox objEr.LastErrorMsg
            bFlag = False
            Exit Sub
        End If

        Set objGeoPt = objRs.GetGeometry

        objRsLine.MoveFirst
        
        While Not objRsLine.IsEOF
            Set objLine = objRsLine.GetGeometry

            For i = 1 To objLine.PartCount
                Set objPts = objLine.GetPartAt(i)
                For j = 1 To objPts.Count
                    Set objPt = objPts.Item(j)
       '如果线对象一个端点的坐标与要移动的点对象的坐标相等，则把鼠标移到的缇转化为地理坐标并赋给这个端点
                    If objPt.x = objPtMove.x And objPt.y = objPtMove.y Then
                        objPt.x = SuperMap1.PixelToMapX(x / Screen.TwipsPerPixelX)
                        objPt.y = SuperMap1.PixelToMapY(y / Screen.TwipsPerPixelY)
                        Set objPts.Item(j) = objPt
                    End If
                Next
                '把这个点集重新生成线对象
                objLine.SetPartAt i, objPts
                
                objRsLine.Edit
                objRsLine.SetGeometry objLine '所这个线对象放到记录集中
                objRsLine.Update
            Next

            objRsLine.MoveNext
        Wend
        '所鼠标所移动到的缇转化为地理坐标并赋给要移动的点对象
        objPtMove.x = SuperMap1.PixelToMapX(x / Screen.TwipsPerPixelX)
        objPtMove.y = SuperMap1.PixelToMapY(y / Screen.TwipsPerPixelY)
      End If

        SuperMap1.Refresh
End Sub
Private Sub SuperMap1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If bFlag = False Then Exit Sub
    If objRsLine Is Nothing Then Exit Sub
        
        Dim objLine As soGeoLine
        Dim objPt As soPoint
        Dim objPts As soPoints
        Dim i As Integer
        Dim j As Integer
        
        Dim xx As Double
        Dim yy As Double
        
        Dim objGeoPt As soGeoPoint
        Dim objRs As soRecordset
        Dim objEr As New soError
        Dim objSel As soSelection
        
        Set objSel = SuperMap1.selection
        If objSel Is Nothing Then
            bFlag = False
            Exit Sub
        End If
        Set objRs = SuperMap1.selection.ToRecordset(False)
        If objRs Is Nothing Then
            bFlag = False
            Exit Sub
        End If
        Set objGeoPt = objRs.GetGeometry
        xx = objGeoPt.x
        yy = objGeoPt.y
        
        objRsLine.MoveFirst
        While Not objRsLine.IsEOF
            Set objLine = objRsLine.GetGeometry
            For i = 1 To objLine.PartCount
                Set objPts = objLine.GetPartAt(i)
                For j = 1 To objPts.Count
                    Set objPt = objPts.Item(i)
                    If objPt.x = objPtMove.x And objPt.y = objPtMove.y Then
                    '把所选的点的坐标重新赋给线对象的与要移动的点对象坐标相同的端点
                        objPt.x = xx
                        objPt.y = yy
                        Set objPts.Item(i) = objPt
                    End If
                Next
                '用这些点集更新与之对应的线对象
                objLine.SetPartAt i, objPts
                objRsLine.Edit
                '所更新过的线对象重新放到记录集中
                objRsLine.SetGeometry objLine
                objRsLine.Update
            Next
            objRsLine.MoveNext
        Wend
    bFlag = False
    objRsLine.Close
    Set objRsLine = Nothing
    
End Sub