1、1在 ArcMap 中，进行属性查询的时候，Arcmap 中提供了选中字段的属性的Unique Value。这样就可以从列表中选择了。以前也遇到类似问题，一直不知道怎么做，好在当时使用的 ArcSDE Oracle 数据，使用了一个 SQL 语句解决了。不过要是 Coverage 就没有办法了。其实 AO 中提供了这样的功能了，可通过 IDataStatistics 来实现，做了一个函数，参数为图层和字段，返回该图层该字段的所有 Unique Value 1.下面程序段是用来列出 ArcMap 中,指定图层和字段中 ,所有Unique Value Public Function listUni
2、queValue(pLayer As IFeatureLayer, pFieldName As String) As String()Dim pCursor As ICursorSet pCursor = pLayer.Search(Nothing, False)Dim pDataStat As IDataStatisticsDim pValue As VariantSet pDataStat = New DataStatisticspDataStat.Field = pFieldNameSet pDataStat.Cursor = pCursorDim pEnumVar As IEnumVa
3、riantSimpleSet pEnumVar = pDataStat.UniqueValuespValue = pEnumVar.NextDim i As LongDim count As Longcount = pDataStat.UniqueValueCounti = 0Dim value(200) As String 数组的长度按说应该使用pDataStat.UniqueValueCount 来控制，但是编译只能使用常数,不能使用变量Do Until IsEmpty(pValue)value(i) = pValuei = i + 1pValue = pEnumVar.NextLoopl
4、istUniqueValue = value()End Function 2.打开图层属性表 (ArcMap VBA)下面程序段是用来列出 ArcMap 中,指定图层和字段中,所有 Unique Value Public Sub OpenFeatureLayerTable() Dim pMxDoc As IMxDocumentDim pMap As IMapDim pLayer As IFeatureLayerDim pTable As ITableWindowSet pMxDoc = ThisDocumentSet pMap = pMxDoc.FocusMapSet pLayer = pMa
5、p.Layer(0)Instantiate the Table windowSet pTable = New TableWindowAssociate the table and a feature layerSet pTable.FeatureLayer = pLayerSet pTable.Application = ApplicationOpen the tablepTable.Show TrueEnd Sub23.AO 中加载 SDE 中的 Raster 数据 (ArcMap VBA/VB AO)Public Function GetRasterFromSDE(sServer As S
6、tring, 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 nameDim pSDEWs As IWorkspaceNameDim pSDEProp
7、ertySet As IPropertySetDim pSDERasterDataset As IRasterDatasetDim pDsName As IDatasetNameDim pName As IName Dim sQualifiedName As String Get connection propertysetSet pSDEPropertySet = New PropertySetWith pSDEPropertySet.SetProperty “Server“, sServer.SetProperty “Instance“, sInstance .SetProperty “D
8、atabase“, sDB.SetProperty “User“, sUser.SetProperty “Password“, sPassword.SetProperty “Version“, versionEnd With Get workspacenameSet pSDEWs = New WorkspaceNamepSDEWs.ConnectionProperties = pSDEPropertySetpSDEWs.WorkspaceFactoryProgID = “esricore.sdeworkspacefactory“ Get raster dataset nameSet pDsNa
9、me = New RasterDatasetNamepDsName.Name = sSDERasterSet pDsName.WorkspaceName = pSDEWsSet pName = pDsName Open ArcSDE raster datasetSet pSDERasterDataset = pName.Open CleanupSet GetRasterFromSDE = pSDERasterDatasetSet pSDEWs = NothingSet pSDERasterDataset = NothingSet pSDEPropertySet = NothingSet pNa
10、me = NothingSet pDsName = NothingEnd Function4.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 EHDim pWorkspaceFactory As IWorkspaceFactoryDim
11、pWorkspace As IFeatureWorkspaceDim pPropSet As IPropertySetDim pClass As IFeatureClassDim pLayer As IFeatureLayerDim pMxDoc As IMxDocument3Set pWorkspaceFactory = New SdeWorkspaceFactorySet pPropSet = New PropertySetWith pPropSet 设置 ArcSDE 连接属性.SetProperty “SERVER“, Server.SetProperty “INSTANCE“, In
12、stance.SetProperty “USER“, User.SetProperty “PASSWORD“, Password.SetProperty “VERSION“, version 可选，缺省为 SDE.DEFAULT 版本End WithSet pWorkspace = pWorkspaceFactory.Open(pPropSet, 0)Set pClass = pWorkspace.OpenFeatureClass(featureClass)Set pLayer = New FeatureLayerSet pLayer.featureClass = pClasspLayer.N
13、ame = pClass.AliasNameSet pMxDoc = ThisDocumentpMxDoc.AddLayer pLayerpMxDoc.ActiveView.PartialRefresh esriViewGeography, pLayer, NotingExit FunctionEH:MsgBox Err.Description, vbInformation, “加载数据错误“End Function5.对选中要素 进行属性统计Public Sub SumSelectedFeatures()Dim pMxDoc As IMxDocumentDim pmap As IMapDim
14、 player As IFeatureLayerDim pFcc As IFeatureClassDim pFields As IFieldsDim pNumFields As IFieldsDim numAreaField As DoubleDim pField As IFieldSet pMxDoc = ThisDocumentSet pmap = pMxDoc.FocusMapSet player = pmap.Layer(0)Set pFcc = player.FeatureClassSet pFields = pFcc.FieldsGet a field to SumSet pNum
15、Fields = pFieldsnumAreaField = pFields.FindField(“pop1997“) -Enter a field hereCheck for a valid field index numberIf numAreaField 0 ThenMsgBox “Please enter a Valid field name“, vbCritical, “Field Doesnt Exist“Exit SubEnd IfSet pField = pFields.Field(numAreaField)*Other useful field stuff*.FindFiel
16、d(“AREA“)MsgBox numAreaFieldMsgBox pField.NameMsgBox pFields.FieldCountMsgBox player.NameGet the selected recordsDim pFeatureSelection As IFeatureSelection4Set pFeatureSelection = playerDim pSelected As ISelectionSetSet pSelected = pFeatureSelection.SelectionSetDim pCursor As ICursorpSelected.Search
17、 Nothing, False, pCursorDim pfeature As IFeatureDim counter As Integercounter = 0Dim sumAREA As DoublesumAREA = 0Set pfeature = pCursor.NextRowDo Until pfeature Is Nothingcounter = counter + 1sumAREA = sumAREA + pfeature.Value(numAreaField)Set pfeature = pCursor.NextRowLoopMsgBox “Total “ & pField.N
18、ame & “ is: “ & sumAREAMsgBox counter & “ Selected records“End Sub 6.在 ArcMap LayOut 中增加文字 Private pMxApp As IMxApplicationPrivate pMxDoc As IMxDocumentPrivate pDisp As IScreenDisplayPrivate pEnv As IEnvelopePrivate pPoint As IPointPrivate pColor As IRgbColorPrivate pLayout As IPageLayoutPrivate pMa
19、pSurround As IMapSurroundPrivate pNSurround As INorthArrowPrivate pGContainer As IGraphicsContainerPrivate pEnumLayer As IEnumLayerPrivate pFLayer As ILayerPrivate pBLayer As ILayer Public Sub AddTextToLayout()Button to place text on the layoutReference App, Doc, Disp, Layout, and GraphicContainerSe
20、t pMxApp = ApplicationSet pMxDoc = DocumentSet pDisp = pMxApp.DisplaySet pLayout = pMxDoc.ActiveViewSet pGContainer = pLayoutCreate a TextElementDim pTxtElement As ITextElementSet pTxtElement = New TextElementCreate a TextSymbol and a fontDim pTxtSym As ITextSymbolSet pTxtSym = New TextSymbolDim pFo
21、nt As IFontDispSet pFont = New StdType.StdFontSet some properties of the fontpFont.Name = “Courier“pFont.Bold = TruepFont.Italic = TruepFont.Size = 30Set the TextSymbols FONT property with the font5pTxtSym.Font = pFontSet the TextElements SYMBOL property with the TextSymbolSet the TextElements TEXT
22、property with the desired textpTxtElement.Symbol = pTxtSympTxtElement.Text = “This is a test“Create an Envelope to define the TextElements GEOMETRYCreate a Point to define the Envelopes LL and UR (extent)Set pEnv = New EnvelopeSet pPoint = New PointpPoint.x = 2 first define LL coordspPoint.y = 8 -th
23、ese are page unitspEnv.LowerLeft = pPointpPoint.x = 7 now define UR coordspPoint.y = 10pEnv.UpperRight = pPointCreate a pointer to the IElement interface, QIDim pElement As IElementSet pElement = pTxtElementSet the Elements GEOMETRY property with the EnvelopepElement.Geometry = pEnvPrepare display f
24、or drawing (Activate), AddElement to theGraphicsContainer, then DrawpElement.Activate pDisp -without this, BAD things happen!pGContainer.AddElement pElement, 1pMxDoc.ActiveView.RefreshEnd Sub7.VB+AO 增加 shapefile 数据Private Sub Form_Load()Dim pWorkspaceFactory As IWorkspaceFactoryDim pWorkspace As IFe
25、atureWorkspaceDim pFClass As IFeatureClassDim pLayer As IFeatureLayerSet pWorkspaceFactory = New ShapefileWorkspaceFactory获取目录Set pWorkspace = pWorkspaceFactory.OpenFromFile(“D:data“, 0)获取 shapefile 名Set pFClass = pWorkspace.OpenFeatureClass(“result“)Set pLayer = New FeatureLayerSet pLayer.FeatureCl
26、ass = pFClassMapControl1.AddLayer pLayerMapControl1.RefreshEnd Sub8.VBA 增加 Raster 数据Public Sub AddRasterLayer() Dim pMxDocument As IMxDocumentDim pMap As IMapDim pLayer As IRasterLayerDim pWF As IWorkspaceFactoryDim pW As IWorkspaceDim pFW As IRasterWorkspaceDim pDataset As IDatasetDim pRDataset As
27、IRasterDatasetSet pWF = New RasterWorkspaceFactory6Enter path to workspace that contains your gridSet pW = pWF.OpenFromFile(“C:data“)QISet pFW = pWEnter Name of Grid folderSet pRDataset = pFW.OpenRasterDataset(“LakeDepth“)Use the grid to create a raster layerDim pRLayer As IRasterLayerSet pRLayer =
28、New RasterLayerpRLayer.CreateFromDataset pRDatasetAdd the raster layer to a mapSet pMxDocument = ThisDocumentSet pMap = pMxDocument.FocusMappMxDocument.AddLayer pRLayerSet the layer nameSet the display extentEnd Sub9.Merge Layer (VB+AO)兔八哥以前写的，现在也放这吧Public Function Merge(pathLayer1 As String, pathLa
29、yer2 As String, pathMergeResult As String, _nameLayer1 As String, nameLayer2 As String, nameMergeResult As String) 分别读取图层一,图层二到 FeatureClass 和 Table 中Dim pWorkspaceFactory As IWorkspaceFactoryDim pWorkspace1 As IFeatureWorkspaceDim pWorkspace2 As IFeatureWorkspace Dim pFirstFeatClass As IFeatureClas
30、sDim pSecondFeatClass As IFeatureClassDim pFirstTable As ITableDim pSecondTable As ITableDim pFeatLayer1 As IFeatureLayerSet pFeatLayer1 = New FeatureLayerDim pFeatLayer2 As IFeatureLayerSet pFeatLayer2 = New FeatureLayerSet pWorkspaceFactory = New ShapefileWorkspaceFactorySet pWorkspace1 = pWorkspa
31、ceFactory.OpenFromFile(pathLayer1, 0)Set pWorkspace2 = pWorkspaceFactory.OpenFromFile(pathLayer2, 0)Set pFirstFeatClass = pWorkspace1.OpenFeatureClass(nameLayer1)Set pSecondFeatClass = pWorkspace2.OpenFeatureClass(nameLayer2)Set pFeatLayer1.FeatureClass = pFirstFeatClassSet pFirstTable = pFeatLayer1
32、Set pFeatLayer2.FeatureClass = pSecondFeatClassSet pSecondTable = pFeatLayer2 检查错误If pFirstTable Is Nothing ThenMsgBox “Table QI failed“Exit FunctionEnd IfIf pSecondTable Is Nothing ThenMsgBox “Table QI failed“Exit FunctionEnd If 定义输出要素类名称和 shape 类型Dim pFeatClassName As IFeatureClassName7Set pFeatCl
33、assName = New FeatureClassNameWith pFeatClassName.FeatureType = esriFTSimple.ShapeFieldName = “Shape“.ShapeType = pFirstFeatClass.ShapeTypeEnd With 定义输出 shapefile 位置与名称Dim pNewWSName As IWorkspaceNameSet pNewWSName = New WorkspaceNameWith pNewWSName.WorkspaceFactoryProgID = “esriCore.ShapefileWorksp
34、aceFactory“.PathName = pathMergeResultEnd WithDim pDatasetName As IDatasetNameSet pDatasetName = pFeatClassNamepDatasetName.Name = nameMergeResultSet pDatasetName.WorkspaceName = pNewWSName 定义 Merge 参数Dim inputArray As IArraySet inputArray = New esriCore.ArrayinputArray.Add pFirstTableinputArray.Add
35、 pSecondTable 进行 Merge 操作Dim pBGP As IBasicGeoprocessorSet pBGP = New BasicGeoprocessorDim pOutputFeatClass As IFeatureClassSet pOutputFeatClass = pBGP.Merge(inputArray, pFirstTable, pFeatClassName)End Function10.GraphicsLayer 中增加一个点Public Sub AddPointToGraphicsLayer()Dim pMxDoc As IMxDocumentSet pM
36、xDoc = ThisDocumentDim pMxApp As IMxApplicationSet pMxApp = ApplicationDim pMap As IMapSet pMap = pMxDoc.FocusMapInstantiate the composite graphics layerDim pCGLayer As ICompositeGraphicsLayerSet pCGLayer = New CompositeGraphicsLayerQI for ILayer to set the layers nameDim pLayer As ILayerSet pLayer
37、= pCGLayerpLayer.Name = “TestPoint“Add the layer to the mappMap.AddLayer pCGLayerSet some x and y values or read them from somewhereDim x As DoubleDim y As Doublex = 200y = 200Make a pointDim pPnt As IPointSet pPnt = New PointpPnt.x = x8pPnt.y = ySet color and symbol for the point, BlueDim pColor As
38、 IRgbColorSet pColor = New RgbColorpColor.Blue = 255pColor.Green = 0pColor.Red = 0Dim pSimpleMarkerSymbol As ISimpleMarkerSymbolSet pSimpleMarkerSymbol = New SimpleMarkerSymbolWith pSimpleMarkerSymbol.Style = esriSMSCircle.Size = 4.Color = pColorEnd WithCreate a marker elementDim pMarkerElement As I
39、MarkerElementSet pMarkerElement = New MarkerElementpMarkerElement.Symbol = pSimpleMarkerSymbolDim pElement As IElementSet pElement = pMarkerElementpElement.Geometry = pPntGet the graphics layer and screen displayDim pGrLayer As IGraphicsLayerSet pGrLayer = pCGLayerDim pScreenDisplay As IScreenDispla
40、ySet pScreenDisplay = pMxApp.DisplayAdd the marker element ot the layer graphics containerDim pGraphicCont As IGraphicsContainerSet pGraphicCont = pGrLayerpGraphicCont.AddElement pMarkerElement, 0With pScreenDisplay.ActiveCache = 0.StartDrawing pScreenDisplay.hDC, 0.SetSymbol pSimpleMarkerSymbolpEle
41、ment.Draw pScreenDisplay, Nothing.FinishDrawingEnd WithRefresh/redraw the display with the new pointpMxDoc.ActiveView.RefreshEnd Sub11. 对 ArcMap 显示区域大小进行缩放本例用来对 ArcMap 显示区域进行放达 2 倍,修改 2 为你需要的放大比例Private Sub UIButtonControl1_Click()Dim pMxApp As IMxApplicationDim pMxDoc As IMxDocumentDim pDisp As ISc
42、reenDisplayDim pPoint As IPointDim pCenterPoint As IPoint 获得当前 DisplaySet pMxApp = ApplicationSet pDisp = pMxApp.DisplaySet pMxDoc = Document获取当前显示区域Dim pCurrentEnv As IEnvelope9Dim pEnv As IEnvelopeSet pCurrentEnv = pMxDoc.ActiveView.Extent.EnvelopeSet pEnv = pMxDoc.ActiveView.Extent.Envelope设置显示范围
43、为当前的 1/2pEnv.Height = pCurrentEnv.Height / 2pEnv.Width = pCurrentEnv.Width / 2设置新的显示区域的中心为原来显示区域中心Set pPoint = New PointSet pCenterPoint = New PointpCenterPoint.X = pCurrentEnv.LowerLeft.X + pCurrentEnv.Width / 2pCenterPoint.Y = pCurrentEnv.LowerLeft.Y + pCurrentEnv.Height / 2pEnv.CenterAt pCenterPo
44、int设置视图显示区域pMxDoc.ActiveView.Extent = pEnvpMxDoc.ActiveView.RefreshEnd Sub12. 复制一个 FeatureClass复制一个 FeatureClassPublic Function hCopyFC(ByVal myinstr As String, ByVal myoutstr As String) As Boolean Dim hOUTshwsname As IWorkspaceNameDim hOutshDSName As IDatasetNameDim hInWorkspaceName As IWorkspaceNa
45、meDim hDatasetName As IDatasetNameDim htoshape As IFeatureDataConverterDim htname As IFeatureClassNameDim houttname As IFeatureClassNameSet hInWorkspaceName = New WorkspaceNamehInWorkspaceName.PathName = strdir + “templatetemplate.mdb“ 数据模板hInWorkspaceName.WorkspaceFactoryProgID = “esriCore.AccessWo
46、rkspaceFactory.1“Set htname = New FeatureClassNameSet hDatasetName = htnameSet hDatasetName.WorkspaceName = hInWorkspaceNamehDatasetName.Name = myinstrSet hOUTshwsname = New WorkspaceNamehOUTshwsname.PathName = strpathname 当前数据路径hOUTshwsname.WorkspaceFactoryProgID = “esriCore.AccessWorkspaceFactory.
47、1“Set houttname = New FeatureClassNameSet hOutshDSName = houttnameSet hOutshDSName.WorkspaceName = hOUTshwsnamehOutshDSName.Name = myoutstrSet htoshape = New FeatureDataConverterhtoshape.ConvertFeatureClass hDatasetName, Nothing, Nothing, hOutshDSName, Nothing, Nothing, “, _ 1000, 0Set hInWorkspaceN
48、ame = NothingSet htname = NothingSet hOUTshwsname = NothingSet houttname = NothingSet htoshape = NothingEnd Function1013. 对指定直线的所有节点坐标进行平移对直线的所有节点坐标进行平移 new_x = (original_x1.2) + 5 Public Function test_Polyline(pPolyline As IPolyline) As IPolylineDim pNewPolyline As IPolylineDim pPointColl As IPoint
49、CollectionDim pNewPointColl As IPointCollectionDim pPoint As IPointDim pNewPoint As IPointDim dX As Double, dY As DoubleDim dNew_X As DoubleDim i As LongSet pNewPointColl = New PolylineIf (Not pPolyline.IsEmpty) ThenSet pPointColl = pPolylineFor i = 0 To pPointColl.PointCount - 1Set pPoint = pPointColl.Point(i)dX = pPoint.xdY = pPoint.ydNew_X = (dX 1.2) + 5Set pNewPoint = New esriCore.PointpNewPoint.PutCoords dNew_X, dY
