frmmain.frm

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

'         5、在地图窗口选择好要闪烁的对象，点击"闪烁"按钮，这些对象会自动同时闪烁。
'
'===================================SuperMap Objects示范工程说明结束=====================================
'功能介绍：
'批量闪烁类模块的使用:
'         1、定义一个模块级的类变量：如 Dim Blink As New clsBlink。注意一定要使用New关键字
'         2、在"闪烁"按钮代码中，设置好类的属性。具体参见类模块的定义
'         3、在Timer1_Timer事件中调用类模块的闪烁方法：Blink.OnStartBlink即可
'==================================================================================================

Option Explicit
Dim Blink As New clsBlink

Public Function PathToName(ByVal strPath As String) As String
'=====================================================
'自定义函数,将文件全路径名转化为文件名(无路径名,无扩展名)
'=====================================================
      Dim nLength As Integer      '字符串长度
      Dim i As Integer
      Dim strTemp As String
      Dim strTemp1 As String
      Dim nPosition As Integer
      
      nPosition = 999
      If InStr(strPath, ".") <> 0 Then
            strTemp = Left(strPath, Len(strPath) - 4)
      Else
            strTemp = strPath
      End If
      
      nLength = Len(strTemp)
      For i = Len(strPath) To 1 Step -1
               If Mid$(strTemp, i, 1) = "\" Then
                     nPosition = i
                     Exit For
               End If
      Next
       If nPosition = 999 Then
            PathToName = strTemp
       Else
            PathToName = Right(strTemp, nLength - nPosition)
       End If
End Function

Private Sub btnOpenDataSource_Click()
      '打开数据源
      Dim objDS As soDataSource         '定义数据源变量
      Dim strDsName As String           '定义数据源名称变量
      Dim strDsAlias As String          '定义数据源别名变量
      Dim objDt As soDataset            '定义数据集变量
      
      SuperMap1.Layers.RemoveAll
      SuperMap1.Refresh
      Me.SuperWorkspace1.Datasources.RemoveAll
      Me.tvwWKS.Nodes.Clear
      tvwWKS.Nodes.Add , tvwFirst, "workspace", "工作空间", 1
      
      With cdl
            .DialogTitle = "打开数据源文件"
            .CancelError = False
            .Filter = "SuperMap数据源文件(*.sdb)|*.sdb"
            .Flags = cdlOFNFileMustExist
            .InitDir = App.Path & "\..\data"
            .FileName = ""
            .ShowOpen
            If .FileName <> "" Then
                  strDsName = .FileName
            Else
                  Exit Sub
            End If
      End With
      
      strDsAlias = PathToName(strDsName)
      Set objDS = Me.SuperWorkspace1.OpenDataSource(strDsName, strDsAlias, sceSDB, False)
      If objDS Is Nothing Then
            MsgBox "数据源打开失败！", vbInformation
      Else
            objDS.DistanceUnits = scuMeter
            objDS.Commit
            '添加数据源到tvwWKS浏览器中
            Me.tvwWKS.Nodes.Add "workspace", tvwChild, "A" & strDsAlias, strDsAlias, 8, 2
            '添加数据集到tvwWKS浏览器中
            For Each objDt In objDS.Datasets
                  If objDt.Type = scdPoint Then
                        frmMain.tvwWKS.Nodes.Add "A" & frmMain.SuperWorkspace1.Datasources(1).Alias, tvwChild, , objDt.Name, 4
                  ElseIf objDt.Type = scdLine Then
                        frmMain.tvwWKS.Nodes.Add "A" & frmMain.SuperWorkspace1.Datasources(1).Alias, tvwChild, , objDt.Name, 5
                  ElseIf objDt.Type = scdRegion Then
                        frmMain.tvwWKS.Nodes.Add "A" & frmMain.SuperWorkspace1.Datasources(1).Alias, tvwChild, , objDt.Name, 9
                  ElseIf objDt.Type = scdText Then
                        frmMain.tvwWKS.Nodes.Add "A" & frmMain.SuperWorkspace1.Datasources(1).Alias, tvwChild, , objDt.Name, 7
                  ElseIf objDt.Type = scdECW Then
                        frmMain.tvwWKS.Nodes.Add "A" & frmMain.SuperWorkspace1.Datasources(1).Alias, tvwChild, , objDt.Name, 10
                  ElseIf objDt.Type = scdMrSID Then
                        frmMain.tvwWKS.Nodes.Add "A" & frmMain.SuperWorkspace1.Datasources(1).Alias, tvwChild, , objDt.Name, 11
                  End If
            Next
            '展开tvwWKS
            Me.tvwWKS.Nodes(1).Expanded = True
            Me.tvwWKS.Nodes("A" & objDS.Alias).Expanded = True
        End If
      '释放内存
      Set objDS = Nothing
      Set objDt = Nothing
End Sub

Private Sub btnSelectCircle_Click()
      SuperMap1.Action = scaCircleSelect    '圆形选择
End Sub

Private Sub btnSelectRect_Click()
      SuperMap1.Action = scaRectSelect      '矩形选择
End Sub

Private Sub btnZoomFree_Click()
      SuperMap1.Action = scaZoomFree        '自由缩放
End Sub

Private Sub btnClearLayers_Click()          '清除图层
      SuperMap1.Layers.RemoveAll
      SuperMap1.Action = scaNull
      SuperMap1.Refresh
      Timer1.Enabled = False
      btnBlink.Enabled = False
      btnClearLayers.Enabled = False
End Sub

Private Sub btnDelDataset_Click()
      '删除数据集
      If tvwWKS.Nodes.Count <= 1 Then Exit Sub
      If tvwWKS.SelectedItem Is Nothing Then Exit Sub
      If tvwWKS.SelectedItem.Text = "工作空间" Then Exit Sub
      If tvwWKS.SelectedItem.Parent.Text = "工作空间" Then Exit Sub
      If MsgBox("试图删除数据集" & tvwWKS.SelectedItem.Text & vbCrLf & "此操作不可恢复，确定吗？", vbYesNo + vbQuestion + vbDefaultButton2) = vbNo Then Exit Sub
      
      Dim objDS As soDataSource
      Dim strDtName As String
      Dim strLayerName As String
      
      strDtName = Me.tvwWKS.SelectedItem.Text
      strLayerName = strDtName & "@" & Me.tvwWKS.SelectedItem.Parent.Text
      If Not (SuperMap1.Layers(strLayerName) Is Nothing) Then
            SuperMap1.Layers.RemoveAll
            SuperMap1.Refresh
      End If
      Set objDS = SuperWorkspace1.Datasources(1)
      If objDS Is Nothing Then
            MsgBox "错误！", vbInformation
      Else
            If objDS.DeleteDataset(strDtName) Then
                  Me.tvwWKS.Nodes.Remove Me.tvwWKS.SelectedItem.Index
            End If
      End If
      
      Set objDS = Nothing
End Sub

Private Sub btnOpenDataset_Click()  '打开数据集
      Dim objDS As soDataSource     '定义数据源变量
      Dim objDt As soDataset        '定义数据集变量
      Dim strDtName As String       '定义数据源别名变量
      Dim i As Integer              '定义循环变量
      
      If tvwWKS.Nodes.Count <= 1 Then Exit Sub
      If tvwWKS.SelectedItem Is Nothing Then Exit Sub
      If tvwWKS.SelectedItem.Text = "工作空间" Then Exit Sub
      If tvwWKS.SelectedItem.Parent.Text = "工作空间" Then Exit Sub
      
      strDtName = Me.tvwWKS.SelectedItem.Text
      Set objDS = SuperWorkspace1.Datasources(1)
      If objDS Is Nothing Then
            MsgBox "错误！", vbInformation
            Exit Sub
      Else
            Set objDt = objDS.Datasets(strDtName)
            If objDt Is Nothing Then
                  MsgBox "错误！", vbInformation
                  Exit Sub
            End If
      End If
      
      SuperMap1.Layers.AddDataset objDt, False
      If SuperMap1.Layers.Count > 0 Then
            SuperMap1.Refresh
            btnClearLayers.Enabled = True
      Else
            MsgBox "打开数据集失败！", vbCritical
      End If
      
     Set objDS = Nothing
     Set objDt = Nothing
End Sub

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

Private Sub btnRefresh_Click()
      SuperMap1.Refresh                 '刷新
End Sub

Private Sub btnSelect_Click()
      If SuperMap1.Layers.Count < 1 Then Exit Sub
      SuperMap1.Action = scaSelect      '选择
End Sub

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

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

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

Private Sub btnClearTrack_Click()
      SuperMap1.TrackingLayer.ClearEvents
      SuperMap1.selection.RemoveAll
      Timer1.Enabled = False
      btnBlink.Enabled = False
      SuperMap1.Refresh
End Sub

Private Sub btnBlink_Click()            '批量闪烁
      Dim objRecordset As soRecordset
      Dim objStyle As New soStyle
      
      With objStyle
            .BrushColor = vbBlue
            .PenColor = vbBlue
            .PenWidth = 8
            .SymbolSize = 100
      End With
      Set objRecordset = Me.SuperMap1.selection.ToRecordset(True)
      
      Set Blink.ctrSuperMap = Me.SuperMap1
      Set Blink.ctrTimer = Me.Timer1
      Set Blink.objStyle = objStyle
      Set Blink.objRecordset = objRecordset
      Blink.Initialize
      Blink.dStartTime = Timer()
      Me.Timer1.Enabled = True
End Sub

Private Sub Form_Load()
      SuperMap1.Connect SuperWorkspace1.Object                       '装载窗体，建立连接
      tvwWKS.Nodes.Add , tvwFirst, "workspace", "工作空间", 1     '初始化tvwWKS和SuperMap1
      SuperMap1.MarginPanEnable = False
      SuperMap1.Action = scaSelect
End Sub

Private Sub Form_Unload(Cancel As Integer)
    SuperMap1.Close
    SuperMap1.Disconnect
    SuperWorkspace1.Close
End Sub

Private Sub SuperMap1_GeometrySelected(ByVal nSelectedGeometryCount As Long)
      btnBlink.Enabled = True
End Sub

Private Sub SuperMap1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
      If SuperMap1.selection.Count < 1 Then btnBlink.Enabled = False
End Sub

Private Sub Timer1_Timer()
      Blink.OnStartBlink
End Sub

Private Sub tvwWKS_DblClick()
      btnOpenDataset_Click
End Sub

Private Sub tvwWKS_NodeClick(ByVal Node As MSComctlLib.Node)
      If Node.Index > 2 Then
            btnDelDataset.Enabled = True
            btnOpenDataset.Enabled = True
      Else
            btnDelDataset.Enabled = False
            btnOpenDataset.Enabled = False
      End If
End Sub