📄 clslabelengine.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 = "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
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -