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

gis

管理员

注册日期2003-07-16
发帖数15947
QQ554730525
铜币25339枚
威望15364点
贡献值0点
银元0个

40楼^#

发布于：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

举报回复喜欢评分

yxh1219

路人甲

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

加关注写私信

41楼^#

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

举报回复喜欢评分

gis

管理员

注册日期2003-07-16
发帖数15947
QQ554730525
铜币25339枚
威望15364点
贡献值0点
银元0个

加关注写私信

42楼^#

发布于：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

管理员

注册日期2003-07-16
发帖数15947
QQ554730525
铜币25339枚
威望15364点
贡献值0点
银元0个

加关注写私信

43楼^#

发布于：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

管理员

注册日期2003-07-16
发帖数15947
QQ554730525
铜币25339枚
威望15364点
贡献值0点
银元0个

加关注写私信

44楼^#

发布于：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

管理员

注册日期2003-07-16
发帖数15947
QQ554730525
铜币25339枚
威望15364点
贡献值0点
银元0个

加关注写私信

45楼^#

发布于：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

管理员

注册日期2003-07-16
发帖数15947
QQ554730525
铜币25339枚
威望15364点
贡献值0点
银元0个

加关注写私信

46楼^#

发布于：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

管理员

注册日期2003-07-16
发帖数15947
QQ554730525
铜币25339枚
威望15364点
贡献值0点
银元0个

加关注写私信

47楼^#

发布于：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

管理员

注册日期2003-07-16
发帖数15947
QQ554730525
铜币25339枚
威望15364点
贡献值0点
银元0个

加关注写私信

48楼^#

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

如何实现在ArcMap中放大缩小地图
用户点击按钮后，可以在地图上进行点击或者拖放矩形框来放大缩小地图
l 要点
因为考虑到用户可以单击放大缩小，也可以拖放矩形框来放大缩小，所以不可以直接使用IRubberBand接口，而是采用INewEnvelopeFeedback接口
l 程序说明
主要通过InewEnvelopeFeedback.StartPoint 和MoveTo方法来绘制矩形框，然后赋值给IActiveView.Extend属性，达到地图的放大缩小
l 代码

Private m_pFeedbackEnv As INewEnvelopeFeedback Private m_pPoint As IPoint Private m_bIsMouseDown As Boolean Private m_pActiveView As IActiveView 
Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, ByVal x As Long, _ByVal y As Long) Dim pMxDocument As IMxDocument On Error GoTo ErrorHandler: 'Left Button Check If button <> 1 Then Exit Sub If m_pActiveView Is Nothing Then Set pMxDocument = ThisDocument Set m_pActiveView = pMxDocument.ActivatedView End If '得到起始点 Set m_pPoint = m_pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y) m_bIsMouseDown = True Exit Sub ErrorHandler: MsgBox Err.Description End Sub 
Private Sub UIToolControl1_MouseMove(ByVal button As Long, ByVal shift As Long, ByVal x As Long, _ByVal y As Long) On Error GoTo ErrorHandler: If Not m_bIsMouseDown Then Exit Sub If m_pFeedbackEnv Is Nothing Then Set m_pFeedbackEnv = New NewEnvelopeFeedback Set m_pFeedbackEnv.Display = m_pActiveView.ScreenDisplay m_pFeedbackEnv.Start m_pPoint End If Set m_pPoint = m_pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y) 'Draw Envelope m_pFeedbackEnv.MoveTo m_pPoint Exit Sub ErrorHandler: MsgBox Err.Description End Sub
Private Sub UIToolControl1_MouseUp(ByVal button As Long, ByVal shift As Long, ByVal x As Long, _ByVal y As Long) Dim pEnv As IEnvelope On Error GoTo ErrorHandler: 'Left Button Check If button <> 1 Then Exit Sub If (m_pFeedbackEnv Is Nothing) Then 'User Only Click Map with left button Set pEnv = m_pActiveView.Extent '如果是缩小的话，将这里的两个0.5都改成1.5 pEnv.Expand 0.5, 0.5, True Else 'User Draw a Envelope Set pEnv = m_pFeedbackEnv.Stop End If m_pActiveView.Extent = pEnv m_bIsMouseDown = False Set m_pPoint = Nothing Set m_pFeedbackEnv = Nothing m_pActiveView.Refresh Exit Sub ErrorHandler: MsgBox Err.Description End Sub

举报回复喜欢评分

lyw505

卧底

注册日期2004-12-04
发帖数205
QQ52498211
铜币3枚
威望0点
贡献值0点
银元0个

加关注写私信

49楼^#

发布于：2005-08-07 17:25

vb环境下，利用AO组件开发Active.DLL。关键是要引用Arcobjects的对象库和实现arcobjects接口（如Icommand,Itool,Itoolbar等），请问如何实现接口？

Y.W.Lau qq:52498211 email:jxgis@126.com msn:lyw505@hotmail.com popo:jxgisrd@163.com

举报回复喜欢评分

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