手上的电脑已经用了将近三年了,想入手一台Surface Pro,所以计划着把电脑上的资料整理下,部分资料打算发到博客上来,资料有同事、也有自己的、也有来自网络的,来源途径太多,也没法详细注明,请见谅!
要素标注:
在Engine中,有一个很好的接口IGraphicsContainer,这个接口就是desktop中的临时图层,所以,要是完成一个标注功能的系统,这个接口就非常有用了。可以通过IMap、IActiveView等接口得到IGraphicsContainer,通过
IGraphicsContainer pGC = m_HookHelper.FocusMap as IGraphicsContainer;
pGC.Reset();
IElement pElement = pGC.Next();
while (pElement != null)
{
ElemnetProperty pProperty = (pElement as IElementProperties2).CustomProperty as ElemnetProperty;
if(pProperty == null)
{
pElement = pGC.Next();
continue;
}
}
对其中的IElement进行遍历,通过IElement得到IElementProperties2,IElementProperties2的CustomProperty是个可读写的object属性,可以通过他保存自定义的内容,所以属性控制方面,非常方便;IElement的Geometry属性可以控制图形,图形方面的问题也得到了解决。(上段代码中的ElemnetProperty 是我自己定义的一个结构。)
控制PageLayout显示
PageLayout上的东西都是element,实现了两个接口IGraphicsContainer and IGraphicsContainerSelect。IGraphicsContainer包括所有pagelayout上的element,有next方法可以遍历,可以添加删除排序,IGraphicsContainerSelect has a DominantElement property for getting the selected element. 一个element又实现了IElementProperties2接口,该接口上有name属性,可以通过这个属性来get or set the name of selected element。在element的ITextElement (并非所有的elment都实现该接口可以用Typeof pElement is ITextElement判断)接口上有text属性,可以来设置其显示的文字。
'get PageLayout
Dim pMxDoc As IMxDocument
Set pMxDoc = ThisDocument
Dim pPageLayout As IPageLayout
Set pPageLayout = pMxDoc.PageLayout
'determine if there is one and only one element selected
Dim pContainerSelect As IGraphicsContainerSelect
Set pContainerSelect = pPageLayout
If pContainerSelect.ElementSelectionCount <> 1 Then
MsgBox "Select one element."
Exit Sub
End If
'get the name property
Dim pElement As IElementProperties2
Set pElement = pContainerSelect.DominantElement
Dim strName As String
strName = InputBox("Enter a name", "Name the element")
'set the name property
pElement.Name = strName
添加新图形(Adding new graphics)
先声明一个IElement 这个接口根据需要可以在polygon, line或point 上实现。用来接收geometry;
声明一个IFillShapeElement接口引用刚才那个对象,用它的symbol属性来设置element的属性。
用symbol的color属性来设置颜色和透明度,outline属性来设置边框
最后用IGraphicsContainer的add方法把element加上去。
IElement 有geometry 属性,来接受一个geometry
IFillShapeElement有symbol属性
IFillSymbol有color属性来设置symbol的颜色透明度等,还有outline属性来设置边框
AE中画带箭头的线(转贴)
使用ICartographicLineSymbol 接口
Private Sub UIButtonControl1_Click()
Dim pMxDoc As IMxDocument
Dim pGraphicsContainer As IGraphicsContainer
Dim pActiveView As IActiveView
Dim pLineElement As ILineElement
Set pMxDoc = Application.Document
Set pGraphicsContainer = pMxDoc.FocusMap
Set pActiveView = pMxDoc.FocusMap
pGraphicsContainer.Reset
Set pLineElement = pGraphicsContainer.Next
Dim aCartoLineSymbol As ICartographicLineSymbol
Set aCartoLineSymbol = New CartographicLineSymbol
Dim aLP As ILineProperties
Set aLP = aCartoLineSymbol
aLP.Offset = 0
Dim hpe(6) As Double
hpe(0) = 0
hpe(1) = 7
hpe(2) = 1
hpe(3) = 1
hpe(4) = 1
hpe(5) = 0
Dim eLineTemplate As ITemplate
Set eLineTemplate = New Template
eLineTemplate.Interval = 1
Dim ix As Integer, jx As Integer
jx = 0
For ix = 1 To 3
eLineTemplate.AddPatternElement hpe(jx), hpe(jx + 1)
jx = jx + 2
Next ix
Set aLP.Template = eLineTemplate
aCartoLineSymbol.Width = 2
aCartoLineSymbol.Cap = esriLCSButt
aCartoLineSymbol.Join = esriLJSBevel
Dim HC As IRgbColor
Set HC = New RgbColor
HC.Red = 255
HC.Green = 0
HC.Blue = 0
aCartoLineSymbol.Color = HC
Dim pSymbol As ISymbol
Set pSymbol = aCartoLineSymbol
pLineElement.Symbol = pSymbol
pActiveView.Refresh
End Sub
引线标注
Dim pMxDoc As IMxDocument
Set pMxDoc = ThisDocument
Dim pTextElement As ITextElement
Set pTextElement = New TextElement
Dim pElement As IElement
Set pElement = pTextElement
pTextElement.Text = "feifeiwua" & vbCrLf & "引线标注!"
Dim dMidX As Double, dMidY As Double
Dim pPoint As IPoint
' dMidX = (pMxDoc.ActiveView.Extent.XMax + pMxDoc.ActiveView.Extent.XMin) / 2
' dMidY = (pMxDoc.ActiveView.Extent.YMax + pMxDoc.ActiveView.Extent.YMin) / 2
Set pPoint = New Point
Set pPoint = pMxDoc.ActivatedView.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y)
dMidX = pPoint.x
dMidY = pPoint.y
pPoint.PutCoords dMidX, dMidY
pElement.Geometry = pPoint
Dim pTextSymbol As IFormattedTextSymbol
Set pTextSymbol = New TextSymbol
Dim pCallout As ICallout
Set pCallout = New BalloonCallout
Set pTextSymbol.Background = pCallout
pPoint.PutCoords dMidX - pMxDoc.ActiveView.Extent.Width / 4, dMidY + pMxDoc.ActiveView.Extent.Width / 20
pCallout.AnchorPoint = pPoint
pTextElement.Symbol = pTextSymbol
Dim pGraphicsContainer As IGraphicsContainer
Set pGraphicsContainer = pMxDoc.ActiveView
pGraphicsContainer.AddElement pElement, 0
pElement.Activate pMxDoc.ActiveView.ScreenDisplay
pMxDoc.ActiveView.PartialRefresh esriViewGraphics, Nothing, Nothing
如何获得投影坐标、参考坐标、投影方式
ArcMap中,View——〉Data Frame Properties——〉Coordinate System:
有一系列的坐标及投影方式,可以通过以下方式获得
Public Sub getSpatialReference()
Dim pDoc As IMxDocument
Dim pMap As IMap
Set pDoc = ThisDocument
Set pMap = pDoc.FocusMap
Dim pSpatialReference As ISpatialReference
Set pSpatialReference = pMap.SpatialReference
Dim pProjectedCS As IProjectedCoordinateSystem
Dim pGeographicCS As IGeographicCoordinateSystem
Dim pProjection As IProjection
Set pProjectedCS = pSpatialReference
Set pGeographicCS = pProjectedCS.GeographicCoordinateSystem
Set pProjection = pProjectedCS.Projection
Debug.Print pProjectedCS.Name
Debug.Print pGeographicCS.Name
Debug.Print pProjection.Name
End Sub
输出结果:
NAD_1983_StatePlane_Vermont_FIPS_4400
GCS_North_American_1983
Transverse_Mercator:横轴墨卡托投影
IFeatureClass::FeatureCount注意点
IFeatureClass.FeatureCount(ISpatialFilter):计算FeatureCount的时候,如果ISpatialFilter::Geometry过于复杂,此方法运算会使程序崩溃(比如:把道路网做缓冲合并成一个Geometry,查询程序崩溃)。
可以采取另外的一个方法:
IFeatureCursor = IFeatureClass.Search(ISpatialFilte*,**lse),然后遍历IFeatureCursor,获得其个数。