進(jìn)行屬性查詢的時候資料

1、在 ArcMap 中，進(jìn)行屬性查詢的時候， Arcmap 中提供了選中字段的屬性的 Unique Value。這樣就可以從列表中選擇了。以前也遇到類似問題，一直不知道怎么做，好在當(dāng)時使用的 ArcSDE Oracle 數(shù)據(jù)，使用了一個 SQL 語句解決了。不過要是 Coverage 就沒有辦法了。其實(shí) AO 中提供了這樣的功能了，可通過 IDataStatistics 來實(shí)現(xiàn)，做了一個函數(shù)，參數(shù)為圖層和字段，返回該圖層該字段的所有 Unique Value1.' 下面程序段是用來列出ArcMap中 , 指定圖層和字段中, 所有Unique ValuePublic Function li

2、stUniqueValue(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 IEn

3、umVariantSimpleSet pEnumVar = pDataStat.UniqueValuespValue = pEnumVar.NextDim i As Long'Dim count As Long'count = pDataStat.UniqueValueCounti = 0Dim value(200) As String ' 數(shù) 組 的 長 度 按 說 應(yīng) 該 使 用 pDataStat.UniqueValueCount 來控制，但是編譯只能使用'常數(shù) ,不能使用變量Do Until IsEmpty(pValue)value(i) = pValu

4、ei = i + 1pValue = pEnumVar.NextLooplistUniqueV alue = value()End Function2.打開圖層屬性表(ArcMap VBA)'下面程序段是用來列出ArcMap 中 ,指定圖層和字段中,所有 Unique ValuePublic Sub OpenFeatureLayerTable()Dim pMxDoc As IMxDocumentDim pMap As IMapDim pLayer As IFeatureLayerDim pTable As ITableWindowSet pMxDoc = ThisDocumentSet

5、 pMap = pMxDoc.FocusMapSet pLayer = pMap.Layer(0)'Instantiate the Table windowSet pTable = New TableWindow'Associate the table and a feature layerSet pTable.FeatureLayer = pLayerSet pTable.Application = Application'Open the tablepTable.Show TrueEnd Sub13.AO 中加載 SDE 中的 Raster 數(shù)據(jù)(ArcMap VB

6、A/VB AO)Public Function GetRasterFromSDE(sServer As String, sInstance As String, _ sUser As String, sPassword As String, sSDERaster As String, Optional version AsString = "SDE.DEFAULT") As IRasterDataset'加載柵格函數(shù)' sServer,sInstance,sDB,sUser,sPasswd: ArcSDE connection info' sSDER

7、aster: the ArcSDE raster dataset nameDim pSDEWs As IWorkspaceNameDim pSDEPropertySet As IPropertySetDim pSDERasterDataset As IRasterDatasetDim pDsName As IDatasetNameDim pName As IName' Dim sQualifiedName As String' Get connection propertysetSet pSDEPropertySet = New PropertySetWith pSDEProp

8、ertySet.SetProperty "Server", sServer.SetProperty "Instance", sInstance' .SetProperty "Database", sDB.SetProperty "User", sUser.SetProperty "Password", sPassword.SetProperty "Version", versionEnd With' Get workspacenameSet pSDEWs =

9、New WorkspaceName pSDEWs.ConnectionProperties = pSDEPropertySet pSDEWs.WorkspaceFactoryProgID = "esricore.sdeworkspacefactory"' Get raster dataset nameSet pDsName = New RasterDatasetNamepDsName.Name = sSDERasterSet pDsName.WorkspaceName = pSDEWsSet pName = pDsName' Open ArcSDE rast

10、er datasetSet pSDERasterDataset = pName.Open' CleanupSet GetRasterFromSDE = pSDERasterDatasetSet pSDEWs = NothingSet pSDERasterDataset = NothingSet pSDEPropertySet = NothingSet pName = NothingSet pDsName = NothingEnd Function4.AO 中直接加載 ArcSDE 矢量數(shù)據(jù)Public Function addSDEData(Server As String, Inst

11、ance As String, User As String, _Password As String, featureClass As String, Optional version As String = "SDE.DEFAULT")On Error GoTo EHDim pWorkspaceFactory As IWorkspaceFactoryDim pWorkspace As IFeatureWorkspaceDim pPropSet As IPropertySetDim pClass As IFeatureClassDim pLayer As IFeature

12、LayerDim pMxDoc As IMxDocument2Set pWorkspaceFactory = New SdeWorkspaceFactory Set pPropSet = New PropertySetWith pPropSet ' 設(shè)置 ArcSDE 連接屬性.SetProperty "SERVER", Server.SetProperty "INSTANCE", Instance.SetProperty "USER", User.SetProperty "PASSWORD", Passw

13、ord.SetProperty "VERSION", version ' 可選，缺省為 SDE.DEFAULT 版本 End WithSet pWorkspace = pWorkspaceFactory.Open(pPropSet, 0)Set pClass = pWorkspace.OpenFeatureClass(featureClass)Set pLayer = New FeatureLayerSet pLayer.featureClass = pClasspLayer.Name = pClass.AliasNameSet pMxDoc = ThisDocum

14、entpMxDoc.AddLayer pLayerEH:MsgBox Err.Description, vbInformation, "加載數(shù)據(jù)錯誤"End Function5.對選中要素進(jìn)行屬性統(tǒng)計(jì)Public Sub SumSelectedFeatures()Dim pMxDoc As IMxDocumentDim pmap As IMapDim player As IFeatureLayerDim pFcc As IFeatureClassDim pFields As IFieldsDim pNumFields As IFieldsDim numAreaField A

15、s DoubleDim pField As IFieldSet pMxDoc = ThisDocumentSet pmap = pMxDoc.FocusMapSet player = pmap.Layer(0)Set pFcc = player.FeatureClassSet pFields = pFcc.Fields'Get a field to SumSet pNumFields = pFieldsnumAreaField = pFields.FindField("pop1997") ' <-Enter a field here 'Chec

16、k for a valid field index numberIf numAreaField < 0 ThenMsgBox "Please enter a Valid field name", vbCritical, "Field Doesn't Exist"Exit SubEnd IfSet pField = pFields.Field(numAreaField)'*Other useful field stuff*'.FindField("AREA")'MsgBox numAreaField

17、'MsgBox pField.Name'MsgBox pFields.FieldCount'MsgBox player.Name'Get the selected recordsDim pFeatureSelection As IFeatureSelection3Set pFeatureSelection = playerDim pSelected As ISelectionSetSet pSelected = pFeatureSelection.SelectionSetDim pCursor As ICursorpSelected.Search Nothing

18、, 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 " & pF

19、ield.Name & " is: " & sumAREA 'MsgBox counter & " Selected records"End Sub6.在 ArcMap LayOut中增加文字Private pMxApp As IMxApplicationPrivate pMxDoc As IMxDocumentPrivate pDisp As IScreenDisplayPrivate pEnv As IEnvelopePrivate pPoint As IPointPrivate pColor As IRgbColor

20、Private pLayout As IPageLayoutPrivate pMapSurround As IMapSurroundPrivate pNSurround As INorthArrowPrivate pGContainer As IGraphicsContainerPrivate pEnumLayer As IEnumLayerPrivate pFLayer As ILayerPrivate pBLayer As ILayerPublic Sub AddTextToLayout()'Button to place text on the layout''R

21、eference App, Doc, Disp, Layout, and GraphicContainerSet pMxApp = ApplicationSet pMxDoc = DocumentSet pDisp = pMxApp.DisplaySet pLayout = pMxDoc.ActiveViewSet pGContainer = pLayout'Create a TextElementDim pTxtElement As ITextElementSet pTxtElement = New TextElement'Create a TextSymbol and a

22、fontDim pTxtSym As ITextSymbolSet pTxtSym = New TextSymbolDim pFont As IFontDispSet pFont = New StdType.StdFont'Set some properties of the fontpFont.Name = "Courier"pFont.Bold = TruepFont.Italic = TruepFont.Size = 304'Set the TextSymbol's FONT property with the font pTxtSym.Fon

23、t = pFont'Set the TextElement's SYMBOL property with the TextSymbol 'Set the TextElement's TEXT property with the desired text pTxtElement.Symbol = pTxtSympTxtElement.Text = "This is a test"'Create an Envelope to define the TextElement's GEOMETRY'Create a Point

24、to define the Envelope's LL and UR (extent)Set pEnv = New EnvelopeSet pPoint = New PointpPoint.x = 2 'first define LL coordspPoint.y = 8 '<-these are page unitspEnv.LowerLeft = pPointpPoint.x = 7 'now define UR coordspPoint.y = 10pEnv.UpperRight = pPoint'Create a pointer to th

25、e IElement interface, QIDim pElement As IElementSet pElement = pTxtElement'Set the Element's GEOMETRY property with the Envelope pElement.Geometry = pEnv'Prepare display for drawing (Activate), AddElement to the 'GraphicsContainer, then DrawEnd Sub7.VB+AO 增加 shapefile數(shù)據(jù)Private Sub Fo

26、rm_Load()Dim pWorkspaceFactory As IWorkspaceFactoryDim pWorkspace As IFeatureWorkspaceDim pFClass As IFeatureClassDim pLayer As IFeatureLayerSet pWorkspaceFactory = New ShapefileWorkspaceFactory '獲取目錄Set pWorkspace = pWorkspaceFactory.OpenFromFile("D:data", 0)'獲取 shapefile 名Set pFC

27、lass = pWorkspace.OpenFeatureClass("result")Set pLayer = New FeatureLayerSet pLayer.FeatureClass = pFClassMapControl1.AddLayer pLayerMapControl1.RefreshEnd Sub8.VBA 增加 Raster 數(shù)據(jù)Public Sub AddRasterLayer()Dim pMxDocument As IMxDocumentDim pMap As IMapDim pLayer As IRasterLayerDim pWF As IWo

28、rkspaceFactoryDim pW As IWorkspace5Dim pFW As IRasterWorkspace' 分別讀取圖層一 ,圖層二到 FeatureClass 和 Table 中Dim pDataset As IDatasetDim pWorkspaceFactory As IWorkspaceFactoryDim pRDataset As IRasterDatasetDim pWorkspace1 As IFeatureWorkspaceSet pWF = New RasterWorkspaceFactoryDim pWorkspace2 As IFeature

29、Workspace'Enter path to workspace that contains your gridDim pFirstFeatClass As IFeatureClassSet pW = pWF.OpenFromFile("C:data")Dim pSecondFeatClass As IFeatureClass'QIDim pFirstTable As ITableSet pFW = pWDim pSecondTable As ITable'Enter Name of Grid folderDim pFeatLayer1 As IF

30、eatureLayerSet pRDataset = pFW.OpenRasterDataset("LakeDepth")Set pFeatLayer1 = New FeatureLayer'Use the grid to create a raster layerDim pFeatLayer2 As IFeatureLayerDim pRLayer As IRasterLayerSet pFeatLayer2 = New FeatureLayerSet pRLayer = New RasterLayerSet pWorkspaceFactory = New Sha

31、pefileWorkspaceFactorypRLayer.CreateFromDataset pRDatasetSet pWorkspace1 = pWorkspaceFactory.OpenFromFile(pathLayer1, 0)'Add the raster layer to a mapSet pWorkspace2 = pWorkspaceFactory.OpenFromFile(pathLayer2, 0)Set pMxDocument = ThisDocumentSet pFirstFeatClass = pWorkspace1.OpenFeatureClass(na

32、meLayer1)Set pMap = pMxDocument.FocusMapSet pSecondFeatClass = pWorkspace2.OpenFeatureClass(nameLayer2)pMxDocument.AddLayer pRLayerSet pFeatLayer1.FeatureClass = pFirstFeatClass'Set the layer nameSet pFirstTable = pFeatLayer1'Set the display extentSet pFeatLayer2.FeatureClass = pSecondFeatCl

33、assEnd SubSet pSecondTable = pFeatLayer2' 檢查錯誤9.Merge Layer (VB+AO)If pFirstTable Is Nothing ThenMsgBox "Table QI failed"'兔八哥以前寫的，現(xiàn)在也放這吧Exit FunctionPublic Function Merge(pathLayer1 As String, pathLayer2 As String,End IfpathMergeResult As String, _If pSecondTable Is Nothing Thennam

34、eLayer1 As String, nameLayer2 As String, nameMergeResult As String)MsgBox "Table QI failed"6Exit FunctionEnd If' 定義輸出要素類名稱和 shape 類型Dim pFeatClassName As IFeatureClassNameSet pFeatClassName = New FeatureClassNameWith pFeatClassName.FeatureType = esriFTSimple.ShapeFieldName = "Shap

35、e".ShapeType = pFirstFeatClass.ShapeTypeEnd With' 定義輸出 shapefile 位置與名稱Dim pNewWSName As IWorkspaceNameSet pNewWSName = New WorkspaceNameWith pNewWSName.WorkspaceFactoryProgID = "esriCore.ShapefileWorkspaceFactory".PathName = pathMergeResultEnd WithDim pDatasetName As IDatasetNameS

36、et pDatasetName = pFeatClassNamepDatasetName.Name = nameMergeResultSet pDatasetName.WorkspaceName = pNewWSName' 定義 Merge 參數(shù)Dim inputArray As IArraySet inputArray = New esriCore.ArrayinputArray.Add pFirstTableinputArray.Add pSecondTable' 進(jìn)行 Merge 操作Dim pBGP As IBasicGeoprocessorSet pBGP = New

37、 BasicGeoprocessorDim pOutputFeatClass As IFeatureClassSet pOutputFeatClass = pBGP.Merge(inputArray, pFirstTable, pFeatClassName)End Function10.GraphicsLayer中增加一個點(diǎn)Public Sub AddPointToGraphicsLayer()Dim pMxDoc As IMxDocumentSet pMxDoc = ThisDocumentDim pMxApp As IMxApplicationSet pMxApp = Applicatio

38、nDim pMap As IMapSet pMap = pMxDoc.FocusMap'Instantiate the composite graphics layerDim pCGLayer As ICompositeGraphicsLayerSet pCGLayer = New CompositeGraphicsLayer'QI for ILayer to set the layer's nameDim pLayer As ILayerSet pLayer = pCGLayerpLayer.Name = "TestPoint"'Add t

39、he layer to the mappMap.AddLayer pCGLayer'Set some x and y values or read them from somewhereDim x As DoubleDim y As Doublex = 2007y = 200'Make a pointDim pPnt As IPointSet pPnt = New PointpPnt.x = xpPnt.y = y'Set color and symbol for the point, BlueDim pColor As IRgbColorSet pColor = Ne

40、w RgbColorpColor.Blue = 255pColor.Green = 0pColor.Red = 0Dim pSimpleMarkerSymbol As ISimpleMarkerSymbolSet pSimpleMarkerSymbol = New SimpleMarkerSymbolWith pSimpleMarkerSymbol.Style = esriSMSCircle.Size = 4.Color = pColorEnd With'Create a marker elementDim pMarkerElement As IMarkerElement Set pM

41、arkerElement = New MarkerElement pMarkerElement.Symbol = pSimpleMarkerSymbol Dim pElement As IElementSet pElement = pMarkerElementpElement.Geometry = pPnt'Get the graphics layer and screen displayDim pGrLayer As IGraphicsLayerSet pGrLayer = pCGLayerDim pScreenDisplay As IScreenDisplaySet pScreen

42、Display = pMxApp.Display'Add the marker element ot the layer graphics containerDim pGraphicCont As IGraphicsContainerSet pGraphicCont = pGrLayerpGraphicCont.AddElement pMarkerElement, 0With pScreenDisplay.ActiveCache = 0.StartDrawing pScreenDisplay.hDC, 0.SetSymbol pSimpleMarkerSymbolpElement.Dr

43、aw pScreenDisplay, Nothing.FinishDrawingEnd With'Refresh/redraw the display with the new pointEnd Sub11. 對 ArcMap 顯示區(qū)域大小進(jìn)行縮放'本例用來對 ArcMap 顯示區(qū)域進(jìn)行放達(dá) 2 倍 ,修改 2 為你需要的放大比例 Private Sub UIButtonControl1_Click()Dim pMxApp As IMxApplicationDim pMxDoc As IMxDocumentDim pDisp As IScreenDisplayDim pPoin

44、t As IPointDim pCenterPoint As IPoint'獲得當(dāng)前Display8Set pMxApp = ApplicationSet pDisp = pMxApp.DisplaySet pMxDoc = Document'獲取當(dāng)前顯示區(qū)域Dim pCurrentEnv As IEnvelopeDim pEnv As IEnvelope'設(shè)置顯示范圍為當(dāng)前的1/2pEnv.Height = pCurrentEnv.Height / 2pEnv.Width = pCurrentEnv.Width / 2'設(shè)置新的顯示區(qū)域的中心為原來顯示區(qū)域中心

45、Set pPoint = New PointSet pCenterPoint = New PointpEnv.CenterAt pCenterPoint'設(shè)置視圖顯示區(qū)域End Sub12. 復(fù)制一個 FeatureClass'復(fù)制一個FeatureClassPublic Function hCopyFC(ByVal myinstr As String, ByVal myoutstr As String) As BooleanDim hOUTshwsname As IWorkspaceNameDim hOutshDSName As IDatasetNameDim hInWork

46、spaceName As IWorkspaceNameDim hDatasetName As IDatasetNameDim htoshape As IFeatureDataConverterDim htname As IFeatureClassNameDim houttname As IFeatureClassNameSet hInWorkspaceName = New WorkspaceName hInWorkspaceName.PathName = strdir + "templatetemplate.mdb" ' 數(shù)據(jù)模板Set htname = New F

47、eatureClassNameSet hDatasetName = htnameSet hDatasetName.WorkspaceName = hInWorkspaceName hDatasetName.Name = myinstrSet hOUTshwsname = New WorkspaceName hOUTshwsname.PathName = strpathname '當(dāng)前數(shù)據(jù)路徑Set houttname = New FeatureClassNameSet hOutshDSName = houttnameSet hOutshDSName.WorkspaceName = hO

48、UTshwsname hOutshDSName.Name = myoutstrSet htoshape = New FeatureDataConverterhtoshape.ConvertFeatureClasshDatasetName,Nothing,Nothing,hOutshDSName, Nothing, Nothing, "", _ 1000, 0 Set hInWorkspaceName = NothingSet htname = NothingSet hOUTshwsname = Nothing9Set houttname = NothingNext iSet

49、 htoshape = NothingSet pNewPolyline = pNewPointCollEnd FunctionElseSet pNewPolyline = Nothing13. 對指定直線的所有節(jié)點(diǎn)坐標(biāo)進(jìn)行平移End IfSet test_Polyline = pNewPolylineEnd Function'對直線的所有節(jié)點(diǎn)坐標(biāo)進(jìn)行平移new_x = (original_x1.2) + 5Public Function test_Polyline(pPolyline As IPolyline) As IPolyline14. 對 ArcMap 目錄表中的圖層進(jìn)行排序D

50、im pNewPolyline As IPolylineDim pPointColl As IPointCollectionDim pNewPointColl As IPointCollection'對目錄表中的圖層進(jìn)行排序Dim pPoint As IPointSub SortLayers()Dim pNewPoint As IPoint' 獲取地圖文檔Dim dX As Double, dY As DoubleDim pMxDoc As IMxDocumentDim dNew_X As DoubleSet pMxDoc = ThisDocumentDim i As Long

51、' TOC 對象Set pNewPointColl = New PolylineDim pTOC As IContentsViewIf (Not pPolyline.IsEmpty) ThenSet pTOC = pMxDoc.CurrentContentsViewSet pPointColl = pPolylineDim pMap As IMapFor i = 0 To pPointColl.PointCount - 1Set pMap = pMxDoc.FocusMapSet pPoint = pPointColl.Point(i)Dim pLayer As ILayerdX =

52、pPoint.xDim i As VariantdY = pPoint.y' 圖層排序dNew_X = (dX 1.2) + 5For i = 0 To pMap.LayerCount - 1Set pNewPoint = New esriCore.PointSet pLayer = pMxDoc.FocusMap.Layer(i)pNewPoint.PutCoords dNew_X, dYSelect Case pLayer.NamepNewPointColl.AddPoint pNewPointCase "Situs Addresses"10pMap.MoveL

53、ayer pLayer, 0Case "Spot Elevations"pMap.MoveLayer pLayer, 1Case "Sewer Network Junctions"pMap.MoveLayer pLayer, 2Case "Manholes"pMap.MoveLayer pLayer, 3Case "Contours"pMap.MoveLayer pLayer, 4Case "Sewer Lines"pMap.MoveLayer pLayer, 5Case "Stree

54、t Centerlines".'兔八哥懶得敲了Case "DEM"pMap.MoveLayer pLayer, 19Case "Hillshade Grid"pMap.MoveLayer pLayer, 20End SelectNext i' 刷新目錄表End Sub15. 在 ArcGIS 中使用繪制的圓形選擇要素'使用繪制的圓形選擇要素，算是彌補(bǔ)ESRI 選擇只能簡單使用面的遺憾吧Private Function UIToolControl1_Message() As StringUIToolControl1_Mes

55、sage = "Select features by dragging a circle"End FunctionPrivate Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, ByVal x As Long, ByVal y As Long)Dim pMxApp As IMxApplicationDim pMxDoc As IMxDocumentDim pActiveView As IActiveViewDim pRubberCirc As IRubberBandDim pCircArc As ICircularArcDim pGeo As IGeometryDim pMap As IMapDim pMapPoint As WKSPointDim pDevPoint As tagPOINTDim pDisplayTransformation As IDispl