ArcEngine开发代码集合

c#制作Symbol选择对话框

现在要实现双击toccontrol中的某一层的symbol调出symbol选择对话框.vb中有示例实现了类似于arcmap中的symbol选择对话框,用到了ISymbolSelector接口. 你看的是AO 的例子，在ENGINE中是没有这个接口的，不过这个例子转换成C＃的代码如下：

private void axTOCCtl_OnDoubleClick(object sender, ESRI.ArcGIS.TOCControl.ITOCControlEvents_OnDoubleClickEvent e)

{

IBasicMap map = null;

object pOther = null;

object index = null;

if (e.button==1)

{

m_TOCControl.HitTest(e.x, e.y, ref m_TocItem, ref map, ref m_TocLayer, ref pOther, ref index);

System.Drawing.Point pos=new System.Drawing.Point(e.x,e.y);

if (this.m_TocItem == esriTOCControlItem.esriTOCControlItemLegendClass)

{

ESRI.ArcGIS.Carto.ILegendClass pLC=new LegendClassClass();

ESRI.ArcGIS.Carto.ILegendGroup pLG=new LegendGroupClass();

if(pOther is ILegendGroup)

{

pLG=(ILegendGroup)pOther;

}

pLC=pLG.get_Class((int)index);

ISymbol pSym;

pSym=pLC.Symbol;

ESRI.ArcGIS.DisplayUI.ISymbolSelector pSS=new ESRI.ArcGIS.DisplayUI.SymbolSelectorClass();

bool bOK=false;

pSS.AddSymbol(pSym);

bOK=pSS.SelectSymbol(0);

if (bOK)

{

pLC.Symbol=pSS.GetSymbolAt(0);

}

this.axMapCtl.ActiveView.Refresh();

this.axTOCCtl.Refresh();

}

}

}

那么在c#中怎么实现呢?有相应的接口吗?

如何实现在MAP空间里选择一块区域打印

如何实现在MAP空间里选择一块区域打印?用ARCENGINE里的对象实现,大家都来说说啊

把选择的区域对每一个图层做区域切割进保存为shap文件在本地．

在对每一个图层做shap文件保存的时候，同时把保存好的shap文件用本地文件的方式加载到一个MapControl控件（或者其它控件，我是自己用PictureBox来显示地图的）．

然后通过控件把显示的地图数据打印出来就可以了．

其中对图层进行切割的代码如下：

'‖=================================================

'‖TrimFeatureClass2ShpFile：裁剪到shape文件

'‖

'‖pFC：裁剪的实体类

'‖pPolygon：裁剪的范围

'‖strShpFileName：输出的shape文件名

'‖bShowProgress：是否显示进度条

'‖pTrimedFeatureClass：输出的FeatureClass

'‖返回：输出的FeatureClass，nothing - 失败

'‖=================================================

Public Function TrimFeatureClass2ShpFile(pFC As esriGeoDatabase.IFeatureClass, pPolygon As esriGeometry.IPolygon, strShpFileName As String, bShowProgress As Boolean) As esriGeoDatabase.IFeatureClass

On Error GoTo ErrorHandler

Set TrimFeatureClass2ShpFile = Nothing

Dim i As Long

Dim pos As Long

Dim pFeatureCursor As esriGeoDatabase.IFeatureCursor

Dim pFeature As esriGeoDatabase.IFeature

Dim pNewFeatureCursor As esriGeoDatabase.IFeatureCursor

Dim pTopologicalOperator As esriGeometry.ITopologicalOperator

Dim pGeometry As esriGeometry.IGeometry

Dim pFeatureBuffer As esriGeoDatabase.IFeatureBuffer

Dim pFeatureCount As Long

Dim pTrimedFeatureClass As IFeatureClass

Dim nOldPercent As Integer

'获取数据库系统时间

Dim pSpatialFilter As esriGeoDatabase.ISpatialFilter

Set pSpatialFilter = New SpatialFilter

Dim pFeatureLayer As esriCarto.IFeatureLayer

With pSpatialFilter

'设置筛选器实体

Set .Geometry = pPolygon

'设置筛选字段

.GeometryField = pFC.ShapeFieldName

'设置空间关系

.SpatialRel = esriSpatialRelIntersects

'设置查询顺序

.SearchOrder = esriSearchOrderSpatial

End With

'获取筛选的实体个数

pFeatureCount = pFC.FeatureCount(pSpatialFilter)

'判断筛选个数为0

If pFeatureCount = 0 Then

Set pSpatialFilter = Nothing

Exit Function

End If

'创建新的SHAPE文件

Set pTrimedFeatureClass = CreateNewShapefile(pFC, strShpFileName)

'判断实体类为空

If pTrimedFeatureClass Is Nothing Then

'设置对象为空

Set pSpatialFilter = Nothing

Exit Function

End If

'获取实体指针

Set pFeatureCursor = pFC.Search(pSpatialFilter, False)

Set pSpatialFilter = Nothing

'获取实体

Set pFeature = pFeatureCursor.NextFeature

nOldPercent = 0

'获取插入实体指针

Set pNewFeatureCursor = pTrimedFeatureClass.Insert(True)

'判断实体不为空

Do While Not pFeature Is Nothing

'创建实体缓冲

Set pFeatureBuffer = pTrimedFeatureClass.CreateFeatureBuffer

If pFC.ShapeType = esriGeometryPolygon Then

' 若实体类型为面，则做相交

Set pTopologicalOperator = pPolygon

Set pGeometry = pTopologicalOperator.InterSect(pFeature.Shape,

esriGeometry2Dimension)

ElseIf pFC.ShapeType = esriGeometryPolyline Then

'若实体类型为线

Set pGeometry = PolygonIntersectPolyline(pPolygon, pFeature.Shape) ElseIf pFC.ShapeType = esriGeometryPoint Then

' 若实体类型为点，则全是

Set pGeometry = pFeature.Shape

ElseIf pFC.ShapeType = esriGeometryMultipoint Then

' 若实体类型为多点

Set pGeometry = PolygonIntersectMultiPoint(pPolygon, pFeature.Shape) Else

MsgBox "不做任何裁剪！"

' 若实体类型为除点、线、面外的类型，不做裁剪

Exit Function

End If

'判断实体不为空

If Not pGeometry Is Nothing Then

If Not pGeometry.IsEmpty Then

'获取实体

Set pFeatureBuffer.Shape = pGeometry

For i = 0 To pFeature.Fields.fieldCount - 1

' 因shape字段最长只能为10位，故只比较前10位

pos = pFeatureBuffer.Fields.FindField(Left(pFeature.Fields.field(i).Name, 10))

If pos >= 0 Then

'判断实体字段类型不为几何类型并且不为OID类型并且字段可编辑并且字段不为空

If Not pFeatureBuffer.Fields.field(pos).Type = esriFieldTypeGeometry And _

Not pFeatureBuffer.Fields.field(pos).Type = esriFieldTypeOID And _

pFeatureBuffer.Fields.field(pos).Editable And _

Not IsNull(pFeature.value(i)) Then

'获取字段值

pFeatureBuffer.value(pos) = pFeature.value(i)

End If

End If

Next i

'插入实体

pNewFeatureCursor.InsertFeature pFeatureBuffer

End If

End If

'获取实体

Set pFeature = pFeatureCursor.NextFeature

If bShowProgress Then

With frmProgress

'进度条当前值加一

.ProgressBar1.value = .ProgressBar1.value + 1

If Int(.ProgressBar1.value * 100 / .ProgressBar1.Max) > nOldPercent Then

.Statuslbl1.Caption = "正在导出" & pFC.AliasName & "层，请稍候..." & Format(.ProgressBar1.value / .ProgressBar1.Max, "###%")

nOldPercent = Int(.ProgressBar1.value * 100 / .ProgressBar1.Max)

pNewFeatureCursor.Flush

DoEvents

End If

End With

End If

Loop

pNewFeatureCursor.Flush

Set TrimFeatureClass2ShpFile = pTrimedFeatureClass

Exit Function

ErrorHandler:

Debug.Print Err.number & " " & Err.Description, vbCritical, "TrimFeatureClass" End Function

以上代码要进行调试一下，因为有一些业务代码本人做了删除．

承接、合作各种GIS项目开发

：ArcGIS平（基于AO、AE、ArcIMS、ArcServer开发）

：MapInfo平台（基于MapXtreme 2004/2005、MapXtreme For Java开发）

E-Mail：cmcrj0929@fc37a53ab84ae45c3b358c70

QQ：31814576

有国土、市政、交通、电力等行业的成功应用项目经验。

自己做插值程序，想和大家分享

'''''by kisssy

'''''Kriging 以克里金插值为例

''''strName1:A string that represents your FeatureClass Path

''''strName2:A string that represents the FeatureClass Name

''''sFieldName:the field for Interpolation

Public Function Kriging(strName1 As String, strName2 As String,sFieldName As String) As IRasterLayer '克里金

'''''''''''''''''''''''''''''''''操作符

Dim pInterpolationOp As IInterpolationOp

Set pInterpolationOp = New RasterInterpolationOp

'''''''''''''''''''''''''''''''''操作环境

Dim pEnv As IRasterAnalysisEnvironment

Set pEnv = pInterpolationOp

'''''add shape for setting mask , this is optional

Dim pFlayer As IFeatureLayer

Set pFlayer = addShp(App.Path + "\Data\BaseDB\JiChuDiLi\city", "大同") 'your shp 'path

Dim pGeoDB As IGeoDataset

Set pGeoDB = pFlayer.FeatureClass

Dim pEnvelop As IEnvelope

Set pEnvelop = pGeoDB.Extent

pEnv.SetExtent esriRasterEnvValue, pEnvelop

Set pEnv.Mask = pGeoDB

''''set cell size

pEnv.SetCellSize esriRasterEnvValue, 600 '600:cellsize

'''''''''''''''''''''''''''''''''''设置FeatureClassDescriptor

Dim pFClass As IFeatureClass

Set pFClass = OpenFC2(strName1, strName2)

Dim pFDescriptor As IFeatureClassDescriptor

Set pFDescriptor = New FeatureClassDescriptor

pFDescriptor.Create pFClass, Nothing, sFieldName

'''''''''''''''''''''''''''''''''设置搜索半径

Dim pRadius As IRasterRadius

Set pRadius = New RasterRadius

pRadius.SetVariable 12 'your variant

''''''''''''''''''''''''''''''调用Kriging

Dim pOutputRaster As IRaster

Set pOutputRaster = pInterpolationOp.Krige(pFDescriptor, esriGeoAnalysisSphericalSemiVariogram, pRadius, True)

'esriGeoAnalysisSphericalSemiVariogram is 'esriGeoAnalysisSemiVariogramEnum

'''''''''''''''''''''''''''''输出Raster

Dim pOutRasLayer As IRasterLayer

Set pOutRasLayer = New RasterLayer

pOutRasLayer.CreateFromRaster pOutputRaster

'''''''''''''''''''''''''着色

UsingRasterClassifyColorRampRenderer pOutRasLayer

Set Kriging = pOutRasLayer

End Function

Public Function addShp(strPath As String, strFcname As String) As IFeatureLayer ''''Open WorkSpace

Dim myFWKS As IFeatureWorkspace

Dim myWKSF As IWorkspaceFactory

Set myWKSF = New ShapefileWorkspaceFactory

Set myFWKS = myWKSF.OpenFromFile(strPath, 0)

If Not myFWKS Is Nothing Then

''''Open

Dim myFC As IFeatureClass

Set myFC = myFWKS.OpenFeatureClass(strFcname)

Dim myDS As IDataset

Set myDS = myFC

Dim myFLayer As IFeatureLayer

Set myFLayer = New FeatureLayer

Set myFLayer.FeatureClass = myFC

fc37a53ab84ae45c3b358c70 = fc37a53ab84ae45c3b358c70

Set addShp = myFLayer

End If

End Function

Public Function OpenFC2(strPath As String, strFcname As String) As IFeatureClass ''''Open WorkSpace

Dim myFWKS As IFeatureWorkspace

Dim myWKSF As IWorkspaceFactory

Set myWKSF = New ShapefileWorkspaceFactory

Set myFWKS = myWKSF.OpenFromFile(strPath, 0)

If Not myFWKS Is Nothing Then

''''Open

Set OpenFC2 = myFWKS.OpenFeatureClass(strFcname)

End If

End Function

Public Sub UsingRasterClassifyColorRampRenderer(pRlayer As IRasterLayer)

' ' We're going to create StatsHistogram

Dim pRaster As IRaster

Set pRaster = pRlayer.Raster

Dim pStatsHist As IStatsHistogram

Set pStatsHist = New StatsHistogram

Dim pCalStatsHist As IRasterCalcStatsHistogram

Set pCalStatsHist = New RasterCalcStatsHistogram

fc37a53ab84ae45c3b358c70puteFromRaster pRaster, 0, pStatsHist

' ' and then classify this data

Dim pClassify As IClassify

Set pClassify = New EqualInterval

Dim pClassMaxMin As IClassifyMinMax

Set pClassMaxMin = pClassify

pClassMaxMin.Maximum = pStatsHist.Max

pClassMaxMin.Minimum = pStatsHist.Min

Dim Classes() As Double

Dim ClassesCount As Long

Dim numDesiredClasses As Long

'pClassify.Classify numDesiredClasses

pClassify.Classify 8 'class count Classes = pClassify.ClassBreaks

ClassesCount = UBound(Classes)

'Create classfy renderer and QI RasterRenderer interface

Dim pClassRen As IRasterClassifyColorRampRenderer

Set pClassRen = New RasterClassifyColorRampRenderer

Dim pRasRen As IRasterRenderer

Set pRasRen = pClassRen

'Set raster for the render and update

Set pRasRen.Raster = pRaster

pClassRen.ClassCount = ClassesCount

pRasRen.Update

'Create a color ramp to use

Dim pRamp As IAlgorithmicColorRamp

Dim pColor As IColor

Set pColor = New RgbColor

Set pRamp = New AlgorithmicColorRamp

pRamp.Size = ClassesCount

pColor.RGB = RGB(0, 0, 255) 'your color

pRamp.FromColor = pColor

pColor.RGB = RGB(255, 0, 0)

pRamp.ToColor = pColor

pRamp.Algorithm = 1

pRamp.CreateRamp True

'Create symbol for the classes

Dim pFSymbol As IFillSymbol

Set pFSymbol = New SimpleFillSymbol

'loop through the classes and apply the color and label Dim i As Integer

For i = 0 To pClassRen.ClassCount - 1

pFSymbol.Color = pRamp.Color(i)

pClassRen.Symbol(i) = pFSymbol

pClassRen.Break(i) = Classes(i + 1)

Next i

'Update the renderer and plug into layer

pRasRen.Update

Set pRlayer.Renderer = pClassRen

Set pRaster = Nothing

Set pRasRen = Nothing

Set pClassRen = Nothing

Set pRamp = Nothing

Set pFSymbol = Nothing

End Sub

希望看到大家发出更好的学习成果,给个介绍先:)

Inverse Distance to a Power（反距离加权插值法）

Kriging（克里金插值法）

Minimum Curvature（最小曲率）

Modified Shepard's Method（改进谢别德法）

Natural Neighbor（自然邻点插值法）

Nearest Neighbor（最近邻点插值法）

Polynomial Regression（多元回归法）

Radial Basis Function（径向基函数法）

Triangulation with Linear Interpolation（线性插值三角网法）

Moving Average（移动平均法）

Local Polynomial（局部多项式法）

下面简单说明不同算法的特点。

1、距离倒数乘方法

距离倒数乘方格网化方法是一个加权平均插值法，可以进行确切的或者圆滑的方式插值。方次参数控制着权系数如何随着离开一个格网结点距离的增加而下降。对于一个较大的方次，较近的数据点被给定一个较高的权重份额，对于一个较小的方次，权重比较均匀地分配给各数据点。计算一个格网结点时给予一个特定数据点的权值与指定方次的从结点到观测点的该结点被赋予距离倒数成比例。当计算一个格网结点时，配给的权重是一个分数，所有权重的总和等于1.0。当一个观测点与一个格网结点重合时，该观测点被给予一个实际为 1.0 的权重，所有其它观测点被给予一个几乎为 0.0 的权重。换言之，该结点被赋给与观测点一致的值。这就是一个准确插值。距离倒数法的特征之一是要在格网区域内产生围绕观测点位置的"牛眼"。用距离倒数格网化时可以指定一个圆滑参数。大于零的圆滑参数保证，对于一个特定的结点，没有哪个观测点被赋予全部的权值，即使观测点与该结点重合也是如此。圆滑参数通过修匀已被插值的格网来降低"牛眼"影响。

2、克里金法

克里金法是一种在许多领域都很有用的地质统计格网化方法。克里金法试图那样表示隐含在你的数据中的趋势，例如，高点会是沿一个脊连接，而不是被牛眼形等值线所孤立。克里金法中包含了几个因子：变化图模型，漂移类型和矿块效应。

3、最小曲率法

最小曲率法广泛用于地球科学。用最小曲率法生成的插值面类似于一个通过各个数据值的，具有最小弯曲量的长条形薄弹性片。最小曲率法，试图在尽可能严格地尊重数据的同时，生

成尽可能圆滑的曲面。使用最小曲率法时要涉及到两个参数：最大残差参数和最大循环次数参数来控制最小曲率的收敛标准。

4、多元回归法

多元回归被用来确定你的数据的大规模的趋势和图案。你可以用几个选项来确定你需要的趋势面类型。多元回归实际上不是插值器，因为它并不试图预测未知的 Z 值。它实际上是一个趋势面分析作图程序。使用多元回归法时要涉及到曲面定义和指定XY的最高方次设置，曲面定义是选择采用的数据的多项式类型，这些类型分别是简单平面、双线性鞍、二次曲面、三次曲面和用户定义的多项式。参数设置是指定多项式方程中 X 和 Y组元的最高方次。

5、径向基本函数法

径向基本函数法是多个数据插值方法的组合。根据适应你的数据和生成一个圆滑曲面的能力，其中的复二次函数被许多人认为是最好的方法。所有径向基本函数法都是准确的插值器，它们都要为尊重你的数据而努力。为了试图生成一个更圆滑的曲面，对所有这些方法你都可以引入一个圆滑系数。你可以指定的函数类似于克里金中的变化图。当对一个格网结点插值时，这些个函数给数据点规定了一套最佳权重。

6、谢别德法

谢别德法使用距离倒数加权的最小二乘方的方法。因此，它与距离倒数乘方插值器相似，但它利用了局部最小二乘方来消除或减少所生成等值线的"牛眼"外观。谢别德法可以是一个准确或圆滑插值器。在用谢别德法作为格网化方法时要涉及到圆滑参数的设置。圆滑参数是使谢别德法能够象一个圆滑插值器那样工作。当你增加圆滑参数的值时，圆滑的效果越好。

7、三角网/线形插值法

三角网插值器是一种严密的插值器，它的工作路线与手工绘制等值线相近。这种方法是通过在数据点之间连线以建立起若干个三角形来工作的。原始数据点的连结方法是这样：所有三角形的边都不能与另外的三角形相交。其结果构成了一张覆盖格网范围的，由三角形拼接起来的网。每一个三角形定义了一个覆盖该三角形内格网结点的面。三角形的倾斜和标高由定义这个三角形的三个原始数据点确定。给定三角形内的全部结点都要受到该三角形的表面的限制。因为原始数据点被用来定义各个三角形，所以你的数据是很受到尊重的。

8.自然邻点插值法

自然邻点插值法(NaturalNeighbor)是Surfer7.0才有的网格化新方法。自然邻点插值法广泛应用于一些研究领域中。其基本原理是对于一组泰森(Thiessen)多边形,当在数据集中加入一个新的数据点(目标)时,就会修改这些泰森多边形,而使用邻点的权重平均值将决定待插点的权重,待插点的权重和目标泰森多边形成比例[9]。实际上,在这些多边形中,有一些多

边形的尺寸将缩小,并且没有一个多边形的大小会增加。同时,自然邻点插值法在数据点凸起的位置并不外推等值线(如泰森多边形的轮廓线)。

9.最近邻点插值法

最近邻点插值法(NearestNeighbor)又称泰森多边形方法,泰森多边形(Thiesen,又叫Dirichlet或Voronoi多边形)分析法是荷兰气象学家A.H.Thiessen提出的一种分析方法。最初用于从离散分布气象站的降雨量数据中计算平均降雨量,现在GIS和地理分析中经常采用泰森多边形进行快速的赋值[2]。实际上,最近邻点插值的一个隐含的假设条件是任一网格点p(x,y)的属性值都使用距它最近的位置点的属性值,用每一个网格节点的最邻点值作为待的节点值[3]。当数据已经是均匀间隔分布,要先将数据转换为SURFER的网格文件,可以应用最近邻点插值法;或者在一个文件中,数据紧密完整,只有少数点没有取值,可用最近邻点插值法来填充无值的数据点。有时需要排除网格文件中的无值数据的区域,在搜索椭圆(SearchEllipse)设置一个值,对无数据区域赋予该网格文件里的空白值。设置的搜索半径的大小要小于该网格文件数据值之间的距离,所有的无数据网格节点都被赋予空白值。在使用最近邻点插值网格化法,将一个规则间隔的XYZ数据转换为一个网格文件时,可设置网格间隔和XYZ数据的数据点之间的间距相等。最近邻点插值网格化法没有选项,它是均质且无变化的,对均匀间隔的数据进行插值很有用,同时,它对填充无值数据的区域很有效。

怎么即时更新地图比例尺阿

放一个text用来显示比例尺1:xxxx, 每次地图放大缩小后, 比例尺都自动更新, 有没有类似的例子, c#和vb都可以, 多谢

在每次放大缩小后调用如下代码,即可实现比例尺动态更新:

Dim dblMapScale As Double

Dim pMap As IMap

If Not pMap Is Nothing Then

dblMapScale = pMap.MapScale

text.Text = "1:" & Format(dblMapScale, "#0.000")

text.Refresh()

End If

arcengine如何新建新图层

用arcengine如何新建一个全新图层呢？我想这应该还涉及到图层类型，图层数据结构的确立吧．大家有知道的请指教了！

How to use:

拷贝代码到你的VB 或者VBA 程序里.

在你的程序里Call下面的函数.

Public Sub CreateShapefile()

Const strFolder As String = "D:\Data"

Const strName As String = "MyShapeFile" ' Dont include .shp extension

Const strShapeFieldName As String = "Shape"

' Open the folder to contain the shapefile as a workspace

Dim pFWS As IFeatureWorkspace

Dim pWorkspaceFactory As IWorkspaceFactory

Set pWorkspaceFactory = New ShapefileWorkspaceFactory

Set pFWS = pWorkspaceFactory.OpenFromFile(strFolder, 0)

' Set up a simple fields collection

Dim pFields As IFields

Dim pFieldsEdit As IFieldsEdit

Set pFields = New esriCore.Fields

Set pFieldsEdit = pFields

Dim pField As IField

Dim pFieldEdit As IFieldEdit

' Make the shape field

' it will need a geometry definition, with a spatial reference

Set pField = New esriCore.Field

Set pFieldEdit = pField

fc37a53ab84ae45c3b358c70 = strShapeFieldName

pFieldEdit.Type = esriFieldTypeGeometry

Dim pGeomDef As IGeometryDef

Dim pGeomDefEdit As IGeometryDefEdit

Set pGeomDef = New GeometryDef

Set pGeomDefEdit = pGeomDef

With pGeomDefEdit

.GeometryType = esriGeometryPolygon

Set .SpatialReference = New UnknownCoordinateSystem

End With

Set pFieldEdit.GeometryDef = pGeomDef

pFieldsEdit.AddField pField

' Add another miscellaneous text field

Set pField = New esriCore.Field

Set pFieldEdit = pField

With pFieldEdit

.Length = 30

.Name = "MiscText"

.Type = esriFieldTypeString

End With

pFieldsEdit.AddField pField

' Create the shapefile

' (some parameters apply to geodatabase options and can be defaulted as Nothing)

Dim pFeatClass As IFeatureClass

Set pFeatClass = pFWS.CreateFeatureClass(strName, pFields, Nothing, _

Nothing, esriFTSimple, strShapeFieldName, "")

End Sub

如何实现TOC控件里的图层拖动

用TOCControl控件绑定mapcontrol，想在TOCControl里实现图层的拖动，从而改变指定图层在图层组或图层间的位置。

我发现TOCControl控件本身好像没有这样的功能，程序写起来很复杂，总是出现很多问题。想请教各位高手有没有这样的例子给予参考，请指教！谢谢!

Private Sub TOCLayer_OnMouseDown(ByVal button As Long, ByVal shift As Long, ByVal x As Long, ByVal y As Long)

If button = 1 Then

Dim pMap As IMap

Dim pLayer As ILayer

Dim pLegendGroup As ILegendGroup

Dim pItem As esriTOCControlItem

Dim pIndex As Variant

Set pSelSymLayer = Nothing

'点击图层或者图例

TOCLayer.HitTest x, y, pItem, pMap, pLayer, pLegendGroup, pIndex

If pLayer Is Nothing Then Exit Sub

If pItem = esriTOCControlItemLayer Then

'点中的是注记中的sublayer就退出

If TypeOf pLayer Is IAnnotationSublayer Then Exit Sub

Set pSelSymLayer = pLayer

ElseIf pItem = esriTOCControlItemLegendClass Then

'点中的是图例

If TypeOf pLayer Is IFeatureLayer Then

......

ElseIf button = 2 Then

'传出的参数pItem,pLayer, pLegendGroup, pIndex

m_pTocControl.HitTest x, y, pItem, pMap, pLayer, pLegendGroup, pIndex m_pMapControl.CustomProperty = pLayer

'点中的是注记中的sublayer就退出

If pLayer Is Nothing Then GoTo err0

If TypeOf pLayer Is IAnnotationSublayer Then Exit Sub

err0:

Set pSelSymLayer = pLayer

'弹出上下文菜单

......

End Sub

Private Sub TOCLayer_OnMouseMove(ByVal button As Long, ByVal shift As Long, ByVal x As Long, ByVal y As Long)

Dim pMap As IMap

Dim pLayer As ILayer

Dim pOther As IUnknown

Dim pItem As esriTOCControlItem

Dim pIndex As Variant

'实现调整图层顺序功能

If (button = vbLeftButton) Then

TOCLayer.HitTest x, y, pItem, pMap, pLayer, pOther, pIndex

End If

If pItem <> esriTOCControlItemNone Then

Set TOCLayer.MouseIcon = LoadResPicture("move", vbResCursor)

Me.TOCLayer.MousePointer = esriPointerCustom

End If

End Sub

Private Sub TOCLayer_OnMouseUp(ByVal button As Long, ByVal shift As Long, ByVal x As Long, ByVal y As Long)

Dim pMap As IMap

Dim pLayer As ILayer

Dim pOther As IUnknown

Dim pItem As esriTOCControlItem

Dim pIndex As Variant

Dim i As Integer, j As Integer

Dim bUpdataToc As Boolean

Me.TOCLayer.MousePointer = esriPointerArrow

'实现调整图层顺序功能

If (button = vbLeftButton) Then

TOCLayer.HitTest x, y, pItem, pMap, pLayer, pOther, pIndex

End If

If pItem = esriTOCControlItemLayer Or esriTOCControlItemLegendClass Then

If (pLayer Is Nothing) Or (pSelSymLayer Is Nothing) Or (pSelSymLayer Is pLayer) Then Exit Sub

If (button = vbLeftButton) Then

For i = 0 To fc37a53ab84ae45c3b358c70yerCount - 1

Dim pLayTmp As ILayer

Set pLayTmp = fc37a53ab84ae45c3b358c70yer(i)

'得到点击当前的索引值

If pLayer Is pLayTmp Then Exit For

Next i

'防止多次刷新

TreeRedraw Me.TOCLayer.hwnd, False

On Error Resume Next

pActiveMap.MoveLayer pSelSymLayer, i

On Error GoTo 0

TreeRedraw Me.TOCLayer.hwnd, True

End If

End If

End Sub

pSelSymLayer为当前需要移动的图层

非常感谢water blue，：）。但是出现一个问题，就是拖动图层的时候，刷新的特别厉害（不断的刷新），我看你那里用了一个TreeRedraw，不知道如何避免刷新的，请求赐教，谢谢！

不要在mousemove中实现pActiveMap.MoveLayer pSelSymLayer, i

定义i为全局变量，在mouseup中实现该语句，就可以防止刷新问题了

'控制对象是否重绘

Public Sub TreeRedraw(ByVal lHWnd As Long, ByVal bRedraw As Boolean)

SendMessage lHWnd, WM_SETREDRAW, bRedraw, 0

End Sub

调用这个函数！就可以防止刷新，很多地方都用的到的！

VBA+AO入门50例完全注释版

网上下的码，自己加的注。

初学，瞎搞，不好，见笑。

和跟我一样的初学者探讨一下怎么入门最快最好，为中国GIS教育事业添一根小火柴

1.

Sub MyMacro()

Dim pMxDocument As IMxDocument '地图文档

Set pMxDocument = Application.Document '获取当前应用程序的文档

MsgBox fc37a53ab84ae45c3b358c70 '显示当前地图的名称

End Sub

2.

Sub MyMacro()

Dim pMxDocument As IMxDocument '地图文档

Dim pMaps As IMaps '地图集

Dim pMap As IMap '地图

Set pMxDocument = Application.Document '获取当前应用程序的文档

Set pMaps = pMxDocument.Maps '获取当前地图文档的地图集

If pMaps.Count > 1 Then '如果该地图集的地图数大于1

Set pMap = pMaps.Item(1) '获取该地图集中的第一幅地图

MsgBox fc37a53ab84ae45c3b358c70 '显示该地图的名称

End If

End Sub

3.

Sub MyMacro()

Dim pMxDocument As IMxDocument '地图文档

Dim pMap As IMap '地图

Dim lCount As Long

Dim lIndex As Long

Set pMxDocument = Application.Document '获取当前应用程序的文档

Set pMap = pMxDocument.FocusMap '获取当前地图

lCount = 0

For lIndex = 0 To (fc37a53ab84ae45c3b358c70yerCount - 1)

If TypeOf fc37a53ab84ae45c3b358c70yer(lIndex) Is IFeatureLayer Then '如果当前地图的第lIndex层的类型是IFeatureLayer

lCount = lCount + 1 '计数器加1

End If

Next lIndex

MsgBox "Number of the feature layers " & _

"in the active map: " & lCount '显示当前地图的要素层的总数

End Sub

4.

Sub MyMacro()

Dim pMxDocument As IMxDocument '获取当前应用程序的文档

Dim pMaps As IMaps '地图集

Dim pMap As IMap '地图

On Error GoTo SUB_ERROR '错误处理

Set pMxDocument = Application.Document '获取当前应用程序的文档

Set pMaps = pMxDocument.Maps '获取当前地图文档的地图集

Set pMap = pMaps.Item(1) '获取该地图集中的第一幅地图

MsgBox fc37a53ab84ae45c3b358c70 '显示该地图的名称

Exit Sub

SUB_ERROR: '行标签

MsgBox "Error: " & Err.Number & "-" & Err.Description '显示错误数和错误信息

End Sub

本文来源：https://www.bwwdw.com/article/jtne.html