modsub.bas

地理信息系统工程案例精选程序,本书所有案例均需要单独配置

Attribute VB_Name = "modRefreshTools"
Option Explicit

Public Sub RemoveAllRelation()

Dim lpLayer As Long
On Error Resume Next
For lpLayer = 0 To frmMain.Map1.Layers.Count - 1
    
    frmMain.Map1.Layers(lpLayer).RemoveRelates
    DoEvents
Next lpLayer

End Sub
Public Sub AddAllRelation()
Dim lpLayer As Long
Dim LayerX As MapLayer
On Error Resume Next
For lpLayer = 0 To frmMain.Map1.Layers.Count - 1
    Set LayerX = frmMain.Map1.Layers(lpLayer)
    Call RefreshRelation(LayerX)
Next lpLayer

End Sub
Public Sub RefreshRelation(LayerX As MapLayer)

Dim TableX As Table
Dim lpointer As Long
Dim b As Boolean
Dim strToField As String
Dim strFromField As String

With CustomLayers(NameToIndex(LayerX.Name))

    For lpointer = 0 To .RelationCount - 1
        Set TableX = New Table
        If UCase(Right(.Relation(lpointer).Table, 3)) = "DBF" Then
            TableX.Database = "FoxPro 2.6;database=" & .Relation(lpointer).Database
            TableX.Name = Left(.Relation(lpointer).Table, Len(.Relation(lpointer).Table) - 4)
        Else
            TableX.Database = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & .Relation(lpointer).Database
            TableX.Name = .Relation(lpointer).Table
        End If
        If .Relation(lpointer).ToField = "" Then
            strToField = "SID"
        Else
            strToField = .Relation(lpointer).ToField
        End If
        If .Relation(lpointer).FromField = "" Then
            strFromField = "SID"
        Else
            strFromField = .Relation(lpointer).FromField
        End If
        
        b = LayerX.AddRelate(strToField, TableX, strFromField, True)
    
    Next lpointer

End With

End Sub
Public Sub refreshTree()

'清除TreeView中已有的节点
frmLayer.treeLayer.Nodes.Clear

Dim lpLayerGroup As Long
Dim lpLayer As Long
Dim LayerX As MapLayer

Dim NodeX As Node


With frmLayer.treeLayer.Nodes
    For lpLayerGroup = 1 To LayerGroupCount - 1
        '根据图层分组信息生成分组图例
        If lpLayerGroup = 1 Then
            '若添加的是第一个节点，则直接添加
            Set NodeX = .Add
        Else
            '添加到上一个分组节点的平级位置
            Set NodeX = .Add("!Group!" & LayerGroup(lpLayerGroup - 1).strGroupName, tvwNext)
        End If
        
        NodeX.text = LayerGroup(lpLayerGroup).strGroupName
        '以!Group!开头的TreeView节点表示图层分组节点
        NodeX.Key = "!Group!" & LayerGroup(lpLayerGroup).strGroupName
        '分组图标预置于ImageList中
        NodeX.Image = "!Group!"
        NodeX.Checked = True
        
        '将属于分组的图层添加到分组节点下，作为其子节点
        For lpLayer = 0 To LayerGroup(lpLayerGroup).lLayerCount - 1
    
            If CustomLayers(LayerGroup(lpLayerGroup).lLayerIndex(lpLayer)).bVisibleInTreeview Then
                Set LayerX = frmMain.Map1.Layers(LayerGroup(lpLayerGroup).lLayerIndex(lpLayer))
                '作为分组节点的子节点
                Set NodeX = .Add("!Group!" & LayerGroup(lpLayerGroup).strGroupName, tvwChild)
                NodeX.Key = CustomLayers(LayerGroup(lpLayerGroup).lLayerIndex(lpLayer)).strName
                NodeX.text = CustomLayers(LayerGroup(lpLayerGroup).lLayerIndex(lpLayer)).strName
                '生成图标
                fnGenerateIcon NodeX.Key, LayerX
                '图层图标来自上一句生成于ImageList中的图标
                NodeX.Image = NodeX.Key
                '根据图层初始可视程决定节点前CheckBox状态
                NodeX.Checked = LayerX.Visible
                
            End If
        Next lpLayer
    Next lpLayerGroup
End With

'将分组节点前的CheckBox状态置为Checked
For Each NodeX In frmLayer.treeLayer.Nodes
    If Left(NodeX.Key, 7) = "!Group!" Then
        NodeX.Checked = True
    Else
        NodeX.Checked = frmMain.Map1.Layers(NameToIndex(NodeX.Key)).Visible
    End If
Next

'刷新图例TreeView
frmLayer.treeLayer.Refresh
End Sub
Public Function NameToIndex(strName As String) As Long

'---------------------------------------------------
'子程序:NameToIndex
'功能:根据图层的地图名寻找图层索引
'参数:strName----图层的地图名
'返回值:图层的索引
'---------------------------------------------------
Dim lpointer As Long
For lpointer = 0 To CustomLayerCount - 1
    If CustomLayers(lpointer).strName = strName Then
        NameToIndex = lpointer
        Exit Function
    End If
Next lpointer
NameToIndex = -1

End Function
Public Function NameToGroupIndex(strName As String) As Long
Dim lpointer As Long
For lpointer = 0 To LayerGroupCount - 1
    If LayerGroup(lpointer).strGroupName = strName Then
        NameToGroupIndex = lpointer
        Exit Function
    End If
Next lpointer
NameToGroupIndex = -1
End Function
Public Function VerifyDatabase(DRelation As CusRelations) As Boolean
'验证一个Relation中数据库的有效性
On Error GoTo VerErr

Dim TableX As New Table
TableX.Database = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DRelation.Database
TableX.Name = DRelation.Table

Dim lpointer As Long

For lpointer = 0 To TableX.Records.TableDesc.FieldCount - 1
    If TableX.Records.TableDesc.FieldName(lpointer) = DRelation.ToField Then Exit For
Next lpointer

If lpointer > TableX.Records.TableDesc.FieldCount - 1 Then
    VerifyDatabase = False
Else
    VerifyDatabase = True
End If
Exit Function
VerErr:
VerifyDatabase = False
End Function
Public Function bIsExcept(strField As String, Index As Long) As Boolean

'判断字段是否是被屏蔽而无需显示的字段

Dim lpointer As Long
With CustomLayers(Index)
    For lpointer = 0 To .HideFieldCount - 1
        If strField = .HideField(lpointer) Then Exit For
    Next

    If lpointer > .HideFieldCount - 1 And UCase(strField) <> "ID" And Len(Trim(strField)) <> 0 Then
        bIsExcept = False
    Else
        bIsExcept = True
    End If
End With
    
End Function
Public Function bHasMultiRelation(Index As Long) As Boolean

If CustomLayers(Index).MultiRelate.Database = "" Or CustomLayers(Index).MultiRelate.Table = "" Then
    bHasMultiRelation = False
Else
    bHasMultiRelation = True
End If

End Function
Public Function GetLayerIndex(strIncluding As String) As Long
Dim lpLayer As Long
For lpLayer = 0 To CustomLayerCount - 1
    If InStr(1, CustomLayers(lpLayer).strName, strIncluding) > 0 Then
        Exit For
    End If
Next lpLayer
If lpLayer >= CustomLayerCount Then
    GetLayerIndex = 0
Else
    GetLayerIndex = lpLayer
End If

End Function
Public Function GetZDLayer() As MapObjects2.MapLayer

'获取监测点图层
Set GetZDLayer = frmMain.Map1.Layers(GetLayerIndex("监测点"))

End Function
Public Function GetJBJLayer() As MapObjects2.MapLayer

'获取级别价图层
Set GetJBJLayer = frmMain.Map1.Layers(GetLayerIndex("级别价"))

End Function