vba10-1.txt

ao的一些代码集合

Option Explicit
Global g_pStateLayer As IFeatureLayer    '要素层
Global g_pCountyLayer As IFeatureLayer    '要素层
Global g_pTractLayer As IFeatureLayer    '要素层


Public Sub Tutorial()
    '当用户点击定制的按钮时调用此事件
    '编辑以下内容来和你的使用环境相符
    Const c_strDataPath = "E:\arcgis\arcdata\cd3\usa\"
    Const c_strStateFileName = "dtl_st.shp"
    Const c_strStateLayerName = "State"
    Const c_strCountyFileName = "dtl_cnty.shp"
    Const c_strCountyLayerName = "County"
    Const c_strTractFileName = "tracts.shp"
    Const c_strTractLayerName = "Census Tract"
    
    '必要的话，加载shape文件
    Dim pLayer As IFeatureLayer    '要素层

    '州shape文件
    Set pLayer = GetLayer(c_strStateLayerName)    '调用GetLayer函数获取图层
    If pLayer Is Nothing Then    '如果图层不存在
        Set pLayer = AddShapeFile(c_strDataPath, c_strStateFileName, c_strStateLayerName)    '调用AddShapeFile函数添加图层
        If pLayer Is Nothing Then    '如果图层不存在
            MsgBox "Unable to locate " & c_strDataPath & c_strStateFileName & " shape file."    '报错
            Exit Sub
        End If
    End If
    Set g_pStateLayer = pLayer    '获取州图层

    '郡shape文件
    Set pLayer = GetLayer(c_strCountyLayerName)
    If pLayer Is Nothing Then
        Set pLayer = AddShapeFile(c_strDataPath, c_strCountyFileName, c_strCountyLayerName)
        If pLayer Is Nothing Then
            MsgBox "Unable to locate " & c_strDataPath & c_strCountyFileName & " shape file."
            Exit Sub
        End If
        '使郡不可见
        pLayer.Visible = False
    End If
    Set g_pCountyLayer = pLayer    '获取郡图层

    '地方人口普查shape文件
    Set pLayer = GetLayer(c_strTractLayerName)
    If pLayer Is Nothing Then
        Set pLayer = AddShapeFile(c_strDataPath, c_strTractFileName, c_strTractLayerName)
        If pLayer Is Nothing Then
            MsgBox "Unable to locate " & c_strDataPath & _
            c_strTractFileName & " shape file."
            Exit Sub
        End If
        '使这些地域不可见
        pLayer.Visible = False
    End If
    Set g_pTractLayer = pLayer    '获取地域图层
    
    '显示用户界面窗口并装入组合框
    frmClassify.PopulateClassCountCombo
    frmClassify.PopulateClassificationCombo
    frmClassify.PopulateStateCombo
    frmClassify.Show
End Sub

Private Function GetLayer(strLayerName As String) As IFeatureLayer
    ' This function accepts a layer name and returns
    ' the layer if available, otherwise returns "Nothing".
    '
    ' (1) Access the document's map
    Dim pMxDoc As IMxDocument
    Dim pMap As IMap
    Set pMxDoc = Application.Document
    Set pMap = pMxDoc.FocusMap
    '
    ' (2) Search through layers for the given layer name
    Dim lngIndex As Long
    Set GetLayer = Nothing
    For lngIndex = 0 To pMap.LayerCount - 1
        If pMap.Layer(lngIndex).Name = strLayerName Then
            Set GetLayer = pMap.Layer(lngIndex)
            Exit For
        End If
    Next lngIndex
End Function

Private Function AddShapeFile(strPath As String, _
strFile As String, strName As String) As IFeatureLayer
    ' This function adds the specified shapefile and 
    ' returns the layer. It returns "Nothing" if not 
    ' successful.
    '
    ' (1) Make sure the shape file exist
    If Len(Dir(strPath & strFile)) = 0 Then
        ' File does not exist
        Set AddShapeFile = Nothing
        Exit Function
    End If
    '
    ' (2) Create a workspace to represent the datasource
    Dim pWorkspaceFactory As IWorkspaceFactory
    Dim pFeatureWorkspace As IFeatureWorkspace
    Set pWorkspaceFactory = New ShapefileWorkspaceFactory
    Set pFeatureWorkspace = _
    pWorkspaceFactory.OpenFromFile(strPath, 0)
    '
    ' (3) Access the shape file through a feature layer
    Dim pClass As IFeatureClass
    Dim pFeatureLayer As IFeatureLayer
    Set pClass = pFeatureWorkspace.OpenFeatureClass(strFile)
    Set pFeatureLayer = New FeatureLayer
    Set pFeatureLayer.FeatureClass = pClass
    pFeatureLayer.Name = strName
    '
    ' (4) Add layer to the map
    Dim pMxDoc As IMxDocument
    Dim pMap As IMap
    Set pMxDoc = Application.Document
    Set pMap = pMxDoc.FocusMap
    pMap.AddLayer pFeatureLayer
    Set AddShapeFile = pFeatureLayer
End Function