clsmaplayeranno.cls

图层自动注记

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsMapLayerAnno"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
''***********************************************************************************************
''*******************类 名 称：clsMapLayerAnno                       ****************************
''*******************功能描述：完成图层的注记                          ****************************
''*******************依赖关系：无                                      ****************************
''*******************作    者：杨淑婧                                  ****************************
''*******************创建日期：2005年10月27日                          ****************************
''*******************版    权：云南省基础地理信息中心                  ****************************
''*************************************************************************************************
'Option Explicit

'定义线划符号
Private Const strYinhao = """"

'定义地图对象
Private m_pMap As IMap

''定义数据库对象
'Private m_oraDB As OraDatabase

'定义当前要注记的图层
Private m_pLayer As ILayer

'定义实体类
Private m_featCls As IFeatureClass

'定义图层
Private m_pFeatlyr As IFeatureLayer

'定义空间实体图层
Private m_pGeofeatlayer As esriCarto.IGeoFeatureLayer

'定义标注字段
Private m_strField As String

'定义标注字体
Private m_Font As String

'定义标注字体大小
Private m_FontSize As Double

'定义最大显示比例
Private m_MaxScale As Double

'定义最小显示比例
Private m_MinScale As Double

Private m_FeatTyp As String

'定义标注三原色
Private m_RColor As Long
Private m_GColor As Long
Private m_BColor As Long

'定义标注事件
Public Event AnnoComplete()

'**************************************************************
'名    称： CurrentLayer属性
'功能描述： 传入图层对象
'传入参数： pLayer
'返回参数：
'依赖关系：
'作    者： 杨淑婧
'创建日期   2005年10月11日
'**************************************************************
Public Property Set CurrentLayer(pLayer As ILayer)
    Set m_pLayer = pLayer
End Property
'**************************************************************
'名    称： Map属性
'功能描述： 传入地图对象
'传入参数： pMap
'返回参数：
'依赖关系：
'作    者： 杨淑婧
'创建日期   2005年10月11日
'**************************************************************
Public Property Set Map(pMap As IMap)
    Set m_pMap = pMap
End Property
'**************************************************************
'名    称： AnnoText属性
'功能描述： 传入需注记的字段
'传入参数： pText
'返回参数：
'依赖关系：
'作    者： 杨淑婧
'创建日期   2005年11月21日
'**************************************************************
Public Property Let AnnoField(pText As String)
    m_strField = pText
End Property

'**************************************************************
'名    称： Annotation
'功能描述： 图层注记
'传入参数：
'返回参数：
'依赖关系：
'作    者： 杨淑婧
'创建日期   2005年10月18日
'**************************************************************
Public Sub Annotation(blnAnno As Boolean)

    '创建新的实体图层
    Set m_pFeatlyr = New FeatureLayer
    
    '设置新图层为当前图层
    Set m_pFeatlyr = m_pLayer
    
    '判断当前实体类型
    Set m_featCls = m_pFeatlyr.FeatureClass
     Select Case m_featCls.ShapeType
        Case esriGeometryNull
            Exit Sub
        Case esriGeometryPoint
            m_FeatTyp = 0
        Case esriGeometryMultipoint
            m_FeatTyp = 0
        Case esriGeometryPolyline
            m_FeatTyp = 1
        Case esriGeometryPolygon
            m_FeatTyp = 2
     End Select
    
    Set m_pGeofeatlayer = m_pFeatlyr
       
    '定义标注集
    Dim pAnnoPropsCol As IAnnotateLayerPropertiesCollection
    
    '设置标注集为当前图层的注记
    Set pAnnoPropsCol = m_pGeofeatlayer.AnnotationProperties
    
    '清空原有注记
    pAnnoPropsCol.Clear
    
    '定义标注属性
    Dim pAnnoLayerProps As IAnnotateLayerProperties
    
    '定义标注位置
    Dim pPositionL As ILineLabelPosition
    
    '定义放置位置
    Dim pPlacementL As ILineLabelPlacementPriorities
    Dim pPlacementP As IPointPlacementPriorities
    
    '定义控制标注放置的属性
    Dim pBasic As IBasicOverposterLayerProperties
    
    '定义标注容器
    Dim pLabelEngine As ILabelEngineLayerProperties
    
    '定义并创建文本符号
    Dim pTextSym As ITextSymbol
    Set pTextSym = New TextSymbol
    Dim pFont As stdole.IFontDisp
    Set pFont = New stdole.StdFont
    
    '设置字体名称
    pFont.Name = m_Font
    'pFont.Underline = True
    pTextSym.Font = pFont
    
    '设置字体大小
    pTextSym.Size = m_FontSize
    
    '设置字体颜色
    Dim pcolor As IColor
    Set pcolor = New RgbColor
    pcolor.RGB = RGB(m_RColor, m_GColor, m_BColor)
    pTextSym.Color = pcolor

    '设置标注位置
    Set pPositionL = New LineLabelPosition
        
    Set pPlacementL = New LineLabelPlacementPriorities
    Set pPlacementP = New PointPlacementPriorities
    
    Set pBasic = New BasicOverposterLayerProperties
    
    '设置标注的实体类型
    pBasic.FeatureType = m_FeatTyp
    
    '设置标注放置位置
    pBasic.LineLabelPlacementPriorities = pPlacementL
    pBasic.LineLabelPosition = pPositionL
    
    pBasic.PointPlacementMethod = esriAroundPoint
    
    pPlacementP.CenterRight = 1
    
    With pPlacementP
        .AboveCenter = 0
        .AboveLeft = 0
        .AboveRight = 0
        .BelowCenter = 0
        .BelowLeft = 0
        .BelowRight = 0
        .CenterLeft = 0
    End With
    
    pBasic.PointPlacementPriorities = pPlacementP

    
    '创建新的容器
    Set pLabelEngine = New LabelEngineLayerProperties
    
    Dim pAnnoExpres As IAnnotationExpressionProperties
    
    '设置容器符号为定义过的文本符号
    Set pLabelEngine.Symbol = pTextSym
    
    '设置容器动态标注属性
    Set pLabelEngine.BasicOverposterLayerProperties = pBasic
    
    '控制点的特殊处理
    If InStr(1, m_pLayer.Name, "CTRP", vbTextCompare) <= 0 Then
    
        '设置文本符号表达式为传入参数
        pLabelEngine.Expression = m_strField
    Else
    
'        '定义并设置VB脚本表达
'        Dim pAnnoVBsEngine As IAnnotationExpressionEngine
'        Set pAnnoVBsEngine = New AnnotationVBScriptEngine
'
'        Set pLabelEngine.ExpressionParser = pAnnoVBsEngine
'
'        '设置控制点的表达式
'        pLabelEngine.Expression = "[CTRP_Name] & vbcr & " & strYinhao & "━━━━━" & strYinhao & " &  vbcr & [CTRP_ELEV]"
'        'Debug.Print pLabelEngine.Expression
        
    End If
   
    Set pAnnoLayerProps = pLabelEngine
    
    '设置显示比例
'    pAnnoLayerProps.AnnotationMaximumScale = 0.05
    pAnnoLayerProps.AnnotationMinimumScale = m_MinScale
    
    '添加注记到集合
    pAnnoPropsCol.Add pAnnoLayerProps
    
    '令当前图层显示注记
    m_pGeofeatlayer.DisplayAnnotation = blnAnno
   
    '定义地图视窗
    Dim t_pView As IActiveView
    Set t_pView = m_pMap
    
    '刷新
    t_pView.Refresh
    
    '触发注记完毕事件
    RaiseEvent AnnoComplete
    
End Sub

'**************************************************************
'名    称： pFont属性
'功能描述： 传入字体名称
'传入参数： strFontN
'返回参数：
'依赖关系：
'作    者： 杨淑婧
'创建日期   2005年10月27日
'**************************************************************
Public Property Let FontName(strFontN As String)
    m_Font = strFontN
End Property
'**************************************************************
'名    称： FontRcolor
'功能描述： 传入字体RGB颜色（红）
'传入参数： pRed
'返回参数：
'依赖关系：
'作    者： 杨淑婧
'创建日期   2005年11月15日
'**************************************************************
Public Property Let FontRcolor(pRed As Long)
    m_RColor = pRed
End Property
'**************************************************************
'名    称： pMaxScale属性
'功能描述： 传入最大显示比例尺范围
'传入参数： dblMax
'返回参数：
'依赖关系：
'作    者： 杨淑婧
'创建日期   2005年11月15日
'**************************************************************
Public Property Let MaxScale(dblMax As Double)
    m_MaxScale = dblMax
End Property

'**************************************************************
'名    称： pMaxScale属性
'功能描述： 传入最小显示比例尺范围
'传入参数： dblMin
'返回参数：
'依赖关系：
'作    者： 杨淑婧
'创建日期   2005年11月15日
'**************************************************************
Public Property Let MinScale(dblMin As Double)
    m_MinScale = dblMin
End Property

'**************************************************************
'名    称： pFontSize属性
'功能描述： 传入字体大小
'传入参数： dblFs
'返回参数：
'依赖关系：
'作    者： 杨淑婧
'创建日期   2005年11月14日
'**************************************************************
Public Property Let FontSize(dblFs As Double)
    m_FontSize = dblFs
End Property

'**************************************************************
'名    称： FeatType属性
'功能描述： 传入实体类型
'传入参数： intFT
'返回参数：
'依赖关系：
'作    者： 杨淑婧
'创建日期   2005年11月14日
'**************************************************************
Public Property Let FeatType(intFT As Integer)
    m_FeatTyp = intFT
End Property
'**************************************************************
'名    称： pGcolor属性
'功能描述： 传入字体RGB颜色（绿）
'传入参数： pGreen
'返回参数：
'依赖关系：
'作    者： 杨淑婧
'创建日期   2005年11月15日
'**************************************************************
Public Property Let FontGcolor(pGreen As Long)
    m_GColor = pGreen
End Property
'**************************************************************
'名    称： pRcolor属性
'功能描述： 传入字体RGB颜色（蓝）
'传入参数： pBlue
'返回参数：
'依赖关系：
'作    者： 杨淑婧
'创建日期   2005年11月15日
'**************************************************************
Public Property Let FontBcolor(pBlue As Long)
    m_BColor = pBlue
End Property