ArcObject常用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