vba10-1.txt

一个基于ARCGIS的VBA开发代码,本人用它做过很多VBA开发,非常不错!

Option Explicit
Global g_pStateLayer As IFeatureLayer
Global g_pCountyLayer As IFeatureLayer
Global g_pTractLayer As IFeatureLayer


Public Sub Tutorial()
    ' This procedure is called when user clicks on the
    ' customized button
    '
    ' (1) Edit the following constants to match your 
    '     environment
    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"
    '
    ' (2) Load the shape files if necessary
    Dim pLayer As IFeatureLayer
    ' State shape file
    Set pLayer = GetLayer(c_strStateLayerName)
    If pLayer Is Nothing Then
        Set pLayer = AddShapeFile(c_strDataPath, _
        c_strStateFileName, c_strStateLayerName)
        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
    ' County shape file
    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
        ' Make county invisible
        pLayer.Visible = False
    End If
    Set g_pCountyLayer = pLayer
    ' Census tract shape file
    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
        ' Make tract invisible
        pLayer.Visible = False
    End If
    Set g_pTractLayer = pLayer
    '
    ' (3) Display the user interface form and populate 
    '     its combo boxes
    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