modfileoperate.bas

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

                              
                                Line Input #1, Readline
                                Readline = Trim(Readline)
                                strValueMap() = Split(Readline, ",")
                                Value1 = strValueMap(0)
                                Value2 = strValueMap(1)
                                Value3 = strValueMap(2)
                                Value4 = strValueMap(3)
                                Value5 = strValueMap(4)
                              LayerX.Renderer.Value(lpClass) = Trim(Value1)
                              LayerX.Renderer.Symbol(lpClass).Color = Val(Value2)
                              LayerX.Renderer.Symbol(lpClass).Style = Val(Value3)
                              LayerX.Renderer.Symbol(lpClass).Outline = fnJudgeTrue(Value4)
                              LayerX.Renderer.Symbol(lpClass).OutlineColor = Val(Value5)
                            Next lpClass
                        End If
                    Case "<LABEL RENDERER>"
                        Set LayerX.Renderer = New LabelRenderer
                        Set FontX = New StdFont
                        Dim strLabelMap() As String
                        Line Input #1, Readline
                        Readline = Trim(Readline)
                        strLabelMap() = Split(Readline, ",")
                        Value1 = strLabelMap(0)
                        Value2 = strLabelMap(1)
                        Value3 = strLabelMap(2)
                        Value4 = strLabelMap(3)
                        Value5 = strLabelMap(4)
                        LayerX.Renderer.Field = Trim(Value1)
                        LayerX.Renderer.Symbol(0).Color = Val(Value2)
                        FontX.Name = Trim(Value3)
                        LayerX.Renderer.Symbol(0).Height = Val(Value4)
                        FontX.Bold = fnJudgeTrue(Value5)
                        FontX.Italic = fnJudgeTrue(Value6)
                        Set LayerX.Renderer.Symbol(0).Font = FontX
                        LayerX.Renderer.AllowDuplicates = True
                        LayerX.Renderer.DrawBackground = False
                    Case "COLOR"
                        '图层颜色
                        LayerX.Symbol.Color = Val(strValue)
                        LayerOVx.Symbol.Color = Val(strValue)
                    Case "SIZE"
                        '大小
                        LayerX.Symbol.Size = Val(strValue)
                        LayerOVx.Symbol.Size = Val(strValue)
                    Case "PICTUREFIELD"
                        '图片字段
                        CustomLayers(CustomLayerCount - 1).PictureField = Trim(strValue)
                    Case "<HIDE FIELD>"
                        '隐藏字段
                        lpExcept = 0
                        Do Until strKeyword = "</HIDE FIELD>"
                            Line Input #1, Readline
                            Readline = Trim(Readline)
                            GetKeyAndValue Readline, strKeyword, strValue
                            Select Case strKeyword
                                Case "HIDEFIELD"
                                CustomLayers(CustomLayerCount - 1).HideField(lpExcept) _
                                    = Trim(strValue)
                                lpExcept = lpExcept + 1
                            End Select
                        Loop
                        CustomLayers(CustomLayerCount - 1).HideFieldCount = lpExcept
                End Select
            Loop
         
        '一个新的LayerGroup开始
        Case "<LAYER GROUP>"
            LayerGroupCount = LayerGroupCount + 1
            LayerGroup(LayerGroupCount - 1).lLayerCount = 0
            
            Do Until strKeyword = "</LAYER GROUP>" Or EOF(1)
                Line Input #1, Readline
                
                GetKeyAndValue Readline, strKeyword, strValue
                
                Select Case strKeyword
                    Case "GROUPNAME"
                        '图层分组组名
                        LayerGroup(LayerGroupCount - 1).strGroupName = strValue
                    Case "INCLUDELAYER"
                        '包含图层
                        LayerGroup(LayerGroupCount - 1).lLayerCount = _
                            LayerGroup(LayerGroupCount - 1).lLayerCount + 1
                        LayerGroup(LayerGroupCount - 1).llayerName(LayerGroup( _
                            LayerGroupCount - 1).lLayerCount - 1) = strValue
                    Case "</GROUP LAYER>"
                End Select
            Loop
        '隐藏的图层分组
        Case "<HIDEN GROUP>"
            LayerGroup(0).lLayerCount = 0
            LayerGroup(0).strGroupName = "SS"
            Do Until strKeyword = "</LAYER GROUP>" Or EOF(1)
                Line Input #1, Readline
                
                GetKeyAndValue Readline, strKeyword, strValue
                
                Select Case strKeyword
                    Case "GROUPNAME"
                        LayerGroup(0).strGroupName = strValue
                    Case "INCLUDELAYER"
                        LayerGroup(0).lLayerCount = LayerGroup(0).lLayerCount _
                            + 1
                        LayerGroup(0).llayerName(LayerGroup(0).lLayerCount _
                            - 1) = strValue
                    Case "</GROUP LAYER>"
                End Select
            Loop
    End Select
Loop
Close #1

'将图层序列倒转,以适应MO对图层顺序的规定

Dim tmpLayer As CusLayer
For lpLayer = 0 To Fix((CustomLayerCount - 1) / 2)
    tmpLayer = CustomLayers(lpLayer)
    CustomLayers(lpLayer) = CustomLayers(CustomLayerCount - lpLayer - 1)
    CustomLayers(CustomLayerCount - lpLayer - 1) = tmpLayer
Next

'将图层的序号和图层名至于相应图层分组中
For lpGroup = 0 To LayerGroupCount - 1
    For lpLayer = 0 To LayerGroup(lpGroup).lLayerCount - 1
        LayerGroup(lpGroup).lLayerIndex(lpLayer) = _
            NameToIndex(LayerGroup(lpGroup).llayerName(lpLayer))
    Next lpLayer
Next lpGroup

'将数据可视图层名显示在界面上
For lpLayer = 0 To CustomLayerCount - 1
    If CustomLayers(lpLayer).bVisibleOfData Then
        frmMain.abProMap.Bands("barStandard").Tools("cmbWork" _
            ).CBAddItem CustomLayers(lpLayer).strName
    End If
Next lpLayer

frmMain.abProMap.Bands("barStandard").Tools("cmbWork").CBListIndex = 0
frmMain.abProMap.RecalcLayout
'根据图层及其分组信息显示图例
modRefreshTools.refreshTree
'根据数据连接信息刷新数据连接
modRefreshTools.AddAllRelation
'全图显示
frmMain.Map1.Extent = frmMain.Map1.FullExtent
frmLayer.Map2.Extent = frmLayer.Map2.Extent
frmMain.Map1.Refresh
frmLayer.Map2.Refresh

fnLoadProjectFile = True

End Function
Function fnCompletePath(strPath As String)
'从当前路径片断或者相对路径推断出完整的路径
If ProgramPath <> "" Then
    '指定了全局基本路径
    If ProgramPath = "%AppPath%" Then
        '全局基本路径为程序运行路径
        If Len(strPath) < 2 Then
            '路径太短不足以成为绝对路径
            fnCompletePath = App.Path & "\" & strPath
        Else
            If Mid(strPath, 2, 1) = ":" Then
                '路径本身为绝对路径
                fnCompletePath = strPath
            Else
                '路径不是绝对路径
                fnCompletePath = App.Path & " \" & strPath
            End If
        End If
    Else
        '全局基本路径为其他制定路径
        If Len(strPath) < 2 Then
            fnCompletePath = ProgramPath & "\" & strPath
        Else
            If Mid(strPath, 2, 1) = ":" Then
                fnCompletePath = strPath
            Else
                fnCompletePath = ProgramPath & " \" & strPath
            End If
        End If
    End If
Else
    '未指定全局基本路径
    If Len(strPath) < 2 Then
        fnCompletePath = App.Path & "\" & strPath
    Else
        If Mid(strPath, 2, 1) = ":" Then
            fnCompletePath = strPath
        Else
            fnCompletePath = App.Path & "\" & strPath
        End If
    End If
End If
End Function

Function fnJudgeTrue(strText As String) As Boolean
'判断字符串是不是"True"
    If StrConv(strText, vbUpperCase) = StrConv("TRUE", vbUpperCase) Then
        fnJudgeTrue = True
    Else
        fnJudgeTrue = False
    End If
End Function
Public Sub GetKeyAndValue(ByVal Source As String, ByRef Keyword As String, ByRef Value As String)
    Dim lSeek As Long
    Source = Trim(Source)
    lSeek = InStr(1, Source, "=", vbTextCompare)
    
    '从读入的字符串中分解出变量名和值
    If lSeek > 0 Then
        Keyword = Trim(UCase(Mid(Source, 1, lSeek - 1)))
        If lSeek < Len(Source) Then
            Value = Mid(Source, lSeek + 1)
        Else
            Value = ""
        End If
    Else
        Keyword = Trim(UCase(Source))
        Value = ""
    End If
End Sub