ESRI ArcGIS应用与开发 [帝国首发]ArcGIS开发教材,0830更新,提问前请先看||做专业的GIS技术交流论坛

gis

管理员

注册日期2003-07-16
发帖数15951
QQ
铜币25345枚
威望15368点
贡献值0点
银元0个

70楼^#

发布于：2005-08-02 23:38

如何设置和修改层的数据源
本例要实现的是如何改变（或设置）一个层的数据源（Ｄata Source）。主要用到IMapAdmin2接口。
l 要点
首先需要得到新数据源的IFeatureClass接口对象和当前要改变数据源的层的当前IFeatureClass接口对象，然后调用IMapAdmin2接口的FireChangeFeatureClass方法实现之。
l 程序说明
过程UICMD_ChageDataSource_Click是实现模块，调用过程ChangeLayerDataSource实现功能。
sNewFileName是层的新数据源的shape文件的完整文件名（包含）。
l 代码
Private Sub UICMD_ChageDataSource_Click()
 Dim pVBProject As VBProject
 Dim sProjectName As String
 Dim sNewFileName As String
On Error GoTo ErrorHandler:
 Set pVBProject = ThisDocument.VBProject
 'Get MXD File Path
 sProjectName = pVBProject.FileName
 'Get Data File Path
 sNewFileName = sProjectName ; "\..\..\..\..\data\country.shp"
 'Call Procedure 
 ChangeLayerDataSource sNewFileName
 Exit Sub
ErrorHandler:
 MsgBox Err.Description
End Sub
Private Sub ChangeLayerDataSource(ByVal sNewFileName As String)
 Dim pWorkspaceFactory As IWorkspaceFactory
 Dim pWorkspace As IWorkspace
 Dim pFeatureWorkspace As IFeatureWorkspace
 Dim pNewFeatureCls As IFeatureClass
 Dim pOldFeatureCls As IFeatureClass
 Dim pMxDocument As IMxDocument
 Dim pMap As IMap
 Dim pActiveView As IActiveView
 Dim pMapAdmin2 As IMapAdmin2
 Dim pFeatureLayer As IFeatureLayer
On Error GoTo ErrorHandler
 'Get Data FeatureClass
 Set pWorkspaceFactory = New ShapefileWorkspaceFactory
 Set pWorkspace = pWorkspaceFactory.OpenFromFile(sNewFileName ; "\..\", 0)
 Set pFeatureWorkspace = pWorkspace
 Set pNewFeatureCls = pFeatureWorkspace.OpenFeatureClass("country")
 'Get Lay(0)'s FeatureClass
 Set pMxDocument = ThisDocument
 Set pMap = pMxDocument.FocusMap
 Set pMapAdmin2 = pMap
 Set pActiveView = pMap
 Set pFeatureLayer = pMap.Layer(0)
 Set pOldFeatureCls = pFeatureLayer.FeatureClass
 'Change Data Source
 Set pFeatureLayer.FeatureClass = pNewFeatureCls
 pMapAdmin2.FireChangeFeatureClass pOldFeatureCls, pNewFeatureCls
 pActiveView.Refresh
 'if want to change Display in Toc ,cancel these comment below
 'pFeatureLayer.Name = pNewFeatureCls.AliasName
 'pMxDocument.CurrentContentsView.Refresh 0 Exit Sub
ErrorHandler:
 MsgBox Err.Description
End Sub

GIS麦田守望者，期待与您交流。

举报回复喜欢评分

gis

管理员

注册日期2003-07-16
发帖数15951
QQ
铜币25345枚
威望15368点
贡献值0点
银元0个

加关注写私信

71楼^#

发布于：2005-08-02 23:38

如何实现在ArcMap上进行属性查询(Identify)
本例要演示的是如何查询Feature的属性信息。实现后的结果为选择了UI Tool Control后，在要查询的Feature上单击鼠标，查询的结果将显示在弹出的窗体上。
l 要点
首先需要得到要查询的Feature对象。使用IIdentify接口的Identify方法可以对给定的位置进行查询，得到结果为IIdentifyObj对象的数组。然后通过为IIdentifyObj对象设置IFeatureIdentifyObj查询接口，即可进一步得到Feature对象。因为IFeatureIdentifyObj接口的Feature属性具有只写（write only）属性，故又用到另一个接口IRowIdentifyObj。
得到Feature对象后即可操作其Fields属性和Value属性，得到其属性字段名和值。
l 程序说明
在窗体上使用了MSFlexGrid Control 6.0来显示查询结果。所以本例也演示了MSFlexGrid控件的使用方法。
窗体名： frmResult
MSFlexGrid控件名： flxAttr
标签控件名： lblLocation （标签用来显示查询位置的地理坐标）
l 代码
Private Sub UIT_Identify_MouseDown(ByVal button As Long, ByVal shift As Long, _ ByVal x As Long, ByVal y As Long)
 Dim pMxApplication As IMxApplication
 Dim pMxDocument As IMxDocument
 Dim pMap As IMap
 Dim pPoint As IPoint
 Dim pIDArray As IArray
 Dim pIdentify As IIdentify
 Dim pFeatureIdentifyObj As IFeatureIdentifyObj
 Dim pIdentifyObj As IIdentifyObj
 Dim pRowIdentifyObj As IRowIdentifyObject
 Dim pFeature As IFeature
 Dim pFields As IFields
 Dim pField As IField
 Dim iFieldIndex As Integer
 Dim iLayerIndex As Integer
 Dim sShape As String
On Error GoTo ErrorHandler
 Set pMxApplication = Application
 Set pMxDocument = Application.Document
 Set pMap = pMxDocument.FocusMap
 'Identify from TOP layer to BOTTOM, exit loop since one Feature identified
 For iLayerIndex = 0 To pMap.LayerCount - 1
 Set pIdentify = pMap.Layer(iLayerIndex)
 'Convert x and y to map units
 Set pPoint = pMxApplication.Display.DisplayTransformation.ToMapPoint(x, y)
 'Set label on the form, coordinates would have 6 digits behind decimal point
 frmResult.lblLocation = "Location:(" ; Format(pPoint.x, "##0.000000") ; "," _ ; Format(pPoint.y, "##0.000000") ; ")" 
 Set pIDArray = pIdentify.Identify(pPoint)
 'Get the FeatureIdentifyObject
 If Not pIDArray Is Nothing Then
 Set pFeatureIdentifyObj = pIDArray.Element(0)
 Set pIdentifyObj = pFeatureIdentifyObj
 pIdentifyObj.Flash pMxApplication.Display
 'Feature property of FeatureIdentifyObject has write only access
 Set pRowIdentifyObj = pFeatureIdentifyObj
 Set pFeature = pRowIdentifyObj.Row
 Set pFields = pFeature.Fields
 'Set the MSFlexGrid control on form te display identify result
 With frmResult.flxAttr
 .AllowUserResizing = flexResizeColumns
 .ColAlignment(1) = AlignmentSettings.flexAlignLeftCenter
 .ColWidth(0) = 1500
 .ColWidth(1) = 1800
 'Add header to MSFlexGrid control
 .Rows = pFields.FieldCount + 1
 .Cols = 2
 .FixedRows = 1
 .FixedCols = 0
 .TextMatrix(0, 0) = "Field"
 .TextMatrix(0, 1) = "Value"
 For iFieldIndex = 0 To pFields.FieldCount - 1
 Set pField = pFields.Field(iFieldIndex)
 'Set field "Field" of the MSFlex control
 .TextMatrix(iFieldIndex + 1, 0) = pField.Name
 'Set field "Value" of the MSFlex control
 Select Case pField.Type
 Case esriFieldTypeOID
 .TextMatrix(iFieldIndex + 1, 1) = pFeature.OID
 Case esriFieldTypeGeometry
 'The function QueryShapeType return a String that
 ' correspond with the esriGeoemtryType const
 sShape = QueryShapeType(pField.GeometryDef.GeometryType) .TextMatrix(iFieldIndex + 1, 1) = sShape
 Case Else
 .TextMatrix(iFieldIndex + 1, 1) = pFeature.Value(iFieldIndex)
 End Select
 Next iFieldIndex
 End With 
 frmResult.Show modal
 Exit Sub
 End If
 Next iLayerIndex
 'If code goes here, no Feature was indentified, clear the MSFlex control's content
 ' and show a message
 frmResult.flxAttr.Clear
 MsgBox "No feature identified."
 Exit Sub
ErrorHandler:
 MsgBox Err.Description
End Sub

Public Function QueryShapeType(ByVal enuGeometryType As esriGeometryType) As String
 Dim sShapeType As String 
 Select Case enuGeometryType
 Case esriGeometryPolyline
 sShapeType = "Polyline"
 Case esriGeometryPolygon
 sShapeType = "Polygon"
 Case esriGeometryPoint
 sShapeType = "Point"
 Case esriGeometryMultipoint
 sShapeType = "Multipoint"
 Case esriGeometryNull
 sShapeType = "Unknown"
 Case esriGeometryLine
 sShapeType = "Line"
 Case esriGeometryCircularArc
 sShapeType = "CircularArc"
 Case esriGeometryEllipticArc
 sShapeType = "EllipticArc"
 Case esriGeometryBezier3Curve
 sShapeType = "BezierCurve"
 Case esriGeometryPath
 sShapeType = "Path"
 Case esriGeometryRing
 sShapeType = "Ring"
 Case esriGeometryEnvelope
 sShapeType = "Envelope"
 Case esriGeometryAny
 sShapeType = "Any valid geometry"
 Case esriGeometryBag
 sShapeType = "GeometryBag"
 Case esriGeometryMultiPatch
 sShapeType = "MultiPatch"
 Case esriGeometryTriangleStrip
 sShapeType = "TriangleStrip"
 Case esriGeometryTriangeFan
 sShapeType = "TriangleFan"
 Case esriGeometryRay
 sShapeType = "Ray"
 Case esriGeometrySphere
 sShapeType = "Sphere"
 Case Else
 sShapeType = "Unknown!"
 End Select
 QueryShapeType = sShapeType
End Function

GIS麦田守望者，期待与您交流。

举报回复喜欢评分

gis

管理员

注册日期2003-07-16
发帖数15951
QQ
铜币25345枚
威望15368点
贡献值0点
银元0个

加关注写私信

72楼^#

发布于：2005-08-02 23:37

如何利用用户定义的规则创建定制的排序
利用ITableSort接口可以完成普通的对记录排序的功能。ITableSortCallBack机制允许用户通过执行自定义的排序算法来完成定制的排序。本例演示了如何创建这样的用户类，通过实现ITableSortCallBack接口来完成该功能。
假设有如下原始数据：其中“Address”字段描述了道路（Street）的道路编号（Street Number）如“2805”，和道路名(Stree Name)如“Citrus Ave”。
 
现在要按道路名排序所有的记录。因为排序字段时必须忽略道路编号，故需要自定排序规则。
l 要点
首先需要创建用户自定义的类，并生成其实例。该类实现了ITableSortCallBack接口。然后把它的引用赋给ITableSort的Compare属性。最后用ITableSort的Sort方法完成排序。
l 程序说明
过程UIBCustomSort_Click是实现模块，调用过程CustomSort实现功能。
类模块clsTailSort为自定义模块，实现ITalbeSortCallBack接口。包括两个函数：ITableSortCallBack_Compare（用于定义字符串比较的规则）和Get_String（用于得到地址字段的道路名部分）。
过程CustomSort中创建Tablesort和clsTailSort的实例，并对结果进行排序，然后调用过程CreateTable，将排序后的结果存入C:\temp目录的NewSortTable.dbf文件，并作为独立表加入当前Map。
l 代码
 类模块clsTailSort
Option Explicit
' Custom class for ITableSortCallBack
' ClassName: clsTailSort
Implements ItableSortCallBack
Private Function ITableSortCallBack_Compare(ByVal value1 As Variant, ByVal value2 As_
Variant,ByVal FieldIndex As Long, ByVal fieldSortIndex As Long) As Long
 ' Custom table sort
 ' Get_string function gets the first block of characters (e.g street numbers)
 ' in each value.
 ' Comparison is then made on the remaining characters (e.g. street names).
 On Error GoTo ErrorHandler
 value1 = Get_String(value1)
 value2 = Get_String(value2) 
 If value1 > value2 Then
 ITableSortCallBack_Compare = 1
 ElseIf value1 < value2 Then
 ITableSortCallBack_Compare = -1
 Else: value1 = value2
 ITableSortCallBack_Compare = 0
 End If
 Exit Function
ErrorHandler:
 MsgBox Err.Description
End Function
Private Function Get_String(ByVal sMyStr As Variant) As Variant
 ' This function gets the tail of the string
 ' after the first block of characters
 Dim sFindString As String
 Dim nPosition As Integer
 Dim nStringLen As Integer
 On Error GoTo ErrorHandler
 nStringLen = Len(sMyStr)
 nPosition = 1
 Do Until nPosition = nStringLen
 sFindString = Mid(sMyStr, nPosition, 1)
 If sFindString = " " Then
 Exit Do
 End If
 nPosition = nPosition + 1
 Loop
 Get_String = Mid(sMyStr, nPosition + 1)
 Exit Function
ErrorHandler:
 MsgBox Err.Description
End Function
功能模块
Option Explicit

Private pMxDocument As IMxDocument
Private pMap As IMap
Private pApplication As IApplication
Public Sub CustomSort()
 Dim pSelectedItem As IUnknown
 Dim pStandaloneTable As IStandaloneTable
 Dim pTable As ITable
 Dim pTableSort As ITableSort
 Dim pTableSortCallBack As ITableSortCallBack
 Dim pCursor As ICursor
 Dim pRow As IRow
 
 On Error GoTo ErrorHandler
 
 Set pMxDocument = ThisDocument
 Set pMap = pMxDocument.FocusMap
 Set pApplication = Application
 Set pSelectedItem = pMxDocument.SelectedItem
 
 If pSelectedItem Is Nothing Then
 MsgBox "Nothing selectd.", vbExclamation
 Exit Sub
 ' If a table is selected
 ElseIf Not TypeOf pSelectedItem Is IStandaloneTable Then
 MsgBox "No table selectd.", vbExclamation
 Exit Sub
 Else
 Set pStandaloneTable = New esriCore.StandaloneTable
 Set pStandaloneTable = pSelectedItem
 End If
 
 Set pTable = pStandaloneTable.Table
 
 ' Create a new custom TableSortCallBack and TableSort object
 ' Class clsTailSort defined in Class Modules
 Set pTableSortCallBack = New clsTailSort
 Set pTableSort = New TableSort
 
 ' Set up the parameters for the sort and excute
 With pTableSort
 .Fields = "Address"
 .Ascending("Address") = True
 .CaseSensitive("Address") = True
 Set .Table = pTable
 Set .Compare = pTableSortCallBack
 End With
 pTableSort.Sort Nothing
 
 ' Create a new cursor object to hold the sorted rows
 Set pCursor = pTableSort.Rows
 
 ' Create a new sorted table
 Call CreateTable(pTable, pCursor)
 
 Set pTableSortCallBack = Nothing
 Set pTableSort = Nothing
 
 Exit Sub
ErrorHandler:
 MsgBox Err.Description
End Sub

Public Sub CreateTable(pTab As ITable, pCur As ICursor)
 ' Create a new .dbf file of the sorted data
 Dim pWorkspaceFactory As IWorkspaceFactory
 Dim pFeatureWorkspace As IFeatureWorkspace
 Dim pWorkspace As IWorkspace
 Dim pDatasetWkSp As IDataset
 Dim pWorkspaceName As IWorkspaceName
 Dim pDatasetNameOut As IDatasetName
 Dim pFields As IFields
 Dim pFields2 As esriCore.IFields
 Dim pDataset As IDataset
 Dim pDatasetName As IDatasetName
 Dim pDS As IDataset
 Dim pEnumDS As IEnumDataset
 
 Dim pStandaloneTable2 As IStandaloneTable
 Dim pTable2 As ITable
 Dim pTableNew As ITable
 Dim pCursor2 As ICursor
 Dim pRowBuffer As IRowBuffer
 Dim pRow As IRow
 Dim pName As IName
 Dim pStandaloneTable As IStandaloneTable
 Dim pStandaloneTableC As IStandaloneTableCollection
 
 Dim j As Integer
 Dim i As Integer
 
 On Error GoTo ErrorHandler
 
 ' Get the dataset name for the input table
 Set pDataset = pTab
 Set pDatasetName = pDataset.FullName
 
 ' Set the output dataset name.
 ' New .dbf file will be created in c:\temp
 Set pFields = pTab.Fields
 Set pWorkspaceFactory = New ShapefileWorkspaceFactory
 Set pWorkspace = pWorkspaceFactory.OpenFromFile("c:\temp", 0)
 Set pFeatureWorkspace = pWorkspace
 Set pDatasetWkSp = pWorkspace
 Set pWorkspaceName = pDatasetWkSp.FullName
 Set pDatasetNameOut = New TableName
 pDatasetNameOut.Name = "NewSortTable"
 Set pDatasetNameOut.WorkspaceName = pWorkspaceName
 
 ' Check if .dbf file already exist: if yes, delete it
 Set pEnumDS = pWorkspace.Datasets(esriDTTable)
 Set pDS = pEnumDS.Next
 Do Until pDS Is Nothing
 If pDS.Name = pDatasetNameOut.Name Then
 pDS.Delete
 Exit Do
 End If
 Set pDS = pEnumDS.Next
 Loop

 ' Create a new .dbf table
 pFeatureWorkspace.CreateTable pDatasetNameOut.Name, pFields, Nothing, Nothing, ""
 
 ' Create a new stand alone table object to represent the .dbf table
 Set pStandaloneTable2 = New StandaloneTable
 Set pStandaloneTable2.Table = pFeatureWorkspace.OpenTable(pDatasetNameOut.Name)
 Set pTable2 = pStandaloneTable2.Table
 Set pFields2 = pTable2.Fields
 
 ' Open an insert cursor on the new table
 Set pCursor2 = pTable2.Insert(True)
 
 ' Create a row buffer for the row inserts
 Set pRowBuffer = pTable2.CreateRowBuffer
 
 ' Loop through the sorted cursor and write to new table
 For j = 0 To pTab.RowCount(Nothing) - 1
 Set pRow = pCur.NextRow
 If Not pRow Is Nothing Then
 i = 1
 Do Until i = pFields2.FieldCount
 If Not IsEmpty(pRow.Value(i)) Then
 If pFields.Field(i).Editable Then
 pRowBuffer.Value(i) = pRow.Value(i)
 End If
 End If
 i = i + 1
 Loop
 pCursor2.InsertRow pRowBuffer
 End If
 Next j
 
 ' Add the new sorted table to map document
 Set pName = pDatasetNameOut
 Set pTableNew = pName.Open
 Set pStandaloneTable = New StandaloneTable
 Set pStandaloneTable.Table = pTableNew
 Set pStandaloneTableC = pMap
 pStandaloneTableC.AddStandaloneTable pStandaloneTable

 pMxDocument.UpdateContents 

 Exit Sub
ErrorHandler:
 MsgBox Err.Description
End Sub

GIS麦田守望者，期待与您交流。

举报回复喜欢评分

gis

管理员

注册日期2003-07-16
发帖数15951
QQ
铜币25345枚
威望15368点
贡献值0点
银元0个

加关注写私信

73楼^#

发布于：2005-08-02 23:37

如何为当前层或独立表创建一个Summary表
本例要实现的是如何按某一字段“分组”（dissolve）,统计其它字段的数据信息摘要（创建Summary表）。可得到的主要信息包括该字段值相同的每组记录中的记录数量、最大值、最小值、和、平均值等。主要用到IBasicGeoprocessor接口的Dissolve方法。
l 要点
为当前层创建Summary表，要得到当前层的引用，并确定在其上执行Dissolve操作的字段。对独立表的操作方法与层的操作类似。
l 程序说明
过程UIBCreateSummaryTable_Click是实现模块，调用过程CreateSummaryTable实现功能。过程CreateSummaryTable中应先确认层（例中为states）和要“Dissolve”的字段（例中为SUB_REGION）存在，同时要定义摘要表的名字（本例为SumStates）。
然后指定执行Dissolve方法的操作符（如Minimum,Count,Average等）和在其上施行操作的字段名（例中为AREA）。操作结果作为独立表添加到当前Map。
因为Dissolve方法参数表中的“输入表”和“输出数据集的名字”都是引用，为了避免多次调用过程使最终SumStates表中的结果不唯一，每次执行Dissolve前，将SumStates的已存内容删除。
l 代码
Private Sub UIBCreateSummaryTable_Click()
 Call CreateSummaryTable
End Sub
Public Sub CreateSummaryTable()
 Dim pMxDocument As IMxDocument
 Dim pMap As IMap
 Dim pLayer As ILayer
 Dim pFeatLayer As IFeatureLayer
 Dim iCount As Integer
 Dim pFeatureClass As IFeatureClass
 Dim pTable As ITable
 Dim pDataSet As IDataset
 Dim pWorkspace As IWorkspace
 Dim pWorkspaceDataset As IDataset
 Dim pWorkspaceName As IName
 Dim pOutTableName As ITableName
 Dim pOutDatasetName As IDatasetName
 Dim pEnumDataset As IEnumDataset
 Dim pBasicGeoprocessor As IBasicGeoprocessor
 Dim pSumTable As ITable
 Dim pStandaloneTable As IStandaloneTable
 Dim pStandaloneTableColl As IStandaloneTableCollection
 ' Define current layer name and output table name
 Const sLayerName As String = "states"
 Const sSumTableName As String = "SumStates"
 Set pMxDocument = ThisDocument
 Set pMap = pMxDocument.FocusMap
 On Error GoTo ErrorHandler 
 Set pMxDocument = ThisDocument
 Set pMap = pMxDocument.FocusMap
 On Error GoTo ErrorHandler 
 ' Find the layer named states
 For iCount = 0 To pMap.LayerCount - 1
 Set pLayer = pMap.Layer(iCount)
 If TypeOf pLayer Is IFeatureLayer Then
 If pLayer.Name = sLayerName Then
 Set pFeatLayer = pLayer
 Exit For
 End If
 End If
 Next 
 If pFeatLayer Is Nothing Then
 MsgBox "The " ; sLayerName ; " layer was not found"
 Exit Sub
 End If
 ' Get the workspace of the states layer
 Set pFeatureClass = pFeatLayer.FeatureClass
 Set pTable = pFeatureClass
 Set pDataSet = pTable
 Set pWorkspace = pDataSet.Workspace
 Set pWorkspaceDataset = pWorkspace
 Set pWorkspaceName = pWorkspaceDataset.FullName
 ' Set up the output table
 Set pOutTableName = New TableName
 Set pOutDatasetName = pOutTableName
 pOutDatasetName.Name = sSumTableName
 Set pOutDatasetName.WorkspaceName = pWorkspaceName
 ' Make sure there is a field called SUB_REGION in the layer
 If pTable.FindField("SUB_REGION") = -1 Then
 MsgBox "There must be a field named SUB_REGION in states"
 Exit Sub
 End If
 ' Check if SumStates.dbf file already exist: if yes, delete it
 Set pEnumDataset = pWorkspace.Datasets(esriDTTable)
 Set pWorkspaceDataset = pEnumDataset.Next
 Do Until pWorkspaceDataset Is Nothing
 If pWorkspaceDataset.Name = pOutDatasetName.Name Then
 pWorkspaceDataset.Delete
 Exit Do
 End If
 Set pWorkspaceDataset = pEnumDataset.Next
 Loop
 ' Perform the summarize. Note the summary fields string (minimum.SUB_REGION ...)
 ' below. This is a comma-delimited string that lists the generated summary
 ' fields. Each field must start with a keyword, and be followed by .fieldName,
 ' where fieldName is the name of a field in the original table.
 '
 ' If you specify the Shape field, you must use the keyword 'Dissolve'. This
 ' is not used below since we are creating a non-spatial summary table.

 Set pBasicGeoprocessor = New BasicGeoprocessor
 Set pSumTable = pBasicGeoprocessor.Dissolve(pTable, False, "SUB_REGION", _
 "Minimum.SUB_REGION, Count.SUB_REGION, Sum.AREA, Average.AREA," ; _
 "Minimum.AREA, Maximum.AREA, StdDev.AREA, Variance.AREA", _
 pOutDatasetName)
 ' add the table to map
 Set pStandaloneTable = New StandaloneTable
 Set pStandaloneTable.Table = pSumTable
 Set pStandaloneTableColl = pMap
 pStandaloneTableColl.AddStandaloneTable pStandaloneTable
 ' Refresh the TOC
 pMxDocument.UpdateContents
 Exit Sub
ErrorHandler:
 MsgBox Err.Number ; " " ; Err.Description
End Sub

GIS麦田守望者，期待与您交流。

举报回复喜欢评分

gis

管理员

注册日期2003-07-16
发帖数15951
QQ
铜币25345枚
威望15368点
贡献值0点
银元0个

加关注写私信

74楼^#

发布于：2005-08-02 23:36

如何拷贝属性表中的一行
本例要实现的是如何将所有属性表（Attribute Table）中的行拷贝到Windows剪贴板，使用户能使用文本编辑器等软件对选中的数据做进一步编辑，从而满足特殊要求。行中的每个属性用半角字符的逗号“,”分隔，行间用换行符分隔。
l 要点
首先需要取得某属性表中的所有选中记录的全部属性，以一个字符串来存储。因为在属性表中选取中记录（Row）后，层中的相应记录（Feature）也将选中。两种途径都能获得所需属性值。
得到所需的字符串sResult后，就可以将其拷贝到剪贴板。在VB中剪贴板是全局对象。可像如下使用：
Clipboard.Clear
Clipboard.SetText sResult
本例将在VBA中实现相同的功能。用到了IGraphicsContianer、IGraphicsContainerSelect、ITextElement、IElement、IClipboardFormat接口。 
l 程序说明
过程UIBCopyRow_Click是实现模块，调用过程CopyRow实现功能。过程CopyRow将选中行的全部属性值（忽略Shape属性）连接成字符串，然后创建TextElement对象，并添加到IGraphicsContainer对象的选择集中，再调用TextClipboardFormat的Copy方法，把字符拷贝到Windows剪贴板。
l 代码
Option Explicit
Private Sub UIBCopyRow_Click()
 Call CopyRow
End Sub 
Public Sub CopyRow()
 Dim pMxDocument As IMxDocument
 Dim pMap As IMap
 Dim pActiveView As IActiveView
 Dim pGraphicsContainer As IGraphicsContainer
 Dim pGraphicsContainerS As IGraphicsContainerSelect
 Dim pFields As IFields
 Dim iCounter As Integer
 Dim iIndex As Integer
 Dim pTextElement As ITextElement
 Dim pElement As IElement
 Dim sResult As String
 Dim pEnumFeature As IEnumFeature
 Dim pEnumFeatureS As IEnumFeatureSetup
 Dim pFeature As IFeature
 Dim pClipboardFormat As IClipboardFormat
 On Error GoTo ErrorHandler
 ' Used for string operation on the clipboard
 Set pClipboardFormat = New TextClipboardFormat
 Set pMxDocument = ThisDocument
 Set pActiveView = pMxDocument.ActivatedView
 Set pMap = pMxDocument.FocusMap
 Set pGraphicsContainer = pMap
 ' Get selected features to retieve their attribute values
 Set pEnumFeature = pMap.FeatureSelection
 Set pEnumFeatureS = pEnumFeature
 pEnumFeatureS.AllFields = True
 Set pFeature = pEnumFeature.Next
 If pFeature Is Nothing Then
 MsgBox "No row selected"
 Exit Sub
 End If
 Set pFields = pFeature.Fields
 iCounter = pFields.FieldCount
 Do Until pFeature Is Nothing
 For iIndex = 0 To iCounter - 1
 If Not TypeOf pFeature.Value(iIndex) Is IGeometry Then
 sResult = sResult ; pFeature.Value(iIndex) ; ","
 End If
 Next iIndex
 ' Remove the trailing comma
 sResult = Left(sResult, Len(sResult) - 1)
 sResult = sResult ; vbNewLine
 Set pFeature = pEnumFeature.Next
 Loop
 ' If you're tending to build a dll to implement the same function and
 ' programming in VB enviroment, simply use the next to statement
 ' to copy the string into windows clippboard
 ' Clipboard.Clear
 ' Clipboard.SetText sResult
 ' Otherwise, programe as follows
 ' Copy the string into clippboard using objects included in esriCore
 
 ' To clear clippboard
 pClipboardFormat.Paste pMxDocument
 pGraphicsContainer.DeleteAllElements
 ' Construct a new TextElement with the string to copy into clipboard
 Set pTextElement = New TextElement
 pTextElement.Text = sResult
 Set pElement = pTextElement
 ' Point(100, 100) is for temporary use
 pElement.Geometry = pActiveView.ScreenDisplay.DisplayTransformation _
 .ToMapPoint(100, 100)
 Set pGraphicsContainer = pMap
 pGraphicsContainer.AddElement pElement, 0
 Set pGraphicsContainerS = pGraphicsContainer
 pGraphicsContainerS.UnselectAllElements
 pGraphicsContainerS.SelectElement pElement
 pClipboardFormat.copy pMxDocument
 pGraphicsContainerS.UnselectElement pElement
 pGraphicsContainer.DeleteElement pElement
 pActiveView.Refresh
 Exit Sub
ErrorHandler:
 MsgBox Err.Description
End Sub

GIS麦田守望者，期待与您交流。

举报回复喜欢评分

gis

管理员

注册日期2003-07-16
发帖数15951
QQ
铜币25345枚
威望15368点
贡献值0点
银元0个

加关注写私信

75楼^#

发布于：2005-08-02 23:36

如何打开选中的层或独立表的属性窗口
本例实现的是如何打开选中的层或独立表的属性窗口（Attribute Table）。主要用到ITableWindow和ITableWindow2接口。
l 要点
首先需要选中一个层或独立表。可在UI Button Cotrol的Enabled事件中测试用户选定了有效的对象后，才使按钮有效。
然后判断属性窗口是否已经打开。如果尚未打开，则创建新的ITableView2对象。
l 程序说明
过程UIBAttributeWindow_Click调用过程OpenAttribWnd实现功能。
函数UIBAttributeWindow_Enabled用来测试用户是否已正确选中了层或独立表，如果是，则使按钮有效。
过程OpenAttribWnd是功能模块，实现了属性窗口的测试和创建，以及显示。
l 代码
Option Explicit
Private Sub UIBAttributeWindow_Click()
 Call OpenAttribWnd
End Sub 
Private Function UIBAttributeWindow_Enabled() As Boolean
 Dim pMxDocument As IMxDocument
 Dim pSelectedItem As IUnknown
 Dim bEnabled As Boolean
 Set pMxDocument = ThisDocument
 Set pSelectedItem = pMxDocument.SelectedItem
 bEnabled = True
 ' Disable if the selected item is nothing or if
 ' it is not a layer or table
 If pSelectedItem Is Nothing Then
 bEnabled = False
 ElseIf (TypeOf pSelectedItem Is IFeatureLayer) Or (TypeOf pSelectedItem Is IStandaloneTable) Then
 bEnabled = True
 End If
 UIBAttributeWindow_Enabled = bEnabled
End Function 
Private Sub OpenAttribWnd()
 Dim pMxDocument As IMxDocument
 Dim pLayer As ILayer
 Dim pStandaloneTable As IStandaloneTable
 Dim pSelectedItem As IUnknown
 Dim pTableWindowExist As ITableWindow
 Dim pTableWindow2 As ITableWindow2
 Dim bSetProperties As Boolean
 On Error GoTo ErrorHandler:
 Set pMxDocument = ThisDocument
 Set pSelectedItem = pMxDocument.SelectedItem
 Set pTableWindow2 = New TableWindow
 ' Determine the selected item's type
 ' Exit sub if item is not a feature layer or standalone table
 If TypeOf pSelectedItem Is IFeatureLayer Then
 Set pLayer = pSelectedItem
 Set pTableWindowExist = pTableWindow2.FindViaLayer(pLayer)
 ' Check if a table already exist; if not create one
 If pTableWindowExist Is Nothing Then
 Set pTableWindow2.Layer = pLayer
 bSetProperties = True
 End If
 ElseIf TypeOf pSelectedItem Is IStandaloneTable Then
 Set pStandaloneTable = pSelectedItem
 Set pTableWindowExist = pTableWindow2.FindViaStandaloneTable(pStandaloneTable)
 ' Check if a table already exists; if not, create one
 If pTableWindowExist Is Nothing Then
 Set pTableWindow2.StandaloneTable = pStandaloneTable
 bSetProperties = True
 End If
 End If
 If bSetProperties Then
 pTableWindow2.TableSelectionAction = esriSelectFeatures
 pTableWindow2.ShowSelected = False
 pTableWindow2.ShowAliasNamesInColumnHeadings = True
 Set pTableWindow2.Application = Application
 Else
 Set pTableWindow2 = pTableWindowExist
 End If
 ' Ensure Table Is Visible
 If Not pTableWindow2.IsVisible Then
 pTableWindow2.Show True
 End If
 Exit Sub
ErrorHandler:
 MsgBox Err.Description
End Sub

GIS麦田守望者，期待与您交流。

举报回复喜欢评分

yxh1219

路人甲

注册日期2004-08-31
发帖数87
QQ
铜币106枚
威望0点
贡献值0点
银元0个

加关注写私信

76楼^#

发布于：2005-08-02 22:40

举报回复喜欢评分

gis

管理员

注册日期2003-07-16
发帖数15951
QQ
铜币25345枚
威望15368点
贡献值0点
银元0个

加关注写私信

77楼^#

发布于：2005-08-02 00:25

如何将Map中显示的图形转化成栅格文件
本例要实现的是如何将当前激活的Map中显示的图形转化成栅格文件。
l 要点
通过IMap实例获得IActiveView接口对象，定义IExporter接口变量，使用TiffExporter实现该接口并对其中的属性进行赋值，使用IActiveView.Output方法将Map中显示的图形导出。
主要用到IActiveView接口，IExporter接口和IEnvelope接口。
l 程序说明
函数Output将当前激活的Map中显示的图形转化成栅格文件，栅格文件路径及名称由参数sFileAllName确定。
l 代码

Private Sub Output(ByVal sFileAllName As String)
 Dim pMxDocument As IMxDocument
 Dim pActiveView As IActiveView
 Dim pExporter As IExporter
 Dim pEnvelope As IEnvelope
 Dim ptagRECT As tagRECT
 Dim pTrackCancel As ITrackCancel
 Dim lscreenResolution As Long 
On Error GoTo ErrorHandler:
 Set pMxDocument = ThisDocument
 Set pActiveView = pMxDocument.ActiveView
 lscreenResolution = pActiveView.ScreenDisplay.DisplayTransformation.Resolution
 ptagRECT.Top = 0
 ptagRECT.Left = 0
 ptagRECT.Right = pActiveView.Extent.Width
 ptagRECT.bottom = pActiveView.Extent.Height
 'We must calculate the size of the user specified Rectangle in Device units
 'Hence convert width and height
 Set pEnvelope = New Envelope
 pEnvelope.PutCoords ptagRECT.Left, ptagRECT.bottom, ptagRECT.Right, ptagRECT.Top
 Set pExporter = New TiffExporter
 pExporter.Resolution = lscreenResolution
 pExporter.ExportFileName = sFileAllName
 pExporter.PixelBounds = pEnvelope
 Set pTrackCancel = New CancelTracker
 pActiveView.Output pExporter.StartExporting, lscreenResolution, _
 ptagRECT, pActiveView.Extent, pTrackCancel
 
 pExporter.FinishExporting
 Exit Sub
ErrorHandler:
 MsgBox Err.Description
End Sub
Private Sub UIButtonControl1_Click()
 Dim pVBProject As VBProject
On Error GoTo ErrorHandler:
 Set pVBProject = ThisDocument.VBProject
 Output pVBProject.FileName ; "\..\..\..\.." ; "\data\MyTifFile.tif"
 Exit Sub
ErrorHandler:
 MsgBox Err.Description
End Sub

GIS麦田守望者，期待与您交流。

举报回复喜欢评分

gis

管理员

注册日期2003-07-16
发帖数15951
QQ
铜币25345枚
威望15368点
贡献值0点
银元0个

加关注写私信

78楼^#

发布于：2005-08-02 00:25

如何将shape文件转化成GeoDataBase(各种文件格式的转换)
本例演示的是如何将shape文件转化成personal GeoDatabase文件，其它格式间的与此转换类似。主要用到IFeatureDataConverter接口的ConvertFeatureClass方法。
l 要点
首先，创建新的GeoDataBase数据库，并创建IFeatureDatasetName对象。创建定义两个IFeatureClassName接口对象分别引用输入表（shape文件）和输出表。
然后设置输出表的Shape字段的GeormetryDef属性。这一步非常关键，因为其中包含了数据库和shape文件的空间参考信息。
最后调用IFeatureDataConverter.ConvertFeatureClass方法完成功能。
l 程序说明
过程UIBConvert_Click是实现模块，调用过程ConvertShapeToGeodatabase实现功能。
sDataPath定义了数据与工程文件的相对路径。SHAPE_NAME描述了要转化的shape文件的文件名。MDB_NAME和F_DS_NAME分别描述了Access数据库名和库的数据集的名称。
l 代码
Option Explicit
Private Sub UIBConvert_Click()
 Call ConvertShapeToGeodatabase
End Sub
Private Sub ConvertShapeToGeodatabase()
 Dim pOutWorkspaceFactory As IWorkspaceFactory
 Dim pOutWorkspaceName As IWorkspaceName
 Dim pInWorkspaceName As IWorkspaceName
 Dim pOutFeatureDSName As IFeatureDatasetName
 Dim pOutDSName As IDatasetName
 Dim pInFeatureClassName As IFeatureClassName
 Dim pInDatasetName As IDatasetName
 Dim pOutFeatureClassName As IFeatureClassName
 Dim pOutDatasetName As IDatasetName
 Dim iCounter As Long
 Dim pOutFields As IFields
 Dim pInFields As IFields
 Dim pFieldChecker As IFieldChecker
 Dim pGeoField As IField
 Dim pOutGeometryDef As IGeometryDef
 Dim pOutGeometryDefEdit As IGeometryDefEdit
 Dim pName As IName
 Dim pInFeatureClass As IFeatureClass
 Dim pShpToFeatClsConverter As IFeatureDataConverter
 Dim pVBProject As VBProject
 Dim sDataPath As String
 Const SHAPE_NAME As String = "country"
 Const MDB_NAME As String = "countryDB"
 Const F_DS_NAME As String = "World"
 On Error GoTo ErrorHandler
 Set pVBProject = ThisDocument.VBProject
 sDataPath = pVBProject.FileName ; "\..\..\..\..\data\"
 If Not "" = Dir(sDataPath ; MDB_NAME ; ".mdb") Then
 MsgBox MDB_NAME ; ".mdb already exist"
 Exit Sub
 Else
 ' Create a new Access database
 Set pOutWorkspaceFactory = New AccessWorkspaceFactory
 Set pOutWorkspaceName = pOutWorkspaceFactory.Create(sDataPath, MDB_NAME, Nothing, 0)
 ' create a new feature datset name object for the output Access feature dataset, call
 ' it "World"
 Set pOutFeatureDSName = New FeatureDatasetName
 Set pOutDSName = pOutFeatureDSName
 Set pOutDSName.WorkspaceName = pOutWorkspaceName
 pOutDSName.Name = F_DS_NAME
 ' Get the name object for the input shapefile workspace
 Set pInWorkspaceName = New WorkspaceName
 pInWorkspaceName.PathName = sDataPath
 pInWorkspaceName.WorkspaceFactoryProgID = _
 "esriCore.ShapefileWorkspaceFactory.1"
 Set pInFeatureClassName = New FeatureClassName
 Set pInDatasetName = pInFeatureClassName
 pInDatasetName.Name = SHAPE_NAME
 Set pInDatasetName.WorkspaceName = pInWorkspaceName
 ' Create the new output FeatureClass name object that will be passed
 ' into the conversion function
 Set pOutFeatureClassName = New FeatureClassName
 Set pOutDatasetName = pOutFeatureClassName
 ' Set the new FeatureClass name to be the same as the input FeatureClass name
 pOutDatasetName.Name = pInDatasetName.Name
 ' Open the input Shapefile FeatureClass object, so that we can get its fields
 Set pName = pInFeatureClassName
 Set pInFeatureClass = pName.Open
 ' Get the fields for the input feature class and run them through
 ' field checker to make sure there are no illegal or duplicate field names
 Set pInFields = pInFeatureClass.Fields
 Set pFieldChecker = New FieldChecker
 pFieldChecker.Validate pInFields, Nothing, pOutFields
 ' Loop through the output fields to find the geometry field
 For iCounter = 0 To pOutFields.FieldCount
 If pOutFields.Field(iCounter).Type = esriFieldTypeGeometry Then
 Set pGeoField = pOutFields.Field(iCounter)
 Exit For
 End If
 Next iCounter
 ' Get the geometry field's geometry definition
 Set pOutGeometryDef = pGeoField.GeometryDef
 ' Give the geometry definition a spatial index grid count and grid size
 Set pOutGeometryDefEdit = pOutGeometryDef
 pOutGeometryDefEdit.GridCount = 1
 pOutGeometryDefEdit.GridSize(0) = 1500000
 ' Now use IFeatureDataConverter::Convert to create the output FeatureDataset and
 ' FeatureClass.
 Set pShpToFeatClsConverter = New FeatureDataConverter
 pShpToFeatClsConverter.ConvertFeatureClass pInFeatureClassName, Nothing, _pOutFeatureDSName, pOutFeatureClassName, Nothing, pOutFields, "", 1000, 0 MsgBox "Convert operation complete!", vbInformation
 End If
 Exit Sub
ErrorHandler:
 MsgBox Err.Description
End Sub

GIS麦田守望者，期待与您交流。

举报回复喜欢评分

gis

管理员

注册日期2003-07-16
发帖数15951
QQ
铜币25345枚
威望15368点
贡献值0点
银元0个

加关注写私信

79楼^#

发布于：2005-08-02 00:24

如何进行层与层之间的逻辑运算
 
本例要实现的是将两个同一GeometryType图层联合成为一个图层，输出Shape文件，并且加载到Map中显示出来。
l 要点
定义ITable的两个接口变量，通过两个图层FeatureClass实例化。然后由接口IFeatureClassName、IWorkspaceName和IDatasetName实现创建一个新的shape文件。再创建IBasicGeoprocessor接口对象，使用IBasicGeoprocessor.Union方法实现两个图层的联合。
l 程序说明
过程UIButtonControl1_Click是实现模块。
l 代码

Option Explicit
Private Sub UIButtonControl1_Click()
 Dim pMxDoc As IMxDocument
 Dim pLayer As ILayer
 Dim pInputTable As ITable
 Dim pOverlayTable As ITable
 Dim pFeatClassName As IFeatureClassName
 Dim pNewWSName As IWorkspaceName
 Dim pDatasetName As IDatasetName
 Dim dtol As Double
 Dim pBasicGeop As IBasicGeoprocessor
 Dim pOutputFeatClass As IFeatureClass
 Dim pOutputFeatLayer As IFeatureLayer
 Dim App As VBProject
On Error GoTo ErrorHandler:
 Set pMxDoc = ThisDocument
 Set pLayer = pMxDoc.FocusMap.Layer(0)
 Set App = ThisDocument.VBProject
 ' Get the input table
 ' Use the Itable interface from the Layer (not from the FeatureClass)
 Set pInputTable = pLayer
 ' Get the overlay layer and table
 ' Use the Itable interface from the Layer (not from the FeatureClass)
 Set pLayer = pMxDoc.FocusMap.Layer(1)
 Set pOverlayTable = pLayer
 ' Error checking
 If pInputTable Is Nothing Then
 MsgBox "Table QI failed"
 Exit Sub
 End If
 If pOverlayTable Is Nothing Then
 MsgBox "Table QI failed"
 Exit Sub
 End If
 ' Define the output feature class name
Set pFeatClassName = New FeatureClassName
' Set output location and feature class name
Set pNewWSName = New WorkspaceName
pNewWSName.WorkspaceFactoryProgID = "esriCore.ShapeFileWorkspaceFactory.1"
 pNewWSName.PathName = App.FileName ; "\.."
 Set pDatasetName = pFeatClassName
 pDatasetName.Name = "Union_result"
 Set pDatasetName.WorkspaceName = pNewWSName
 ' Set the tolerance. Passing 0.0 causes the default tolerance to be used.
 ' The default tolerance is 1/10,000 of the extent of the data frame's spatial domain
 dtol = 0#
 ' Perform the union
 Set pBasicGeop = New BasicGeoprocessor
 Set pOutputFeatClass = pBasicGeop.Union(pInputTable, False, pOverlayTable, False, _dtol, pFeatClassName)
 ' Add the output layer to the map
 Set pOutputFeatLayer = New FeatureLayer
 Set pOutputFeatLayer.FeatureClass = pOutputFeatClass
 pOutputFeatLayer.Name = pOutputFeatClass.AliasName
 pMxDoc.FocusMap.AddLayer pOutputFeatLayer
 Exit Sub
ErrorHandler:
 MsgBox Err.Description
End Sub

GIS麦田守望者，期待与您交流。

举报回复喜欢评分

您需要登录后才可以回帖，登录或者注册