frmlayerset.frm

来自「都是基于VB所做的程序集合,值得大家作为实践的参考资料.」· FRM 代码 · 共 579 行 · 第 1/2 页

    nlistItemCount = Me.lvLayersInfo.ListItems.Count        '图层数
    '设置图层参数
    For i = 1 To nlistItemCount
        '显示
        objlayers.Item(i).Visible = TextToBoolean(Me.lvLayersInfo.ListItems(i).SubItems(1))
        '选择
        objlayers.Item(i).Selectable = TextToBoolean(Me.lvLayersInfo.ListItems(i).SubItems(2))
        '编辑
        If Me.lvLayersInfo.ListItems(i).SubItems(3) = "Y" Then
              iLayerIndex = i
        End If
        '捕捉
        objlayers.Item(i).Snapable = TextToBoolean(Me.lvLayersInfo.ListItems(i).SubItems(4))
    Next
    
    If iLayerIndex = 0 Then
        objlayers.SetEditableLayer 0
    Else
        objlayers.SetEditableLayer iLayerIndex
    End If
    
    frmMain.SuperMap1.Refresh
    Unload Me
End Sub

Private Sub Form_Load()
    Dim i As Integer, ilayerCount As Integer    '图层数目
    Dim objLayer As soLayer           '图层对象
    Dim objlayers As solayers
    
    Set objlayers = frmMain.SuperMap1.Layers
    ilayerCount = objlayers.Count
    
    '获取各个图层信息并添加到ListView
    lvLayersInfo.ListItems.Clear
    For i = 1 To ilayerCount
        Set objLayer = objlayers.Item(i)
        If objLayer Is Nothing Then
            MsgBox "图层" & i & "内部错误，无法继续！", vbInformation
        Else
            '设置显示内容
            If objLayer.Dataset.Vector = True Then '这里仅示范管理矢量数据集
                With Me.lvLayersInfo
                    .ListItems.Add , , objLayer.Name
                    .ListItems(i).SubItems(1) = BooleanToText(objLayer.Visible)
                    .ListItems(i).SubItems(2) = BooleanToText(objLayer.Selectable)
                    .ListItems(i).SubItems(3) = BooleanToText(objLayer.Editable)
                    .ListItems(i).SubItems(4) = BooleanToText(objLayer.Snapable)
                    
                    '设置ToolTipHelp
                    .ListItems(i).ListSubItems(1).ToolTipText = "显示"
                    .ListItems(i).ListSubItems(2).ToolTipText = "选择"
                    .ListItems(i).ListSubItems(3).ToolTipText = "编辑"
                    .ListItems(i).ListSubItems(4).ToolTipText = "捕捉"
                End With
            End If
        End If
    Next
End Sub

'设置Y、N标记
Private Sub lvLayersInfo_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim strLayerName As String
    Dim objDs As soDataSource
    Dim i As Integer, j As Integer, iLayerIndex As Integer
    Dim ilayerCount As Integer
    
    If Button = vbLeftButton Then
        If (Me.lvLayersInfo.SelectedItem Is Nothing) Then Exit Sub
        
        '得到鼠标当前位置上选中的是第几个图层
        ilayerCount = frmMain.SuperMap1.Layers.Count
        For i = 1 To ilayerCount
            strLayerName = frmMain.SuperMap1.Layers.Item(i).Name
            j = Len(lvLayersInfo.SelectedItem.Text)
            If Left$(strLayerName, j) = lvLayersInfo.SelectedItem.Text Then
                iLayerIndex = i
                Exit For
            End If
        Next
        
        For i = 1 To lvLayersInfo.ColumnHeaders.Count
            If X > GetCollumRange(i).XStart And X < GetCollumRange(i).XEnd Then
                '根据选择的列进行处理
                Select Case i
                    Case 2:   '选择
                        'Visible=True时其他项可用；Visible=False时不可用
                        If Me.lvLayersInfo.SelectedItem.SubItems(1) = "Y" Then
                            Me.lvLayersInfo.SelectedItem.SubItems(1) = " "
                            For j = 2 To 4
                                Me.lvLayersInfo.SelectedItem.SubItems(j) = " "
                            Next j
                        Else
                            Me.lvLayersInfo.SelectedItem.SubItems(1) = "Y"
                        End If
                    Case 3:   '选择(可见才可选)
                        If Me.lvLayersInfo.SelectedItem.SubItems(1) = "Y" Then
                            If Me.lvLayersInfo.SelectedItem.SubItems(2) = "Y" Then
                                Me.lvLayersInfo.SelectedItem.SubItems(2) = ""
                                Me.lvLayersInfo.SelectedItem.SubItems(3) = ""
                            Else
                                Me.lvLayersInfo.SelectedItem.SubItems(2) = "Y"
                            End If
                        End If
            
                    Case 4:   '编辑(同一时间只能有一个图层可编辑. 图层可视、可选择才能编辑。)
                        If Me.lvLayersInfo.SelectedItem.SubItems(1) <> "Y" Then Exit For        '不可见
                        If Me.lvLayersInfo.SelectedItem.SubItems(2) <> "Y" Then Exit For        '不可选
                        
                        Set objDs = frmMain.SuperWorkspace1.Datasources.Item(Mid$(strLayerName, InStr(strLayerName, "@") + 1))
                        If objDs.ReadOnly = True Then
                            MsgBox "数据源只读打开，不能编辑!", vbCritical
                            Exit For
                        End If
                        
                        '设置其余图层为不可编辑
                        For j = 1 To Me.lvLayersInfo.ListItems.Count
                            If lvLayersInfo.ListItems(j).Text <> lvLayersInfo.SelectedItem.Text Then
                                lvLayersInfo.ListItems(j).SubItems(3) = ""
                            End If
                        Next
                        If Me.lvLayersInfo.SelectedItem.SubItems(3) = "Y" Then
                            Me.lvLayersInfo.SelectedItem.SubItems(3) = ""
                        Else
                            Me.lvLayersInfo.SelectedItem.SubItems(3) = "Y"
                        End If
                    Case 5:   ' 捕捉
                        If Me.lvLayersInfo.SelectedItem.SubItems(4) = "Y" Then
                            Me.lvLayersInfo.SelectedItem.SubItems(4) = " "
                        Else
                            Me.lvLayersInfo.SelectedItem.SubItems(4) = "Y"
                        End If
                End Select
            End If
        Next i
    End If
End Sub

Private Sub tlbLayerSet_ButtonClick(ByVal Button As MSComctlLib.Button)
    Dim strExchange As String
    Dim iIndex As Integer
    Dim i As Integer
    Dim j As Integer
    Dim strItemText(0 To 12) As String
    Dim objlayers As solayers
    
    Set objlayers = frmMain.SuperMap1.Layers
    
    Select Case Button.Key
        Case "DeleteLayer":
            If Not (Me.lvLayersInfo.SelectedItem Is Nothing) Then
                objlayers.Remove Me.lvLayersInfo.SelectedItem.Index, 1
                frmMain.SuperMap1.Refresh
                Me.lvLayersInfo.ListItems.Remove lvLayersInfo.SelectedItem.Index
            End If
    
        Case "LayerStyle":
            '图层设置
            Dim nLayerIndex As Integer
            If (Me.lvLayersInfo.SelectedItem Is Nothing) Then
                Exit Sub
            Else
                nLayerIndex = Me.lvLayersInfo.SelectedItem.Index
            End If
            If nLayerIndex > 0 Then
                Dim Style As soStyle
                Dim Map As SuperMap
                Dim nDimension As Long
                
                Set Map = frmMain.SuperMap1
                Set Style = Map.Layers.Item(nLayerIndex).Style
                nDimension = Map.Layers.Item(nLayerIndex).Dataset.Dimension
                If Map.ShowStylePicker(Style, nDimension) = True Then
                    Map.Refresh
                End If
            End If
        Case "MoveToTop":     '上移图层到顶
            iIndex = 0
            If (Me.lvLayersInfo.SelectedItem Is Nothing) Then
                Exit Sub
            Else
                iIndex = Me.lvLayersInfo.SelectedItem.Index
            End If
            If iIndex > 1 Then
                objlayers.MoveTop iIndex
                strItemText(0) = Me.lvLayersInfo.ListItems(iIndex).Text
                For i = 1 To 4
                    strItemText(i) = Me.lvLayersInfo.ListItems(iIndex).SubItems(i)
                Next i
                For i = iIndex To 2 Step -1
                    Me.lvLayersInfo.ListItems(i).Text = Me.lvLayersInfo.ListItems(i - 1).Text
                    For j = 1 To 4
                        Me.lvLayersInfo.ListItems(i).SubItems(j) = Me.lvLayersInfo.ListItems(i - 1).SubItems(j)
                    Next j
                Next i
                Me.lvLayersInfo.ListItems(1).Text = strItemText(0)
                For i = 1 To 4
                    Me.lvLayersInfo.ListItems(1).SubItems(i) = strItemText(i)
                Next i
            End If
            
            Set Me.lvLayersInfo.SelectedItem = Me.lvLayersInfo.ListItems(1)
            frmMain.SuperMap1.Refresh
        Case "MoveUp":     '上移图层
            iIndex = 0
            If (Me.lvLayersInfo.SelectedItem Is Nothing) Then
                Exit Sub
            Else
                iIndex = Me.lvLayersInfo.SelectedItem.Index
            End If
            If iIndex > 1 Then
                objlayers.MoveUp iIndex
                strExchange = Me.lvLayersInfo.ListItems(iIndex - 1).Text
                Me.lvLayersInfo.ListItems(iIndex - 1).Text = Me.lvLayersInfo.SelectedItem.Text
                Me.lvLayersInfo.SelectedItem.Text = strExchange
                For j = 1 To 4
                    strExchange = Me.lvLayersInfo.ListItems(iIndex - 1).SubItems(j)
                    Me.lvLayersInfo.ListItems(iIndex - 1).SubItems(j) = Me.lvLayersInfo.SelectedItem.SubItems(j)
                    Me.lvLayersInfo.SelectedItem.SubItems(j) = strExchange
                Next j
                Set Me.lvLayersInfo.SelectedItem = Me.lvLayersInfo.ListItems(iIndex - 1)
            End If
            frmMain.SuperMap1.Refresh
        Case "MoveDown":    '下移图层
            iIndex = 0
            If (Me.lvLayersInfo.SelectedItem Is Nothing) Then
                Exit Sub
            Else
                iIndex = Me.lvLayersInfo.SelectedItem.Index
            End If
            If iIndex < Me.lvLayersInfo.ListItems.Count Then
                objlayers.MoveDown iIndex
                strExchange = Me.lvLayersInfo.ListItems(iIndex + 1).Text
                Me.lvLayersInfo.ListItems(iIndex + 1).Text = Me.lvLayersInfo.SelectedItem.Text
                Me.lvLayersInfo.SelectedItem.Text = strExchange
                For j = 1 To 4
                    strExchange = Me.lvLayersInfo.ListItems(iIndex + 1).SubItems(j)
                    Me.lvLayersInfo.ListItems(iIndex + 1).SubItems(j) = Me.lvLayersInfo.SelectedItem.SubItems(j)
                    Me.lvLayersInfo.SelectedItem.SubItems(j) = strExchange
                Next j
                Set Me.lvLayersInfo.SelectedItem = Me.lvLayersInfo.ListItems(iIndex + 1)
            End If
            frmMain.SuperMap1.Refresh
        Case "MoveToBottom":   '下移图层到底
            iIndex = 0
            If (Me.lvLayersInfo.SelectedItem Is Nothing) Then
                Exit Sub
            Else
                iIndex = Me.lvLayersInfo.SelectedItem.Index
            End If
            
            Dim nLastIndex As Integer
            
            nLastIndex = Me.lvLayersInfo.ListItems.Count
            If iIndex < nLastIndex Then
                objlayers.MoveBottom iIndex
                strItemText(0) = Me.lvLayersInfo.ListItems(iIndex).Text
                For i = 1 To 4
                    strItemText(i) = Me.lvLayersInfo.ListItems(iIndex).SubItems(i)
                Next i
                For i = iIndex To nLastIndex - 1
                    Me.lvLayersInfo.ListItems(i).Text = Me.lvLayersInfo.ListItems(i + 1).Text
                    For j = 1 To 4
                        Me.lvLayersInfo.ListItems(i).SubItems(j) = Me.lvLayersInfo.ListItems(i + 1).SubItems(j)
                    Next j
                Next i
                Me.lvLayersInfo.ListItems(nLastIndex).Text = strItemText(0)
                For i = 1 To 4
                    Me.lvLayersInfo.ListItems(nLastIndex).SubItems(i) = strItemText(i)
                Next i
                Set Me.lvLayersInfo.SelectedItem = Me.lvLayersInfo.ListItems(nLastIndex)
            End If
            frmMain.SuperMap1.Refresh
        Case Else:
    End Select
End Sub
Private Function GetCollumRange(ByVal iCollumIndex As Integer) As XRange
    '===========================
    '自定义函数检测鼠标点击的位置
    '===========================
    Dim i As Integer
    
    GetCollumRange.XStart = lvLayersInfo.Left
    For i = 1 To iCollumIndex
        GetCollumRange.XStart = GetCollumRange.XEnd
        GetCollumRange.XEnd = GetCollumRange.XEnd + lvLayersInfo.ColumnHeaders(i).Width
    Next
End Function