frmsave.frm

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

      Caption         =   ""
      Visible         =   0   'False
      Begin VB.Menu mnuNewMapWin 
         Caption         =   "新建地图窗口"
      End
      Begin VB.Menu mnuAddToCurrWin 
         Caption         =   "添加到当前窗口"
      End
   End
End
Attribute VB_Name = "FrmSave"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'=====================================SuperMap Objects示范工程说明==================================================
'
'功能简介：示范SuperMap Objects中的工作空间和Map对象的保存与打开。
'所用控件：SuperMap控件和SuperWordspace控件
'所用数据：..\Data\World.sdb 和 World.sdd两个文件
'操作说明：
'        1、程序运行时就是一个默认的工作空间(没有专门的语句)，左侧的"数据列表"中列出了其中的数据源、数据集。
'        2、双击一个数据集可以显示该数据集。选中一个数据集后右击，会弹出一个打开数据集的快捷菜单，使用它也可以打开。
'        3、使用"平移"、"自由缩放"和"全幅显示"按钮可以对地图进行基本操作。
'           "清除图层"按钮可以清除地图窗口中所有图层。
'        4、使用"打开数据源"可以打开一个数据源文件，并把其中的数据加入到"数据列表"中。
'        5、"打开工作空间"可以打开以前保存的工作空间文件(*.smw)，其中的数据会加入到"数据列表"中，保存的地图对象(Map)
'                        会加入到"地图列表"中。
'           "保存工作空间"、"另存工作空间"、"关闭工作空间"按钮可以对工作空间进行保存和关闭操作。
'        6、"保存地图"可以把地图窗口中地图(可以是多层)及其每层的显示风格、比例尺等状态(大小和所用的线型、符号等)保存为
'                     Map对象，放在工作空间中。保存的地图对象(Map)会列在左侧的"地图列表"中。
'           "打开地图"可以把"地图列表"中选中的地图对象(Map)打开在地图窗口中(或双击其中一项也可以打开);
'           "地图另存"将打开的地图对象另存为一个地图对象。
'
'===================================SuperMap Objects示范工程说明结束==================================================                                       工程说明：

Option Explicit
Dim objError As New soError

Private Sub btnDelLayers_Click()
      SuperMap1.Layers.RemoveAll
      SuperMap1.Action = scaNull
      SuperMap1.Refresh
      btnSaveMap.Enabled = False
      btnSaveAsMap.Enabled = False
End Sub

Private Sub btnOpenDatasource_Click()
      Dim strDsFileName As String      '定义数据源名称变量
      Dim strDsAlias  As String        '定义数据源别名变量
      Dim objDS As soDataSource        '定义数据源变量
      Dim i As Integer                 '定义循环变量
      
      '初始化打开数据源对话框
      With cmlFile
            .CancelError = False
            .DialogTitle = "打开数据源"
            .Filter = "SuperMap 数据源文件(*.sdb)|*.sdb"
            .InitDir = App.Path
            .FileName = ""
            .Flags = cdlOFNFileMustExist
            .ShowOpen
            If .FileName <> "" Then
                  strDsFileName = .FileName
                  strDsAlias = .FileTitle
            Else
                  Set objDS = Nothing
                  Exit Sub
            End If
      End With
      
      '打开新数据源
      strDsAlias = Left$(strDsAlias, InStrRev(strDsAlias, ".") - 1)
      
      '请查看您的数据源，如果数据源类型为SDB请修改打开时的seEngineType
      Set objDS = SuperWorkspace1.OpenDataSource(strDsFileName, strDsAlias, sceSDBPlus, False)
      If objDS Is Nothing Then
            MsgBox "打开数据源文件错误！", vbInformation
      Else
            '添加数据源到浏览器中
            TreeView1.Nodes.Add "WORKSPACE", tvwChild, strDsAlias, strDsAlias, 8, 9
            
            For i = 1 To objDS.Datasets.Count
                  '分类添加数据集到浏览器中
                  Select Case objDS.Datasets(i).Type
                        Case scdPoint
                              FrmSave.TreeView1.Nodes.Add strDsAlias, tvwChild, , objDS.Datasets.Item(i).Name, 4
                        Case scdLine
                              FrmSave.TreeView1.Nodes.Add strDsAlias, tvwChild, , objDS.Datasets.Item(i).Name, 5
                        Case scdRegion
                              FrmSave.TreeView1.Nodes.Add strDsAlias, tvwChild, , objDS.Datasets.Item(i).Name, 6
                        Case scdText
                              FrmSave.TreeView1.Nodes.Add strDsAlias, tvwChild, , objDS.Datasets.Item(i).Name, 7
                        Case scdNetwork
                              FrmSave.TreeView1.Nodes.Add strDsAlias, tvwChild, , objDS.Datasets.Item(i).Name, 10
                        Case scdGrid
                              FrmSave.TreeView1.Nodes.Add strDsAlias, tvwChild, , objDS.Datasets.Item(i).Name, 14
                        Case scdImage
                              FrmSave.TreeView1.Nodes.Add strDsAlias, tvwChild, , objDS.Datasets.Item(i).Name, 16
                        Case scdTIN
                              FrmSave.TreeView1.Nodes.Add strDsAlias, tvwChild, , objDS.Datasets.Item(i).Name, 17
                        Case scdDEM
                              FrmSave.TreeView1.Nodes.Add strDsAlias, tvwChild, , objDS.Datasets.Item(i).Name, 15
                        Case scdCAD
                              FrmSave.TreeView1.Nodes.Add strDsAlias, tvwChild, , objDS.Datasets.Item(i).Name, 12
                        Case scdECW
                              FrmSave.TreeView1.Nodes.Add strDsAlias, tvwChild, , objDS.Datasets.Item(i).Name, 11
                        Case scdMrSID
                              FrmSave.TreeView1.Nodes.Add strDsAlias, tvwChild, , objDS.Datasets.Item(i).Name, 13
                        Case Else
                              FrmSave.TreeView1.Nodes.Add strDsAlias, tvwChild, , objDS.Datasets.Item(i).Name, 3
                  End Select
            Next
            '展开树状浏览器
            TreeView1.Nodes(1).Expanded = True
            TreeView1.Nodes(2).Expanded = True
      End If
      
      Set objDS = Nothing
End Sub

Private Sub btnPan_Click()
      SuperMap1.Action = scaPan        '漫游
End Sub

Private Sub btnSaveWorkspace_Click()
      '判断工作空间是否是第一次存盘
      Dim strWkspName As String
      
      strWkspName = Me.SuperWorkspace1.GetWorkspaceName()
      If (strWkspName) <> "" Then     '已经存过盘
            SuperWorkspace1.Save
      Else                            '第一次存盘
            btnSaveAsWorkspace_Click
      End If
End Sub

Private Sub btnSaveAsWorkspace_Click()
      '工作空件另存为....
      Dim strWorkspaceName As String
      Dim nRespond As Integer
      
      '获取工作空间名
      cmlFile.CancelError = False
      cmlFile.DialogTitle = "工作空间另存为"
      cmlFile.Filter = "SuperMap 工作空间文件(*.smw)|*.smw"
      cmlFile.InitDir = App.Path
      cmlFile.FileName = ""
      cmlFile.Flags = cdlOFNOverwritePrompt
      cmlFile.ShowSave
      
      If (Trim$(cmlFile.FileName) = "") Then Exit Sub
      strWorkspaceName = Trim$(cmlFile.FileName)
       '判断文件是否存在,是否覆盖
      SuperWorkspace1.SaveAs strWorkspaceName, False, False

End Sub

Private Sub btnSaveMap_Click()
      '保存地图对象
      Dim i As Integer
      Dim bResult As Boolean
      Dim bExist As Boolean
      Dim strMapName As String
      Dim objMaps As soMaps
      
      Set objMaps = FrmSave.SuperWorkspace1.Maps
      If objMaps Is Nothing Then
            MsgBox objError.LastErrorMsg, vbInformation
            Exit Sub
      End If
      Do
            strMapName = Trim$(InputBox(vbCrLf & "请输入地图名称:", "保存地图"))
            If (strMapName) = "" Then Exit Sub
            '判断重名
            bExist = False
            For i = 1 To objMaps.Count
                  If UCase$(objMaps.Item(i)) = UCase$(strMapName) Then
                        MsgBox "地图名称已被使用，请重新命名！", vbInformation
                        bExist = True
                        Exit For
                  End If
            Next
            If bExist = False Then Exit Do
      Loop
      bResult = FrmSave.SuperMap1.SaveMapAs(strMapName)
      If bResult Then
            FrmSave.Caption = strMapName
            lstMaps.AddItem strMapName
      Else
            MsgBox "地图保存失败!", vbInformation
      End If
      
      Set objMaps = Nothing
End Sub

Private Sub btnSaveAsMap_Click()
      '地图另存为....
      Dim bExist As Boolean                     '是否重名的标志，=True时重名。
      Dim bResult As Boolean
      Dim strMapName As String
      Dim i As Long
      Dim objMaps As soMaps

      If FrmSave.SuperMap1.Visible = True Then
            Set objMaps = FrmSave.SuperWorkspace1.Maps
            If objMaps Is Nothing Then
                  MsgBox "内部错误，无法继续!", vbInformation
                  Exit Sub
            End If
            '接收地图名的输入,并判断是否重名
            Do
                  strMapName = Trim$(InputBox(vbCrLf & "请输入地图名称:", "保存地图"))
                  If (strMapName) = "" Then Exit Sub
                  '判断地图是否重名
                  bExist = False
                  For i = 1 To objMaps.Count
                        If UCase$(objMaps.Item(i)) = UCase$(strMapName) Then
                              MsgBox "地图名称已被使用，请重新命名！", vbInformation
                              bExist = True
                              Exit For
                        End If
                  Next
                  If bExist = False Then Exit Do
            Loop
              
            bResult = FrmSave.SuperMap1.SaveMapAs(strMapName)
            If bResult Then
                  FrmSave.lstMaps.AddItem strMapName
                  FrmSave.Caption = strMapName
            Else
                  MsgBox "地图保存失败!", vbInformation
            End If
      End If

      Set objMaps = Nothing
End Sub

Private Sub btnOpenWorkspace_Click()
      Dim DS As soDataSource
      Dim objMaps As soMaps
      Dim strWorkspaceName As String   '工作空间文件名
      Dim nDtCount As Integer
      Dim strDtName As String
      Dim i As Integer
        
            
      '从公用对话框获取  FileName
      FrmSave.cmlFile.CancelError = False
       With FrmSave.cmlFile
            .DialogTitle = "打开原有工作空间"
            .Filter = "SuperMap WorkSpaceFile (*.smw)|*.smw"
            .Flags = cdlOFNFileMustExist
            .InitDir = App.Path
            .FileName = ""
            .ShowOpen
            If Trim$(.FileName) = "" Then           '用户选择Cancel后，.FileName 必等于空
                  Exit Sub
            End If
      End With
      strWorkspaceName = FrmSave.cmlFile.FileName
      
      btnCloseWorkspace_Click                       '关闭原工作空间
      
      '判断打开结果
      If Not FrmSave.SuperWorkspace1.Open(strWorkspaceName) Then         '打开失败
            MsgBox objError.LastErrorMsg, vbInformation
            Exit Sub