VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Label3DEngine"
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: contracts@esri.com

Option Explicit

Private m_Events As clsSGEvents     '   event handler for labelling
Public m_pScene As IScene          '   scene reference we get init with
Const m_cnDefaultColor = vbRed      '   default color RGB

Enum eLabelDocType
   eLabelDocTypeIndividual = 1
   eLabelDocTypeLayers = 2
End Enum





Public Function MoveLabelsToSurface(GroupIndex, sSurfaceLayerIndex, nzOffset As Double, Optional bRefreshViewers As Boolean) As String
On Error GoTo MoveLabelsToSurface_ERR

Dim pSurface As ISurface
Dim pG As LabelGroup
Dim pT As IDDDText
Dim nFactor As Double

    Debug.Assert 0
    
    If m_pScene Is Nothing Then Exit Function
    
    Set pSurface = GetSurfaceFromLayer(sSurfaceLayerIndex)
    If pSurface Is Nothing Then
      MoveLabelsToSurface = "Surface Layer at Index: " & sSurfaceLayerIndex & " not found."
      Exit Function
    End If
    
    Set pG = Me.LabelGroup(GroupIndex)
    If pG Is Nothing Then
      MoveLabelsToSurface = "Label Group at Index: " & GroupIndex & " not found."
      Exit Function
    End If
            
    nFactor = m_pScene.exaggerationFactor
            
    For Each pT In pG.Labels
        pT.Origin.z = (pSurface.z(pT.Origin.X, pT.Origin.Y) * nFactor) + nzOffset
    Next
    
    If bRefreshViewers Then
        m_pScene.SceneGraph.RefreshViewers
    End If
    
    Exit Function
    
MoveLabelsToSurface_ERR:
    Debug.Assert 0
    Debug.Print "MoveLabelsToSurface_ERR: " & Err.Description
    Resume Next
    
End Function
'
'   given a layername or index return the ISurface from it;
'   optionally return the name of the layer
Public Function GetSurfaceFromLayer(sLayer, Optional ByRef sOutName As String) As ISurface

Dim pLayer As ILayer
Dim pTin As ITin
Dim pRLayer As IRasterLayer
Dim pTLayer As ITinLayer
Dim pSurf As IRasterSurface
Dim pBands As IRasterBandCollection
Dim sName As String

On Error GoTo GetSurfaceFromLayer_ERR

'   get the layer:
    Set pLayer = GetLayer(sLayer)

    If pLayer Is Nothing Then Exit Function

    If TypeOf pLayer Is IRasterLayer Then

        Set pRLayer = pLayer

        Dim p3DProp As I3DProperties
        Dim pLE As ILayerExtensions
        Set pLE = pLayer
        
        Dim i As Integer
        
    '   look for 3D properties of layer:
        For i = 0 To pLE.ExtensionCount - 1
            If TypeOf pLE.Extension(i) Is I3DProperties Then
                Set p3DProp = pLE.Extension(i)
                Exit For
            End If
        Next


    '   look first for base surface of layer:
        Set pSurf = p3DProp.BaseSurface
        
    '   if not found, try first band of raster:
        If pSurf Is Nothing Then

            If Not pRLayer.raster Is Nothing Then
                Set pSurf = New RasterSurface
                Set pBands = pRLayer.raster
                pSurf.RasterBand = pBands.Item(0)
                sName = pLayer.name

            End If
        Else
        '   track the name of the layer if requested:
            sName = pLayer.name
            If Not p3DProp.BaseName Is Nothing Then
                sName = sName & " <" & p3DProp.BaseName.NameString & ">"
            Else
                sName = sName & " <surface?>"
            End If
        End If
        
        Set GetSurfaceFromLayer = pSurf
        
    ElseIf TypeOf pLayer Is ITinLayer Then
    '   get the surface off the tin layer:
        Set pTLayer = pLayer
        Set GetSurfaceFromLayer = pTLayer.Dataset
        sName = pTLayer.name
    Else
    
    End If

'   set return name if requested:
    If Not IsMissing(sOutName) Then sOutName = sName
    
    Exit Function
    
GetSurfaceFromLayer_ERR:
    Debug.Print "GetSurfaceFromLayer_ERR: " & vbCrLf & Err.Description
    Debug.Assert 0
    
End Function

'   pass in a location, a message, and some optional params
'   and insert a new label in either the default, found, or newly created group
'
Public Sub AddLabelDirect(Where As IPoint, sMessage As String, Optional GroupName As String, Optional sType As String, _
    Optional nFont As Double = 20, _
    Optional pFontcolor As IRgbColor, _
    Optional sFontName As String = "ARIAL", _
    Optional bVisible As Boolean, _
    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 nMinDispDist As Double = -1, _
    Optional bBillBoarding As Boolean)

On Error GoTo AddLabelDirect_ERR

    Dim pDDD As IDDDText
    Dim pColor As IRgbColor
    
'   create new label:
    Set pDDD = New DDDText
    
'   create necessary defaults:
    If Not pFontcolor Is Nothing Then
        Set pColor = pFontcolor
    Else
        Set pColor = New RgbColor
        pColor.RGB = m_cnDefaultColor
    End If
    
'   initialize class:
    With pDDD
        .Initialize sMessage, Where, nFont, nXScale, nYScale, nZScale, pColor, nxRot, _
        nyRot, nZRot, sFontName, sType, bBillBoarding, nMinDispDist
        .Enabled = True
    End With
    
'   put in proper label group:
    Dim pLabelGroup As New LabelGroup
    If Len(Trim(GroupName)) > 1 Then
    '   if groupname was supplied, look for it in collection:
    
        Dim i As Integer
        Dim iIndex As Integer
        Dim p As New LabelGroup
        iIndex = -1
        For i = 0 To g_colLabelGroup.Count - 1
            Set p = g_colLabelGroup.Item(i + 1)
            If UCase(p.name) = UCase(GroupName) Then
                iIndex = i
                Exit For
            End If
        Next

        If iIndex < 0 Then
            Set pLabelGroup = CreateBasicLabelGroup(GroupName)
        Else
            Set pLabelGroup = g_colLabelGroup.Item(iIndex + 1)
        End If
        
        
    Else
    '   add to default group:
        If g_colLabelGroup.Count = 0 Then
            CreateDefaultLabelGroup 'guarantees first item
        End If
        Set pLabelGroup = g_colLabelGroup.Item(1)
    End If
    
    
    pLabelGroup.AddLabelDirect pDDD
    
    Exit Sub
    
AddLabelDirect_ERR:
    Debug.Assert 0
    Debug.Print "AddLabelDirect_ERR: " & Err.Description
    Resume Next
    

End Sub


'   pass in a reference to the scene:
'
Public Sub Init(theScene As IScene)
    
On Error GoTo Init_ERR

    If m_Events Is Nothing Then Set m_Events = New clsSGEvents
    Set m_Events.m_pSG = theScene.SceneGraph
    Set m_pScene = theScene
    
    Exit Sub
    
Init_ERR:
    Debug.Assert 0
    Debug.Print "Init_ERR: " & Err.Description
    
    
End Sub

Public Function LabelGroups() As Collection
On Error Resume Next
'   return the actual collection:
    Set LabelGroups = g_colLabelGroup
End Function

Private Sub Class_Initialize()
'   create new label group collection; add the default:

    Set g_colLabelGroup = New Collection
    CreateDefaultLabelGroup
    
End Sub



Private Sub CreateDefaultLabelGroup()
    
On Error GoTo CreateDefaultLabelGroup_ERR

    Dim pDefault As New LabelGroup
    pDefault.name = "<graphics layer>"
    pDefault.LabelItem = "<default>"
    pDefault.Visible = False
    pDefault.CanAddLabels = True
    pDefault.ExtentNeedsInit = True
    
    With pDefault
        .Billboarding = False
        .FontName = "Arial"
        
        Dim pC As IColor
        Set pC = New RgbColor
        pC.RGB = m_cnDefaultColor
        Set .Fontcolor = pC
        
        .m_nXRotMin = 0
        .m_nXRotMax = 360
        
        .m_nYRotMin = 0
        .m_nYRotMax = 360
        
        .m_nZRotMin = 0
        .m_nZRotMax = 360
        
        .m_nXOffMax = 5000
        .m_nYOffMax = 5000
        .m_nZOffMax = 5000
        
        .m_nXOffMin = -5000
        .m_nYOffMin = -5000
        .m_nZOffMin = -5000
        
        .m_nXScale = 100
        .m_nYScale = 100
        .m_nZScale = 20
        
        .FontSize = 20
        
    End With
    g_colLabelGroup.Add pDefault
    
    Exit Sub
    
CreateDefaultLabelGroup_ERR:
    Debug.Assert 0
    Debug.Print "CreateDefaultLabelGroup_ERR: " & Err.Description
    Resume Next
    
End Sub
Private Function CreateBasicLabelGroup(sName As String) As LabelGroup
    
On Error GoTo CreateBasicLabelGroup_ERR

    Dim pDefault As New LabelGroup
    pDefault.name = sName
    pDefault.LabelItem = "<default>"
    pDefault.Visible = True
    pDefault.CanAddLabels = True
    
    With pDefault
        .Billboarding = False
        .FontName = "Arial"
        Dim pC As IColor
        Set pC = New RgbColor
        pC.RGB = m_cnDefaultColor
        Set .Fontcolor = pC
        
        .m_nXRotMin = 0
        .m_nXRotMax = 360
        
        .m_nYRotMin = 0
        .m_nYRotMax = 360
        
        .m_nZRotMin = 0
        .m_nZRotMax = 360
        
        .m_nXOffMax = g_colLabelGroup.Item(1).m_nXOffMax
        .m_nYOffMax = g_colLabelGroup.Item(1).m_nYOffMax
        .m_nZOffMax = g_colLabelGroup.Item(1).m_nZOffMax
        
        .m_nXOffMin = g_colLabelGroup.Item(1).m_nXOffMax
        .m_nYOffMin = g_colLabelGroup.Item(1).m_nYOffMax
        .m_nZOffMin = g_colLabelGroup.Item(1).m_nZOffMax
        
        .m_nXScale = 100
        .m_nYScale = 100
        .m_nZScale = 20

        .FontSize = 20


    End With
    g_colLabelGroup.Add pDefault
    Set CreateBasicLabelGroup = pDefault
    Exit Function
    
CreateBasicLabelGroup_ERR:
    Debug.Assert 0
    Debug.Print "CreateDefaultLabelGroup_ERR: " & Err.Description
    Resume Next
    
End Function


Public Sub InitFeatureLayerLabels(pFeatureLayer As IFeatureLayer, pFeatureFilter As IQueryFilter, _
sLabelItem As String, _
Optional bNoChangeSettings As Boolean, Optional nFontSize As Double = 20, _
Optional pFontcolor As IRgbColor, Optional sFontName As String = "ARIAL", _
Optional nxRot As Double = 90, Optional nyRot As Double = 0, Optional nZRot As Double = 0, _
Optional nXScale, Optional nYScale, Optional nZScale, _
Optional bBillBoarding As Boolean)

On Error GoTo InitFeatureLayerLabels_ERR

'   ensure label group exists, pass parameters:
    Dim i As Integer
    Dim iIndex As Integer
    Dim pGroup As LabelGroup
    
    If pFeatureLayer Is Nothing Then Exit Sub
    
    iIndex = -1
    For i = 0 To g_colLabelGroup.Count - 1
        Set pGroup = g_colLabelGroup.Item(i + 1)
        If UCase(pGroup.name) = UCase(pFeatureLayer.name) Then
            iIndex = i
            Exit For
        End If
    Next
    
    Dim pLabelGroup As LabelGroup
    If iIndex < 0 Then
        'was not found:
        'create new:
        Set pLabelGroup = New LabelGroup
        pLabelGroup.name = pFeatureLayer.name
        g_colLabelGroup.Add pLabelGroup
    Else
        Set pLabelGroup = g_colLabelGroup(iIndex + 1)
    End If
        
    
    Dim pFeatureCursor As IFeatureCursor
    Set pFeatureCursor = pFeatureLayer.Search(pFeatureFilter, True)
    

'   get color to pass:
    Dim pColor As IRgbColor
    If pFontcolor Is Nothing Then
        Set pColor = New RgbColor
        pColor.RGB = m_cnDefaultColor
    Else
        Set pColor = pFontcolor
    End If
    
    Dim xD As Double, yD As Double, zD As Double
    Dim xOffMin As Double, yOffMin As Double, xOffMax As Double, yOffMax As Double
    Dim zOffMin As Double, zOffMax As Double