clslabelengine.cls

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

    
    Dim nFont As Double, nExtentScale As Double
    
    'x and y delta:
    'xD = pFeatureLayer.AreaOfInterest.xmax - pFeatureLayer.AreaOfInterest.xmin
    'yD = pFeatureLayer.AreaOfInterest.ymax - pFeatureLayer.AreaOfInterest.ymin
    'zD = pFeatureLayer.AreaOfInterest.zmax - pFeatureLayer.AreaOfInterest.zmin
    
    If Not m_pScene Is Nothing Then
        xD = m_pScene.SceneGraph.OwnerExtent(pFeatureLayer, False).Envelope.xmax - m_pScene.SceneGraph.OwnerExtent(pFeatureLayer, False).xmin
        yD = m_pScene.SceneGraph.OwnerExtent(pFeatureLayer, False).ymax - m_pScene.SceneGraph.OwnerExtent(pFeatureLayer, False).ymin
        zD = m_pScene.SceneGraph.OwnerExtent(pFeatureLayer, False).zmax - m_pScene.SceneGraph.OwnerExtent(pFeatureLayer, False).zmin
    End If
    
    If zD < 1 Then
        zD = 5000
    End If
    
    If (xD = 0 Or yD = 0) And Not m_pScene Is Nothing Then
        xD = m_pScene.Extent.xmax - m_pScene.Extent.xmin
        yD = m_pScene.Extent.ymax - m_pScene.Extent.ymin
        zD = m_pScene.Extent.zmax - m_pScene.Extent.zmin
    End If

       
    Me.UpdateExtentScale pLabelGroup, xD, yD, zD, False
    
    If nFontSize = 0 Then nFontSize = 20
    nFont = nFontSize

'   call the init on the label group with the parameters:
    pLabelGroup.InitFeatureLabels pFeatureCursor, pFeatureLayer, sLabelItem, False, _
    nFont, , , pFontcolor, sFontName, pLabelGroup.m_nXOffMin, pLabelGroup.m_nXOffMax, _
     pLabelGroup.m_nYOffMin, pLabelGroup.m_nYOffMax, , , nxRot, nyRot, nZRot, CDbl(nXScale), _
    CDbl(nYScale), CDbl(nZScale), bBillBoarding
    
    Exit Sub
    
InitFeatureLayerLabels_ERR:
    Debug.Assert 0
    Debug.Print "InitFeatureLayerLabels_ERR: " & Err.Description
    Resume Next

    
End Sub
'
'find the label group indexed, and return a reference:
'
Public Function LabelGroup(Index) As LabelGroup
Dim i As Integer
Dim pLabelGroup As LabelGroup

On Error GoTo GetLabelGroup_ERR

    If IsNumeric(Index) Then
        If Index + 1 <= g_colLabelGroup.Count Then
            Set pLabelGroup = g_colLabelGroup.Item(Index + 1)
        End If
    
    Else
        Dim p As LabelGroup
        For i = 0 To g_colLabelGroup.Count - 1
            Set p = g_colLabelGroup.Item(i + 1)
            If UCase(p.name) = UCase(Index) Then
                Set pLabelGroup = g_colLabelGroup.Item(i + 1)
                Exit For
            End If
        Next
    
    End If
    
    
    Set LabelGroup = pLabelGroup
        
    Exit Function
    
GetLabelGroup_ERR:
    Debug.Assert 0
    Debug.Print "GetLabelGroup_ERR: " & Err.Description
    
End Function

Public Function SelectLabelsFromPoint(ptLocation As IPoint, Optional sGroupNames As Collection) As Collection
  On Error GoTo SelectLabelsFromPoint_ERR
  
  Dim theLabels As Collection         '   the collection of labels found
  Dim pDDD As IDDDText                '   an object to search the labels
  Dim pCam As ICamera                 '   the camera
  Dim pVect1 As IVector3D             '   first vector
  Dim dx As Double, dy As Double      '   locationals
  Dim pRay1 As IRay                   '   first ray
  Dim pOrig1 As IPoint                '   first point
  Dim pVect2 As IVector3D             '   second vector
  Dim m1 As Double                    '   magnitude 1
  Dim m2 As Double                    '   magnitude 2
  Dim dDotP As Double                 '   dot product
  Dim aLowest As Double               '   lowest angle value
  Dim a As Double                     '   angle value

  If m_pScene Is Nothing Then
    Exit Function
  End If
  
  If m_pScene.SceneGraph.IsEmpty Then
    Exit Function
  End If

  
'   the collection of found labels:
  Set theLabels = New Collection
      
'   the camera:
  Set pCam = m_pScene.SceneGraph.ActiveViewer.Camera
  
'   our local coordinates:
  dx = ptLocation.X
  dy = ptLocation.Y

'   get the ray, origin, and vector from the point on the screen which we passed in:
  Set pRay1 = pCam.GetIdentifyRay(dx, dy)
  Set pVect1 = pRay1.Vector
  Set pOrig1 = pRay1.Origin

'   the magnitude of the first vector:
  m1 = pVect1.Magnitude
          
'   init the lowest angle as a high value
  aLowest = 360 '?

'   make sure this label has a tag including a group name in the collection
'   which was passed in:
  Dim iGroup As Integer
  Dim bUse As Boolean
  Dim i As Integer
  Dim pGroup As LabelGroup
  Dim bFilter As Boolean
  Dim sGroup As String
  
  If Not IsMissing(sGroupNames) Then bFilter = True
  If sGroupNames Is Nothing Then bFilter = False
  
  For iGroup = 0 To g_colLabelGroup.Count - 1
      bUse = False
      Set pGroup = g_colLabelGroup.Item(iGroup + 1)
      
      '   if we are using this one:

          If bFilter Then
              sGroup = pGroup.name
              
              For i = 0 To sGroupNames.Count - 1
                  If UCase(sGroup) = UCase(sGroupNames.Item(i + 1)) Then
                      bUse = True
                      Exit For
                  Else
                      bUse = False
                  End If
              Next
          Else
              bUse = True
          End If
      
          If bUse Then
              For Each pDDD In pGroup.Labels
              '   if the label is on and intersects our ray:
                  If pDDD.Enabled Then
                      If pRay1.Intersects(pDDD.BoundingBox()) Then
                          Debug.Assert 0
                      '   add it to the collection of 'found' labels:
                          theLabels.Add pDDD
                      Else
                       
                      End If
                  End If
       
              Next
      
          End If
          
  Next
  
'   return the collection we may have added IDDDTexts to:
  If Not theLabels Is Nothing Then
    If theLabels.Count > 0 Then
      Set SelectLabelsFromPoint = theLabels
    End If
  End If
         
  
  Exit Function
  
SelectLabelsFromPoint_ERR:
  Debug.Assert 0
  Debug.Print "SelectLabelsFromPoint_ERR: " & Err.Description
  MsgBox "debug: " & "SelectLabelsFromPoint_ERR: " & Err.Description
  
  Resume Next
    
    
End Function

Public Function LoadLabelsFromDoc(sLabelDoc As String, iFormat As eLabelDocType) As LabelGroup
'**FORMAT1 = <x,y,z,xrot,yrot,zrot,xScale,yScale,zScale,MinDisplayDistance,message,visible,fontsize,fontname,BillBoarding,fontrgbcolor>
'**FORMAT2 = <layername,item,visible,fontsize,fontrgbcolor>
Dim lFileID As Long
Dim sLine As String
Dim nFont As Double
Dim pColor As IRgbColor
Dim sFontName As String
Dim sMessage As String
Dim bVisible As Boolean
Dim X As Double, Y As Double, z As Double
Dim sLayerName As String
Dim sItem As String
Dim pWhere As IPoint
Dim bBillBoarding As Boolean
Dim nxRot As Double, nyRot As Double, nZRot As Double
Dim pGroup As LabelGroup
Dim i As Integer
Dim nMinDispDist As Double
Dim nXScale As Double
Dim nYScale As Double
Dim nZScale As Double
Dim nFormat As Integer

On Error GoTo LoadLabelsFromDoc_ERR

    lFileID = FreeFile
    Open sLabelDoc For Input As lFileID
        
    'header:
    Line Input #lFileID, sLine
    Line Input #lFileID, sLine
    
    nFormat = CInt(iFormat)
    Select Case nFormat
    Case 1
        Do While Not EOF(lFileID)
            Line Input #lFileID, sLine
            GetAttribsFromLine nFormat, sLine, sMessage, X, Y, z, nxRot, nyRot, nZRot, nXScale, nYScale, nZScale, nMinDispDist, bVisible, nFont, pColor, bBillBoarding, sFontName
            
            Set pWhere = New Point
            With pWhere
                .X = X
                .Y = Y
                .z = z
            End With
            
            sLayerName = stringsUtil.GetFileName(sLabelDoc, True)

sLayerName = "*" & sLayerName & "*"

            Me.AddLabelDirect pWhere, sMessage, sLayerName, , nFont, pColor, sFontName, bVisible, nxRot, nyRot, nZRot, nXScale, nYScale, nZScale, nMinDispDist, bBillBoarding
        
    
        Loop
        
        For i = 0 To g_colLabelGroup.Count - 1
            If UCase(g_colLabelGroup.Item(i + 1).name) = UCase(sLayerName) Then

        '   set some container properties from the first label, as a default:
            Set pGroup = g_colLabelGroup.Item(i + 1)
                If pGroup.Labels.Count > 0 Then
                    Dim pDDD As IDDDText
                    Set pDDD = pGroup.Labels(1)
                    pDDD.GetTextScale X, Y, z
                    pGroup.m_nXScale = X
                    pGroup.m_nYScale = Y
                    pGroup.m_nZScale = z
                    pGroup.FontSize = pDDD.FontSize
                    pGroup.NoUpdatesNeeded
                End If
                Set LoadLabelsFromDoc = pGroup
                Exit For
            End If
        Next
        
        
    Case 2
        Do While Not EOF(lFileID)
            Line Input #lFileID, sLine
            GetAttribsFromLine 2, sLine, sMessage, X, Y, z, nxRot, nyRot, nZRot, nXScale, nYScale, nZScale, nMinDispDist, bVisible, nFont, pColor, bBillBoarding, sFontName, sLayerName, sItem

            Set pWhere = New Point
            With pWhere
                .X = X
                .Y = Y
                .z = z
            End With
            
            Dim pFLayer As IFeatureLayer
            Set pFLayer = GetLayer(sLayerName)
            If Not pFLayer Is Nothing Then
                Me.InitFeatureLayerLabels pFLayer, Nothing, sItem, , nFont, pColor, sFontName
            End If
            
        Loop
        
    
    End Select
    Close lFileID
    
    Debug.Assert 0

    Exit Function
    
LoadLabelsFromDoc_ERR:
    Debug.Print "Unrecoverable Error reading: " & sLabelDoc & "." & vbCrLf & Err.Description
    
    Resume Next
    
End Function


'
'   accept a layername or index and return the corresponding ILayer
'
Public Function GetLayer(sLayer) As ILayer
Dim pSxDoc As ISxDocument
Dim pTOCs As ISxContentsView
Dim pTOC  As IContentsView
Dim i As Integer
Dim pLayers As IEnumLayer
Dim pLayer As ILayer

On Error GoTo GetLayer_Err

    If IsNumeric(sLayer) Then
        Set GetLayer = m_pScene.Layer(sLayer)
    Else
    '   iterate through document layers looking for a name match:
            Set pLayers = m_pScene.Layers

            Set pLayer = pLayers.Next
            Do While Not pLayer Is Nothing
                If UCase(sLayer) = UCase(pLayer.name) Then
                    Set GetLayer = pLayer
                    Exit Function
                End If
                Set pLayer = pLayers.Next
            Loop
            

    End If
    Exit Function
    
GetLayer_Err:
    
End Function



Public Sub PersistLabels(sLabelDocPath As String, Format As eLabelDocType)
'**FORMAT1 = <x,y,z,xrot,yrot,zrot,xScale,yScale,zScale,MinDisplayDistance,message,visible,fontsize,fontname,BillBoarding,fontrgbcolor>
'**FORMAT2 = <layername,item,visible,fontsize,fontrgbcolor>

On Error GoTo PersistLabels_ERR

Dim lFileID As Long

    lFileID = FreeFile
    Open sLabelDocPath For Output As lFileID
        
Dim pGroup As LabelGroup
Dim pDDD As IDDDText
Dim sLine As String
Dim nxRot As Double, nyRot As Double, nZRot As Double
Dim bBillBoarding As Boolean
Dim nXScale As Double, nYScale As Double, nZScale As Double, nMinDispDist As Double

'   header:
    Print #lFileID, "**FORMAT1 = <x,y,z,xrot,yrot,zrot,xScale,yScale,zScale,MinDisplayDistance,message,visible,fontsize,fontname,BillBoarding,fontrgbcolor>"
    Print #lFileID, ""

    For Each pGroup In g_colLabelGroup
        If Not pGroup.Labels Is Nothing Then
        If pGroup.Visible Then
        For Each pDDD In pGroup.Labels
            If pDDD.Enabled Then
            With pDDD
                
                .GetAxisRotation nxRot, nyRot, nZRot
                bBillBoarding = .AutoAdjust
                .GetTextScale nXScale, nYScale, nZScale
                nMinDispDist = .MinDisplayDist
                sLine = PutAttribsIntoLine(1, .Message, .Origin.X, .Origin.Y, .Origin.z, nxRot, nyRot, nZRot, nXScale, nYScale, nZScale, nMinDispDist, .Enabled, .FontSize, .Color, .FontName, bBillBoarding)
            End With
            Print #lFileID, sLine
            End If
        Next
        End If
        End If
    Next

    Close lFileID
        
    Exit Sub
    
PersistLabels_ERR:
    Debug.Assert 0
    Debug.Print "PersistLabels_ERR: " & Err.Description
    Resume Next
    
    
End Sub

'
'   take a labelgroup reference and extent info and derive ranges (for GUI)
'
Public Sub UpdateExtentScale(p As LabelGroup, xDelta As Double, yDelta As Double, zDelta As Double, bUpdateFontSize As Boolean)
On Error GoTo UpdateExtentScales_ERR



    If xDelta = -1 And yDelta = -1 And zDelta = -1 Then
        If Not m_pScene Is Nothing Then
            If Not m_pScene.SceneGraph.IsEmpty Then
                xDelta = m_pScene.Extent.xmax - m_pScene.Extent.xmin
                yDelta = m_pScene.Extent.ymax - m_pScene.Extent.ymin
                zDelta = m_pScene.Extent.zmax - m_pScene.Extent.zmin
                
                p.m_nXScale = xDelta / 20
                p.m_nYScale = yDelta / 20
                p.m_nZScale = p.m_nXScale * 0.2
                
            End If
        End If
    End If
    
    If xDelta <> 0 Then
        p.m_nXOffMax = xDelta
        p.m_nXOffMin = -(xDelta)
    End If
    
    If yDelta <> 0 Then
        p.m_nYOffMax = yDelta
        p.m_nYOffMin = -(yDelta)
    End If
    
    If zDelta <> 0 Then
        p.m_nZOffMax = zDelta
        p.m_nZOffMin = -(zDelta)
    End If

    If bUpdateFontSize Then
        p.FontSize = 20
    End If
    
    
    Exit Sub
    
UpdateExtentScales_ERR:
    Debug.Assert 0
    Debug.Print "UpdateExtentScales_ERR: " & Err.Description
    Resume Next
    
End Sub

Private Sub Class_Terminate()
On Error Resume Next

    
End Sub