modfileoperate.bas

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

Attribute VB_Name = "modFileOperate"

Public Sub AssertAllTool()

If bIsConfig Then
    frmMain.abProMap.Bands("barFile").Visible = False
Else
    frmMain.abProMap.Bands("barFile").Visible = True
End If

End Sub

Public Function fnLoadProjectFile(strFileName As String) As Boolean

'判断指定配置文件是否存在
If Dir(strFileName) = "" Then
    '文件不存在,读入失败
    fnLoadProjectFile = False
    Exit Function
End If

'从文件中读出的字符串
Dim Readline As String
'当前HideField数量
Dim lpExcept As Long

'地图数据连接
Dim ConnectionX As MapObjects2.DataConnection
'将要加入地图中的图层
Dim LayerX As MapObjects2.MapLayer
'将要加入鹰眼窗口中的图层
Dim LayerOVx As MapObjects2.MapLayer

Dim Value1 As String
Dim Value2 As String
Dim Value3 As String
Dim Value4 As String
Dim Value5 As String
Dim Value6 As String
Dim lpClass As Long
Dim stringx As New MapObjects2.Strings
Dim FontX As New StdFont
Dim lpGroup As Long

'初始化
lpLayer = -1
lpGroupCount = -1
LayerGroupCount = 1

'变量名
Dim strKeyword As String
'属性值
Dim strValue As String
'临时变量，用于标示readline中"="的位置
Dim lSeek As Long

Open strFileName For Input As #1

Do Until EOF(1)
    
    Line Input #1, Readline
    
    GetKeyAndValue Readline, strKeyword, strValue
    
    '对关键字分类处理
    strKeyword = UCase(strKeyword)
    Select Case strKeyword
        '当前工程名
        Case "PROJECTTITLE"
            '工程名
            frmMain.Caption = strValue
        Case "SCALEBAR"
            '比例尺
            frmMain.FraZoom.Visible = fnJudgeTrue(strValue)
            frmMain.abProMap.Bands("mnuView").Tools("miVRuler").Visible _
                = fnJudgeTrue(strValue)
        Case "MEASURE"
            '测量工具
            frmMain.abProMap.Bands("mnuMain").Tools("mnuMeasure").Visible _
                = fnJudgeTrue(strValue)
            frmMain.abProMap.Bands("barStandard").Tools("mpMeasure").Visible _
                = fnJudgeTrue(strValue)
        Case "ISDBASE"
            '是否xBase数据
            modDefinition.bIsDbaseDatabase = fnJudgeTrue(strValue)
   
        '图层部分开始
        Case "<LAYER>"
        
            CustomLayerCount = CustomLayerCount + 1
          
            Do Until strKeyword = "</LAYER>" Or EOF(1)
                
                Line Input #1, Readline
                
                GetKeyAndValue Readline, strKeyword, strValue
                Select Case strKeyword
                    Case "</LAYER>"
                        '一个图层结束,将图层加入地图和鹰眼图中
                        If Not CustomLayers(NameToIndex(LayerX.Name) _
                            ).bEditable Then
                            frmLayer.Map2.Layers.Add LayerOVx
                        End If
                        frmMain.Map1.Layers.Add LayerX
                        
                    Case "LAYERPATH"
                        '图层路径指定
                        '连接地图数据库
                        Set ConnectionX = New MapObjects2.DataConnection
                        ConnectionX.Database = fnCompletePath(strValue)
                        CustomLayers(CustomLayerCount - 1).strPath = _
                            fnCompletePath(strValue)
                        If ConnectionX Is Nothing Then Exit Do
                        
                    Case "LAYERNAME"
                        '图层名称
                        LayerX.Name = strValue
                        CustomLayers(CustomLayerCount - 1).strName = strValue
                        
                    Case "LAYERFILENAME"
                        '图层文件名
                        Set LayerX = New MapObjects2.MapLayer
                        Set LayerX.GeoDataset = ConnectionX.FindGeoDataset(strValue)
                        Set LayerOVx = New MapObjects2.MapLayer
                        Set LayerOVx.GeoDataset = ConnectionX.FindGeoDataset(strValue)
                        
                    Case "VISIBLEINTREEVIEW"
                        '在图例中可见
                        CustomLayers(CustomLayerCount - 1).bVisibleInTreeview _
                            = fnJudgeTrue(strValue)
                    Case "VISIBLEINMAINMAP"
                        '在地图中可见
                        LayerX.Visible = fnJudgeTrue(strValue)
                    Case "VISIBLEINOVERALLMAP"
                        '在缩略图中可见
                        LayerOVx.Visible = fnJudgeTrue(strValue)
                    Case "VISIBLEOFLABEL"
                        '文本标注
                        CustomLayers(CustomLayerCount - 1).bVisibleOfLabel _
                            = fnJudgeTrue(strValue)
                        If Not LayerX.Renderer Is Nothing Then
                            If Not CustomLayers(CustomLayerCount - _
                                1).bVisibleOfLabel Then
                                Set LayerX.Renderer = Nothing
                            End If
                        End If
                    Case "ANNOTATIONFIELD"
                        '标注字段
                        Dim RendererX As New LabelRenderer
                        CustomLayers(CustomLayerCount - 1).strLabelField = strValue
                        RendererX.Field = strValue
                        'RendererX.Symbol(0).Font = "宋体"
                        RendererX.Symbol(0).Font.Bold = False
                        Set LayerX.Renderer = RendererX
                    Case "DATAEDITABLE"
                        '数据修改
                        CustomLayers(CustomLayerCount - 1).bEditable _
                            = fnJudgeTrue(strValue)
                    Case "DATAVISIBLE"
                        '数据可视
                        CustomLayers(CustomLayerCount - 1).bVisibleOfData _
                            = fnJudgeTrue(strValue)
                    Case "<SINGLE RELATION>"
                        '数据连接
                        Do Until strKeyword = "</SINGLE RELATION>" Or EOF(1)
                            Line Input #1, Readline
                            
                            GetKeyAndValue Readline, strKeyword, strValue
                            
                            Select Case strKeyword
                                Case "RELATIONDBNAME"
                                    '数据库
                                    CustomLayers(CustomLayerCount - 1).RelationCount = 1
                                    CustomLayers(CustomLayerCount - 1).Relation(0 _
                                        ).Database = fnCompletePath(strValue)
                                Case "RELATIONTABLE"
                                    '表
                                    CustomLayers(CustomLayerCount - 1).Relation(0 _
                                        ).Table = strValue
                                Case "RELATETOFIELD"
                                    '目标键
                                    CustomLayers(CustomLayerCount - 1).Relation(0 _
                                        ).ToField = strValue
                                Case "RELATEFROMFIELD"
                                    '源键
                                    CustomLayers(CustomLayerCount - 1).Relation(0 _
                                        ).FromField = strValue
                            End Select
                        Loop
                    Case "<VALUEMAP RENDERER>"
                        Set LayerX.Renderer = New ValueMapRenderer
                        Dim strValueMap() As String
                        Line Input #1, Readline
                        Readline = Trim(Readline)
                        strValueMap() = Split(Readline, ",")
                        Value1 = strValueMap(0)
                        
                        Value2 = strValueMap(1)
                        Select Case LayerX.shapeType
                            Case moShapeTypeLine
                                LayerX.Renderer.SymbolType = moLineSymbol
                            Case moShapeTypePolygon
                                LayerX.Renderer.SymbolType = moFillSymbol
                            Case Else
                                LayerX.Renderer.SymbolType = moPointSymbol
                        End Select
                        
                        LayerX.Renderer.Field = Value1
                        LayerX.Renderer.ScalingField = Value1
                        
                        If Val(Value2) = 0 Then
                            LayerX.Records.MoveFirst
                            stringx.Clear
                            Do Until LayerX.Records.EOF
                                stringx.Add LayerX.Records.Fields(Value1).ValueAsString
                                LayerX.Records.MoveNext
                                DoEvents
                            Loop
                            LayerX.Renderer.ValueCount = stringx.Count2
                            For lpClass = 0 To stringx.Count2 - 1
                                LayerX.Renderer.Value(lpClass) = stringx(lpClass)
                                LayerX.Symbol(lpClass).Color = Val(stringx(lpClass))
                            Next lpClass
                        Else
                            LayerX.Renderer.ValueCount = CLng(Value2)
                            
                            For lpClass = 0 To CLng(Value2) - 1