frmbatchblink.frm

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

'===================================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 iPosition As Integer
    
    iPosition = 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
            iPosition = i
            Exit For
        End If
    Next
    If iPosition = 999 Then
        PathToName = strTemp
    Else
        PathToName = Right(strTemp, nLength - iPosition)
    End If
End Function

Private Sub btnOpenDataSource_Click() '打开数据源
    Dim objDS As soDataSource         '定义数据源变量
    Dim strDsName As String           '定义数据源名称变量
    Dim strDsAlias As String          '定义数据源别名变量
    Dim objDt As soDataset            '定义数据集变量
    
    With cdl
        .DialogTitle = "打开数据源文件"
        .CancelError = False
        .Filter = "SuperMap数据源文件(*.sdb)|*.sdb"
        .Flags = cdlOFNFileMustExist
        .InitDir = App.Path
        .FileName = ""
        .ShowOpen
        If .FileName <> "" Then
            strDsName = .FileName
        Else
            Exit Sub
        End If
    End With
    
    strDsAlias = PathToName(strDsName)
    Set objDS = Me.SuperWorkspace1.OpenDataSource(strDsName, strDsAlias, sceSDBPlus, False)
    If objDS Is Nothing Then
        MsgBox "数据源打开失败！", vbInformation
    Else
        '添加数据源到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" & strDsAlias, tvwChild, , objDt.Name, 4
            ElseIf objDt.Type = scdLine Then
            frmMain.tvwWKS.Nodes.Add "A" & strDsAlias, tvwChild, , objDt.Name, 5
            ElseIf objDt.Type = scdRegion Then
            frmMain.tvwWKS.Nodes.Add "A" & strDsAlias, tvwChild, , objDt.Name, 9
            ElseIf objDt.Type = scdText Then
            frmMain.tvwWKS.Nodes.Add "A" & strDsAlias, tvwChild, , objDt.Name, 7
            ElseIf objDt.Type = scdECW Then
            frmMain.tvwWKS.Nodes.Add "A" & strDsAlias, tvwChild, , objDt.Name, 10
            ElseIf objDt.Type = scdMrSID Then
            frmMain.tvwWKS.Nodes.Add "A" & strDsAlias, tvwChild, , objDt.Name, 11
            End If
        Next
        '展开tvwWKS
        Me.tvwWKS.Nodes(1).Expanded = True
        Me.tvwWKS.Nodes("A" & objDS.Alias).Expanded = True
    End If
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() '删除数据集
    Dim strDtName As String
    
    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
    
    '判断如果当前闪烁的对象在要删除的数据集上，则暂时不允许删除
    If Timer1.Enabled = True Then
        If Blink.strDtName = strDtName Then
            MsgBox "当前闪烁的对象在要删除的数据集上，暂时不可以删除"
            Exit Sub
        End If
    End If
    
    If MsgBox("试图删除数据集" & tvwWKS.SelectedItem.Text & vbCrLf & "此操作不可恢复，确定吗？", vbYesNo + vbQuestion + vbDefaultButton2) = vbNo Then Exit Sub
    
    Dim objDS As soDataSource
    Dim strLayerName As String
    Dim strDsAlias As String
    
    strDsAlias = tvwWKS.SelectedItem.Parent.Text
    strLayerName = strDtName & "@" & strDsAlias '图层的命名规则是“数据集名称@数据源别名”
    If Not (SuperMap1.Layers(strLayerName) Is Nothing) Then
        SuperMap1.Layers.RemoveAt strLayerName
        SuperMap1.Refresh
    End If
    Set objDS = SuperWorkspace1.Datasources(strDsAlias)
    If objDS Is Nothing Then
        MsgBox "未能正确得到数据源", vbInformation
    Else
        If objDS.DeleteDataset(strDtName) Then
            Me.tvwWKS.Nodes.Remove tvwWKS.SelectedItem.Index
        End If
    End If
End Sub

Private Sub btnOpenDataset_Click()  '打开数据集
    Dim objDS As soDataSource     '定义数据源变量
    Dim objDt As soDataset        '定义数据集变量
    Dim strDsName As String       '定义数据源别名变量
    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 = tvwWKS.SelectedItem.Text
    strDsName = tvwWKS.SelectedItem.Parent.Text
    Set objDS = SuperWorkspace1.Datasources(strDsName)
    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
        If SuperMap1.TrackingLayer.EventCount > 0 Then
            SuperMap1.TrackingLayer.ClearEvents
        End If
        
        SuperMap1.Refresh
        btnClearLayers.Enabled = True
    Else
        MsgBox "打开数据集失败", vbCritical
    End If
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()            '批量闪烁，调用模块clsBlink
    Dim objRecordset As soRecordset
    Dim objStyle As New soStyle
    
    With objStyle
        .BrushColor = vbBlue
        .PenColor = vbGreen
        .BrushBackTransparent = True
        .BrushStyle = 2
    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.strDtName = SuperMap1.selection.Dataset.Name
    Blink.Initialize   '初始化闪烁模块，准备闪烁
    Blink.dStartTime = Timer()
    Me.Timer1.Enabled = True
    
    Set objStyle = Nothing
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) '断开连接，退出程序
    If Timer1.Enabled = True Then Timer1.Enabled = False
    If Not Blink Is Nothing Then Set Blink = Nothing
    
    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() '开启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