clslayerlabels.cls

gis地图 --- --- --文字1

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "LabelGroup"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True

' Copyright 1995-2004 ESRI

' All rights reserved under the copyright laws of the United States.

' You may freely redistribute and use this sample code, with or without modification.

' Disclaimer: THE SAMPLE CODE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED 
' WARRANTIES, INCLUDING THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 
' FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ESRI OR 
' CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, 
' OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 
' SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
' INTERRUPTION) SUSTAINED BY YOU OR A THIRD PARTY, HOWEVER CAUSED AND ON ANY 
' THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ARISING IN ANY 
' WAY OUT OF THE USE OF THIS SAMPLE CODE, EVEN IF ADVISED OF THE POSSIBILITY OF 
' SUCH DAMAGE.

' For additional information contact: Environmental Systems Research Institute, Inc.

' Attn: Contracts Dept.

' 380 New York Street

' Redlands, California, U.S.A. 92373 

' Email: [e-mail]


Option Explicit

Public Labels As Collection
Public CanAddLabels As Boolean
Public LabelItem As String
Public LayerName  As String
Public ExtentNeedsInit As Boolean

Private m_pFontcolor As IRgbColor
Private m_bVisible As Boolean
Private m_sFontName As String
Private m_bBillboarding As Boolean
Private m_nFontSize As Double
Private m_nMinDispDist As Double

'   private status flags:
Dim m_bb_haschanged As Boolean
Dim m_fs_haschanged As Boolean
Dim m_fn_haschanged As Boolean
Dim m_fc_haschanged As Boolean
Dim m_xr_haschanged As Boolean
Dim m_yr_haschanged As Boolean
Dim m_zr_haschanged As Boolean
Dim m_vs_haschanged As Boolean
Dim m_md_haschanged As Boolean


'   for use on GUIs:===============================================
Public m_nYOff As Double
Public m_nZOff As Double
Public m_nXOff As Double
Private m_nXRot As Double
Private m_nYRot As Double
Private m_nZRot As Double
Public m_nXScale As Double
Public m_nYScale As Double
Public m_nZScale As Double
Public m_nFontMax As Double
Public m_nFontMin As Double
Public m_nXOffMin As Double
Public m_nYOffMin As Double
Public m_nZOffMin As Double
Public m_nXOffMax As Double
Public m_nYOffMax As Double
Public m_nZOffMax As Double
Public m_nXRotMin As Double
Public m_nYRotMin As Double
Public m_nZRotMin As Double
Public m_nXRotMax As Double
Public m_nYRotMax As Double
Public m_nZRotMax As Double
'
'   take a feature cursor, a layer name, a label item, and derive a label at each
'   feature location:
'
Friend Sub InitFeatureLabels(pInCursor As IFeatureCursor, pLayer As ILayer, sLabelItem As String, _
Optional bNoChangeSettings As Boolean, _
Optional nFont As Double = 20, Optional nFontMin As Double = 100, Optional nFontMax As Double = 4400, _
Optional pFontcolor As IRgbColor, Optional sFontName As String = "ARIAL", _
Optional nXOffMin As Double = -100000, Optional nXOffMax As Double = 100000, _
Optional nYOffMin As Double = -100000, Optional nYOffMax As Double = 100000, _
Optional nZOffMin As Double = -10000, Optional nZOffMax As Double = 10000, _
Optional nxRot As Double = 90, Optional nyRot As Double = 0, Optional nZRot As Double = 0, _
Optional nXScale As Double = 100, Optional nYScale As Double = 100, Optional nZScale As Double = 20, _
Optional bBillBoarding As Boolean)

On Error GoTo InitFeatureLabels_ERR

    Dim sLabel As String
    Dim pptWhere As IPoint
    Dim sFont As String
    Dim sLblField As String
    Dim sLayer As String
    
'   store parameters:
    sLblField = sLabelItem
    sLayer = pLayer.name
    LabelItem = sLabelItem
    LayerName = sLayer
    
'   if not requested not to, change the settings:
    If Not bNoChangeSettings Then
        
        m_nXRot = nxRot
        m_nYRot = nyRot
        m_nZRot = nZRot
        
        m_nXScale = nXScale
        m_nYScale = nYScale
        m_nZScale = nZScale
        
        m_nFontMax = nFontMax
        m_nFontMin = nFontMin
        FontSize = nFont
        
        m_nXOffMin = nXOffMin
        m_nYOffMin = nYOffMin
        m_nZOffMin = nZOffMin
        m_nXOffMax = nXOffMax
        m_nYOffMax = nYOffMax
        m_nZOffMax = nZOffMax
        
        m_nXRotMin = 0
        m_nYRotMin = 0
        m_nZRotMin = 0
        m_nXRotMax = 360
        m_nYRotMax = 360
        m_nZRotMax = 360
        
        Billboarding = bBillBoarding
        
        FontName = sFontName
        
        Set Fontcolor = pFontcolor

    End If
    
    
    
'   create new collection to store labels:
    Set Labels = New Collection

'   ensure label name:
    If Len(FontName) < 1 Then
        FontName = "ARIAL"
    End If
    
'   ensure font color:
    If Fontcolor Is Nothing Then
        Set Fontcolor = New RgbColor
        Fontcolor.RGB = RGB(255, 0, 0)
    End If
    

    Dim pZAware As IZAware
    
    Dim pFeature As IFeature
    Set pFeature = pInCursor.NextFeature
    
    Dim nZFactor As Double
    Dim pSxDoc As ISxDocument
    Set pSxDoc = Application.Document
    If Not pSxDoc Is Nothing Then
      nZFactor = pSxDoc.Scene.ExaggerationFactor
    Else
      nZFactor = 1
    End If
    
    '   only create labels if the label group is currently visible:
    If Me.Visible Then
        '   apply 3d properties

        Dim p3DProps As I3DProperties
        Set p3DProps = Get3DPropsFromLayer(pLayer)
        Dim pFProps As IFeature3DProperties
        Set pFProps = p3DProps
        
        Dim pGeomZ As IGeometry
        Dim pGeomArea As IArea
        
        Do While (Not pFeature Is Nothing)
          If Not pFeature.Shape Is Nothing Then
            Set pptWhere = New Point
            pFProps.ApplyFeatureProperties pFeature, pGeomZ, False
            
            If Not pGeomZ Is Nothing Then
              Select Case pFeature.Shape.GeometryType
                 
                  Case 1, 4, esriGeometryPolyline   'point, polygon, line
                      
                      'pFProps.ApplyFeatureProperties pFeature, pGeomZ, False
                      
                      If pFeature.Shape.GeometryType = esriGeometryPoint Then
  
                          pptWhere.x = pGeomZ.Envelope.xmin + (pGeomZ.Envelope.xmax - pGeomZ.Envelope.xmin) / 2
                          pptWhere.y = pGeomZ.Envelope.ymin + (pGeomZ.Envelope.ymax - pGeomZ.Envelope.ymin) / 2
                      
                      ElseIf pFeature.Shape.GeometryType = esriGeometryPolygon Then
                          
                          Set pGeomArea = pGeomZ.Envelope
                          pptWhere.x = pGeomArea.LabelPoint.x
                          pptWhere.y = pGeomArea.LabelPoint.y
                          
                      ElseIf pFeature.Shape.GeometryType = esriGeometryPolyline Then
                      
                          Set pGeomArea = pGeomZ.Envelope
                          pptWhere.x = pGeomArea.LabelPoint.x
                          pptWhere.y = pGeomArea.LabelPoint.y
                          
                      End If
                      
         
                  Case Else
                      
                      Debug.Assert 0
                      Exit Sub
                  
                End Select
            

                With pptWhere
                    Set pZAware = pptWhere
                    pZAware.ZAware = True
                    
                    'If pZAware.ZAware Then
                    If CStr(pGeomZ.Envelope.zmax) = "1.#QNAN" Or CStr(pGeomZ.Envelope.zmax) = "1,#QNAN" Then
                        .z = 0
                    Else
                        .z = pGeomZ.Envelope.zmax + m_nZOff
                    End If
                    
                    .z = .z * nZFactor
                End With


            
            '   get label text:
                sLabel = pFeature.Value(pFeature.Fields.FindField(sLblField))
                
                Dim pDDDText As IDDDText
                Set pDDDText = New DDDText
                
            '   create and initialize new font:
                pDDDText.Initialize sLabel, pptWhere, FontSize, m_nXScale, m_nYScale, m_nZScale, _
                                            Fontcolor, m_nXRot, m_nYRot, m_nZRot, _
                                             FontName, "FEATURE", bBillBoarding
    
            
        
            '   add to internal colleciton:
                Labels.Add pDDDText
    
            
              End If  'pGeomZ is nothing