?? vba10-1.txt
字號:
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
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -