AOSample.doc

在ArcMap中，进行属性查询的时候，Arcmap中提供了选中字段的属性的Unique Value。这样就可以从列表中选择了。以前也遇到类似问题，一直不知道怎么做，好在当时使用的ArcSDE Oracle数据，使用了一个SQL语句解决了。不过要是Coverage就没有办法了。其实AO中提供了这样的功能了，可通过IDataStatistics来实现，做了一个函数，参数为图层和字段，返回该图层该字段的所有Unique Value
1.'下面程序段是用来列出ArcMap中,指定图层和字段中,所有Unique Value
Public Function listUniqueValue(pLayer As IFeatureLayer, pFieldName As String) As String()
　Dim pCursor As ICursor
　Set pCursor = pLayer.Search(Nothing, False)
　Dim pDataStat As IDataStatistics
　Dim pValue As Variant
　Set pDataStat = New DataStatistics
　pDataStat.Field = pFieldName
　Set pDataStat.Cursor = pCursor
　Dim pEnumVar As IEnumVariantSimple
　Set pEnumVar = pDataStat.UniqueValues
　pValue = pEnumVar.Next
　Dim i As Long
　'Dim count As Long
　'count = pDataStat.UniqueValueCount
　i = 0
　Dim value(200) As String　'数组的长度按说应该使用pDataStat.UniqueValueCount来控制，但是编译只能使用
　　　　　　　　　　　　　　'常数,不能使用变量
　Do Until IsEmpty(pValue)
　　value(i) = pValue
　　i = i + 1
　　pValue = pEnumVar.Next
　Loop
　listUniqueValue = value()
End Function
2.打开图层属性表　(ArcMap VBA)

'下面程序段是用来列出ArcMap中,指定图层和字段中,所有Unique Value
Public Sub OpenFeatureLayerTable()
Dim pMxDoc As IMxDocument
Dim pMap As IMap
Dim pLayer As IFeatureLayer
Dim pTable As ITableWindow
Set pMxDoc = ThisDocument
Set pMap = pMxDoc.FocusMap
Set pLayer = pMap.Layer(0)
'Instantiate the Table window
Set pTable = New TableWindow
'Associate the table and a feature layer
Set pTable.FeatureLayer = pLayer
Set pTable.Application = Application
'Open the table
pTable.Show True
End Sub

3.AO中加载SDE中的Raster数据　(ArcMap VBA/VB AO)

Public Function GetRasterFromSDE(sServer As String, sInstance As String, _
sUser As String, sPassword As String, sSDERaster As String, Optional version As String = "SDE.DEFAULT") As IRasterDataset　　　'加载栅格函数
' sServer,sInstance,sDB,sUser,sPasswd: ArcSDE connection info
' sSDERaster: the ArcSDE raster dataset name
Dim pSDEWs As IWorkspaceName
Dim pSDEPropertySet As IPropertySet
Dim pSDERasterDataset As IRasterDataset
Dim pDsName As IDatasetName
Dim pName As IName
' Dim sQualifiedName As String
' Get connection propertyset
Set pSDEPropertySet = New PropertySet
With pSDEPropertySet
　.SetProperty "Server", sServer
　.SetProperty "Instance", sInstance
　' .SetProperty "Database", sDB
　.SetProperty "User", sUser
　.SetProperty "Password", sPassword
　.SetProperty "Version", version
End With
' Get workspacename
Set pSDEWs = New WorkspaceName
pSDEWs.ConnectionProperties = pSDEPropertySet
pSDEWs.WorkspaceFactoryProgID = "esricore.sdeworkspacefactory"
' Get raster dataset name
Set pDsName = New RasterDatasetName
pDsName.Name = sSDERaster
Set pDsName.WorkspaceName = pSDEWs
Set pName = pDsName
' Open ArcSDE raster dataset
Set pSDERasterDataset = pName.Open
' Cleanup
Set GetRasterFromSDE = pSDERasterDataset
Set pSDEWs = Nothing
Set pSDERasterDataset = Nothing
Set pSDEPropertySet = Nothing
Set pName = Nothing
Set pDsName = Nothing
End Function
4.AO中直接加载ArcSDE矢量数据
Public Function addSDEData(Server As String, Instance As String, User As String, _
　Password As String, featureClass As String, Optional version As String = "SDE.DEFAULT")
　On Error GoTo EH
　Dim pWorkspaceFactory As IWorkspaceFactory
　Dim pWorkspace As IFeatureWorkspace
　Dim pPropSet As IPropertySet
　Dim pClass As IFeatureClass
　Dim pLayer As IFeatureLayer
　Dim pMxDoc As IMxDocument
　Set pWorkspaceFactory = New SdeWorkspaceFactory
　Set pPropSet = New PropertySet
　With pPropSet '设置ArcSDE连接属性
　　.SetProperty "SERVER", Server
　　.SetProperty "INSTANCE", Instance
　　.SetProperty "USER", User
　　.SetProperty "PASSWORD", Password
　　.SetProperty "VERSION", version '可选，缺省为SDE.DEFAULT版本
　End With
　Set pWorkspace = pWorkspaceFactory.Open(pPropSet, 0)
　Set pClass = pWorkspace.OpenFeatureClass(featureClass)
　Set pLayer = New FeatureLayer
　Set pLayer.featureClass = pClass
　pLayer.Name = pClass.AliasName

　Set pMxDoc = ThisDocument
　pMxDoc.AddLayer pLayer
　pMxDoc.ActiveView.PartialRefresh esriViewGeography, pLayer, Noting
　Exit Function
EH:
　MsgBox Err.Description, vbInformation, "加载数据错误"
End Function
5.对选中要素进行属性统计

Public Sub SumSelectedFeatures()
Dim pMxDoc As IMxDocument
Dim pmap As IMap
Dim player As IFeatureLayer
Dim pFcc As IFeatureClass
Dim pFields As IFields
Dim pNumFields As IFields
Dim numAreaField As Double
Dim pField As IField
Set pMxDoc = ThisDocument
Set pmap = pMxDoc.FocusMap
Set player = pmap.Layer(0)
Set pFcc = player.FeatureClass
Set pFields = pFcc.Fields
'Get a field to Sum
Set pNumFields = pFields
numAreaField = pFields.FindField("pop1997") ' <--Enter a field here
'Check for a valid field index number
If numAreaField < 0 Then
MsgBox "Please enter a Valid field name", vbCritical, "Field Doesn't Exist"
Exit Sub
End If
Set pField = pFields.Field(numAreaField)
'***Other useful field stuff***
'.FindField("AREA")
'MsgBox numAreaField
'MsgBox pField.Name
'MsgBox pFields.FieldCount
'MsgBox player.Name
'Get the selected records
Dim pFeatureSelection As IFeatureSelection
Set pFeatureSelection = player
Dim pSelected As ISelectionSet
Set pSelected = pFeatureSelection.SelectionSet
Dim pCursor As ICursor
pSelected.Search Nothing, False, pCursor
Dim pfeature As IFeature
Dim counter As Integer
counter = 0
Dim sumAREA As Double
sumAREA = 0
Set pfeature = pCursor.NextRow
Do Until pfeature Is Nothing
counter = counter + 1
sumAREA = sumAREA + pfeature.Value(numAreaField)
Set pfeature = pCursor.NextRow
Loop
MsgBox "Total " & pField.Name & " is: " & sumAREA
'MsgBox counter & " Selected records"
End Sub
6.在ArcMap LayOut中增加文字
Private pMxApp As IMxApplication
Private pMxDoc As IMxDocument
Private pDisp As IScreenDisplay
Private pEnv As IEnvelope
Private pPoint As IPoint
Private pColor As IRgbColor
Private pLayout As IPageLayout
Private pMapSurround As IMapSurround
Private pNSurround As INorthArrow
Private pGContainer As IGraphicsContainer
Private pEnumLayer As IEnumLayer
Private pFLayer As ILayer
Private pBLayer As ILayer
Public Sub AddTextToLayout()
'Button to place text on the layout
'
'Reference App, Doc, Disp, Layout, and GraphicContainer
Set pMxApp = Application
Set pMxDoc = Document
Set pDisp = pMxApp.Display
Set pLayout = pMxDoc.ActiveView
Set pGContainer = pLayout
'Create a TextElement
Dim pTxtElement As ITextElement
Set pTxtElement = New TextElement
'Create a TextSymbol and a font
Dim pTxtSym As ITextSymbol
Set pTxtSym = New TextSymbol
Dim pFont As IFontDisp
Set pFont = New StdType.StdFont
'Set some properties of the font
pFont.Name = "Courier"
pFont.Bold = True
pFont.Italic = True
pFont.Size = 30
'Set the TextSymbol's FONT property with the font
pTxtSym.Font = pFont
'Set the TextElement's SYMBOL property with the TextSymbol
'Set the TextElement's TEXT property with the desired text
pTxtElement.Symbol = pTxtSym
pTxtElement.Text = "This is a test"
'Create an Envelope to define the TextElement's GEOMETRY
'Create a Point to define the Envelope's LL and UR (extent)
Set pEnv = New Envelope
Set pPoint = New Point
pPoint.x = 2 'first define LL coords
pPoint.y = 8 '<--these are page units
pEnv.LowerLeft = pPoint
pPoint.x = 7 'now define UR coords
pPoint.y = 10
pEnv.UpperRight = pPoint
'Create a pointer to the IElement interface, QI
Dim pElement As IElement
Set pElement = pTxtElement
'Set the Element's GEOMETRY property with the Envelope
pElement.Geometry = pEnv
'Prepare display for drawing (Activate), AddElement to the
'GraphicsContainer, then Draw
pElement.Activate pDisp '<-without this, BAD things happen!
pGContainer.AddElement pElement, 1
pMxDoc.ActiveView.Refresh
End Sub
7.VB+AO增加shapefile数据

Private Sub Form_Load()
Dim pWorkspaceFactory As IWorkspaceFactory
Dim pWorkspace As IFeatureWorkspace
Dim pFClass As IFeatureClass
Dim pLayer As IFeatureLayer
Set pWorkspaceFactory = New ShapefileWorkspaceFactory
'获取目录
Set pWorkspace = pWorkspaceFactory.OpenFromFile("D:\data\", 0)
'获取shapefile名
Set pFClass = pWorkspace.OpenFeatureClass("result")
Set pLayer = New FeatureLayer
Set pLayer.FeatureClass = pFClass
MapControl1.AddLayer pLayer
MapControl1.Refresh
End Sub

8.VBA增加Raster数据

Public Sub AddRasterLayer()
Dim pMxDocument As IMxDocument
Dim pMap As IMap
Dim pLayer As IRasterLayer
Dim pWF As IWorkspaceFactory
Dim pW As IWorkspace
Dim pFW As IRasterWorkspace
Dim pDataset As IDataset
Dim pRDataset As IRasterDataset
Set pWF = New RasterWorkspaceFactory
'Enter path to workspace that contains your grid
Set pW = pWF.OpenFromFile("C:\data")
'QI
Set pFW = pW
'Enter Name of Grid folder
Set pRDataset = pFW.OpenRasterDataset("LakeDepth")
'Use the grid to create a raster layer
Dim pRLayer As IRasterLayer
Set pRLayer = New RasterLayer
pRLayer.CreateFromDataset pRDataset
'Add the raster layer to a map
Set pMxDocument = ThisDocument
Set pMap = pMxDocument.FocusMap
pMxDocument.AddLayer pRLayer
'Set the layer name
'Set the display extent
End Sub

9.Merge Layer (VB+AO)

'兔八哥以前写的，现在也放这吧
Public Function Merge(pathLayer1 As String, pathLayer2 As String, pathMergeResult As String, _
nameLayer1 As String, nameLayer2 As String, nameMergeResult As String)
' 分别读取图层一,图层二到FeatureClass和Table中
Dim pWorkspaceFactory As IWorkspaceFactory
Dim pWorkspace1 As IFeatureWorkspace
Dim pWorkspace2 As IFeatureWorkspace
Dim pFirstFeatClass As IFeatureClass
Dim pSecondFeatClass As IFeatureClass
Dim pFirstTable As ITable
Dim pSecondTable As ITable
Dim pFeatLayer1 As IFeatureLayer
Set pFeatLayer1 = New FeatureLayer
Dim pFeatLayer2 As IFeatureLayer
Set pFeatLayer2 = New FeatureLayer
Set pWorkspaceFactory = New ShapefileWorkspaceFactory
Set pWorkspace1 = pWorkspaceFactory.OpenFromFile(pathLayer1, 0)
Set pWorkspace2 = pWorkspaceFactory.OpenFromFile(pathLayer2, 0)
Set pFirstFeatClass = pWorkspace1.OpenFeatureClass(nameLayer1)
Set pSecondFeatClass = pWorkspace2.OpenFeatureClass(nameLayer2)
Set pFeatLayer1.FeatureClass = pFirstFeatClass
Set pFirstTable = pFeatLayer1
Set pFeatLayer2.FeatureClass = pSecondFeatClass
Set pSecondTable = pFeatLayer2
' 检查错误
If pFirstTable Is Nothing Then
　MsgBox "Table QI failed"
　Exit Function
End If
If pSecondTable Is Nothing Then
　MsgBox "Table QI failed"
　Exit Function
End If
' 定义输出要素类名称和shape类型
Dim pFeatClassName As IFeatureClassName
Set pFeatClassName = New FeatureClassName
With pFeatClassName
.FeatureType = esriFTSimple
.ShapeFieldName = "Shape"
.ShapeType = pFirstFeatClass.ShapeType
End With
' 定义输出shapefile位置与名称
Dim pNewWSName As IWorkspaceName
Set pNewWSName = New WorkspaceName
With pNewWSName
.WorkspaceFactoryProgID = "esriCore.ShapefileWorkspaceFactory"
.PathName = pathMergeResult
End With
Dim pDatasetName As IDatasetName
Set pDatasetName = pFeatClassName
pDatasetName.Name = nameMergeResult
Set pDatasetName.WorkspaceName = pNewWSName
' 定义Merge参数
Dim inputArray As IArray
Set inputArray = New esriCore.Array
inputArray.Add pFirstTable
inputArray.Add pSecondTable
' 进行Merge操作
Dim pBGP As IBasicGeoprocessor
Set pBGP = New BasicGeoprocessor
Dim pOutputFeatClass As IFeatureClass
Set pOutputFeatClass = pBGP.Merge(inputArray, pFirstTable, pFeatClassName)
End Function

10.GraphicsLayer中增加一个点

Public Sub AddPointToGraphicsLayer()
Dim pMxDoc As IMxDocument
Set pMxDoc = ThisDocument
Dim pMxApp As IMxApplication
Set pMxApp = Application
Dim pMap As IMap
Set pMap = pMxDoc.FocusMap
'Instantiate the composite graphics layer
Dim pCGLayer As ICompositeGraphicsLayer
Set pCGLayer = New CompositeGraphicsLayer
'QI for ILayer to set the layer's name
Dim pLayer As ILayer
Set pLayer = pCGLayer
pLayer.Name = "TestPoint"
'Add the layer to the map
pMap.AddLayer pCGLayer
'Set some x and y values or read them from somewhere
Dim x As Double
Dim y As Double
x = 200
y = 200
'Make a point
Dim pPnt As IPoint
Set pPnt = New Point
pPnt.x = x
pPnt.y = y
'Set color and symbol for the point, Blue
Dim pColor As IRgbColor
Set pColor = New RgbColor
pColor.Blue = 255
pColor.Green = 0
pColor.Red = 0
Dim pSimpleMarkerSymbol As ISimpleMarkerSymbol
Set pSimpleMarkerSymbol = New SimpleMarkerSymbol
With pSimpleMarkerSymbol
.Style = esriSMSCircle
.Size = 4
.Color = pColor
End With
'Create a marker element
Dim pMarkerElement As IMarkerElement
Set pMarkerElement = New MarkerElement
pMarkerElement.Symbol = pSimpleMarkerSymbol
Dim pElement As IElement
Set pElement = pMarkerElement
pElement.Geometry = pPnt
'Get the graphics layer and screen display
Dim pGrLayer As IGraphicsLayer
Set pGrLayer = pCGLayer
Dim pScreenDisplay As IScreenDisplay
Set pScreenDisplay = pMxApp.Display
'Add the marker element ot the layer graphics container
Dim pGraphicCont As IGraphicsContainer
Set pGraphicCont = pGrLayer
pGraphicCont.AddElement pMarkerElement, 0
With pScreenDisplay
.ActiveCache = 0
.StartDrawing pScreenDisplay.hDC, 0
.SetSymbol pSimpleMarkerSymbol
pElement.Draw pScreenDisplay, Nothing
.FinishDrawing
End With
'Refresh/redraw the display with the new point
pMxDoc.ActiveView.Refresh
End Sub
11. 对ArcMap显示区域大小进行缩放

'本例用来对ArcMap显示区域进行放达2倍,修改2为你需要的放大比例
Private Sub UIButtonControl1_Click()
　　Dim pMxApp As IMxApplication
　　Dim pMxDoc As IMxDocument
　　Dim pDisp As IScreenDisplay
　　Dim pPoint As IPoint
　　Dim pCenterPoint As IPoint
　　'获得当前Display
　　Set pMxApp = Application
　　Set pDisp = pMxApp.Display
　　Set pMxDoc = Document
　　'获取当前显示区域
　　Dim pCurrentEnv As IEnvelope
　　Dim pEnv As IEnvelope
　　Set pCurrentEnv = pMxDoc.ActiveView.Extent.Envelope
　　Set pEnv = pMxDoc.ActiveView.Extent.Envelope
　　'设置显示范围为当前的1/2
　　pEnv.Height = pCurrentEnv.Height / 2
　　pEnv.Width = pCurrentEnv.Width / 2
　　'设置新的显示区域的中心为原来显示区域中心
　　Set pPoint = New Point
　　Set pCenterPoint = New Point
　　pCenterPoint.X = pCurrentEnv.LowerLeft.X + pCurrentEnv.Width / 2
　　pCenterPoint.Y = pCurrentEnv.LowerLeft.Y + pCurrentEnv.Height / 2
　　pEnv.CenterAt pCenterPoint
　　'设置视图显示区域
　　pMxDoc.ActiveView.Extent = pEnv
　　pMxDoc.ActiveView.Refresh
End Sub
12. 复制一个FeatureClass

'复制一个FeatureClass
Public Function hCopyFC(ByVal myinstr As String, ByVal myoutstr As String) As Boolean
　Dim hOUTshwsname As IWorkspaceName
　Dim hOutshDSName As IDatasetName
　Dim hInWorkspaceName As IWorkspaceName
　Dim hDatasetName As IDatasetName
　Dim htoshape As IFeatureDataConverter
　Dim htname As IFeatureClassName
　Dim houttname As IFeatureClassName
　Set hInWorkspaceName = New WorkspaceName
　hInWorkspaceName.PathName = strdir + "\template\template.mdb" '数据模板
　hInWorkspaceName.WorkspaceFactoryProgID = "esriCore.AccessWorkspaceFactory.1"
　Set htname = New FeatureClassName
　Set hDatasetName = htname
　Set hDatasetName.WorkspaceName = hInWorkspaceName
　hDatasetName.Name = myinstr
　Set hOUTshwsname = New WorkspaceName
　hOUTshwsname.PathName = strpathname '当前数据路径
　hOUTshwsname.WorkspaceFactoryProgID = "esriCore.AccessWorkspaceFactory.1"
　Set houttname = New FeatureClassName
　Set hOutshDSName = h