modlabel3dtoolbar.bas

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

Public Sub ReinitLayerLabels()
'   do this to set new label item since the text collection
'   must be recreated:
On Error GoTo ReinitLayerLabels_ERR
Dim pFLayer As IFeatureLayer
    
'   ensure currentlabelgroup class:
    frmProps.GetCurrentLabelGroup
    
    Set pFLayer = GetLayer(g_pCurrentGroup.Name)
    
'   if this is not a feature class then exit:
    If pFLayer Is Nothing Then Exit Sub
    
'   call the init feature labels of the label engine using flag to not overwrite
'   basic settings other then the label item:
    g_pLabelEngine.InitFeatureLayerLabels pFLayer, Nothing, g_pCurrentGroup.LabelItem, True, , , , , , , g_pCurrentGroup.m_nXScale, g_pCurrentGroup.m_nYScale, g_pCurrentGroup.m_nZScale
        
    Exit Sub
    
ReinitLayerLabels_ERR:
    Debug.Assert 0
    Debug.Print "ReinitLayerLabels_ERR: " & Err.Description
    Resume Next
    
End Sub

Public Sub RefreshViewers(Optional bGraphicsLayer As Boolean)
On Error GoTo RefreshViewers_ERR

    If bGraphicsLayer Then g_pDoc.Scene.SceneGraph.Invalidate g_pDoc.Scene.ActiveGraphicsLayer, True, False
    g_pDoc.Scene.SceneGraph.RefreshViewers
    frmProps.RefreshMe
    
    Exit Sub
    
RefreshViewers_ERR:
    Debug.Print "ReinitLayerLabels_ERR: " & Err.Description
    Debug.Assert 0
    
End Sub

'   call the label engine's INITFEATURELABELS routine; use the first
'   'usable' field name as the labelitem if not supplied:
Public Sub AddLayerToLabelList(pFLayer As IFeatureLayer, Optional sDefaultItem As String, Optional pFontColor As IRgbColor, Optional sFontName As String, Optional nFontSize As Double, Optional bvisible As Boolean)
Dim pFieldNames As New Collection
Dim sItem As String
Dim i As Integer

On Error GoTo AddLayerToLabelList_ERR

    If pFLayer Is Nothing Then Exit Sub
    
'   get the first usable field name as the labelitem if not supplied:
    Set pFieldNames = GetUsableFieldNames(pFLayer)
    If pFieldNames Is Nothing Then
        Debug.Assert 0
        Exit Sub
    End If
    
    If Len(sDefaultItem) < 1 Then
        If pFieldNames.Count > 0 Then
            sItem = pFieldNames.Item(1)
        Else
            Debug.Assert 0
            Exit Sub
        End If
    Else
        '   make sure that the default item is in the usable field collection:
        For i = 0 To pFieldNames.Count - 1
            If UCase(sDefaultItem) = UCase(pFieldNames.Item(i + 1)) Then
                sItem = sDefaultItem
                Exit For
            End If
        Next
    End If
    
    If Len(Trim(sItem)) < 1 Then
        Debug.Assert 0
        Exit Sub
    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 nFont As Double
Dim sFont As String

    
    If IsMissing(sFontName) Or Len(sFontName) < 1 Then
        sFont = "ARIAL"
    Else
        sFont = sFontName
    End If
    
Dim nXScale As Double
Dim nYScale As Double
Dim nZScale As Double


    xD = pFLayer.AreaOfInterest.XMax - pFLayer.AreaOfInterest.XMin
    yD = pFLayer.AreaOfInterest.YMax - pFLayer.AreaOfInterest.YMin
    

    nXScale = xD / 20
    nYScale = yD / 20 ' nXScale
    nZScale = nXScale * 0.2

'   init the feature labels:
    g_pLabelEngine.InitFeatureLayerLabels pFLayer, Nothing, sItem, False, nFont, pFontColor, sFont, , , , nXScale, nYScale, nZScale

'   init the visibility as off:
    Dim pCls As LabelGroup
    Set pCls = g_pLabelEngine.LabelGroup(pFLayer.Name)
    pCls.Visible = False

'   add this group to the GUI:
    AddToFormLayerList pCls

'   update the extent of the non-feature groups:
    If Not m_bDontUpdateDefaults Then
    '   first layer added; need to update <graphic layer> default fontsize

        UpdateGroupLayersExtent
        m_bDontUpdateDefaults = True
    End If
    
    
    
    Exit Sub
    
AddLayerToLabelList_ERR:
    Debug.Print "AddLayerToLabelList_ERR: " & Err.Description
    Resume Next
    
End Sub
'   remove the label group from the label engine and the GUI
'
Public Sub RemoveLayerFromLabelList(pFLayer As IFeatureLayer)
Dim pClsLayerLBL As LabelGroup
Dim i As Integer
    
On Error GoTo RemoveLayerFromLabelList_ERR

    For Each pClsLayerLBL In g_pLabelEngine.LabelGroups
        i = i + 1
        If UCase(pFLayer.Name) = UCase(pClsLayerLBL.LayerName) Then
            RemoveFromFormLayerList pClsLayerLBL
            g_pLabelEngine.LabelGroups.Remove i
            Exit Sub
        End If
    Next
    
    Exit Sub
        
RemoveLayerFromLabelList_ERR:
    Debug.Assert 0
    Debug.Print "RemoveLayerFromLabelList_ERR: " & Err.Description
    Resume Next
End Sub

'   add the label group name to the GUI combo box:
'
Public Sub AddToFormLayerList(pCls As LabelGroup)

    On Error GoTo AddToFormLayerList_ERR

    If pCls Is Nothing Then Exit Sub
    
    frmProps.cmbLayers.AddItem pCls.Name
    If frmProps.cmbLayers.ListCount = 1 Then
        frmProps.cmbLayers.ListIndex = 0
    End If
    
    frmProps.RefreshMe
    
    Exit Sub
    
AddToFormLayerList_ERR:
    Debug.Print "AddToFormLayerList_ERR: " & Err.Description
    Resume Next
    
End Sub
'   remove the LabelGroup from the GUI:
'
Public Sub RemoveFromFormLayerList(pCls As LabelGroup)
Dim i As Integer

On Error GoTo RemoveFromFormLayerList_ERR

    If pCls Is Nothing Then Exit Sub
    If Len(Trim(pCls.LayerName)) < 1 Then Exit Sub
    
    For i = 0 To frmProps.cmbLayers.ListCount - 1
        If UCase(frmProps.cmbLayers.Text) = UCase(pCls.LayerName) Then
            frmProps.cmbLayers.RemoveItem i
            Exit For
        End If
    Next
        
    If frmProps.cmbLayers.ListIndex < 0 Then
        frmProps.cmbLabelField.Clear
        frmProps.chkOn.Value = 0
    End If
    
    frmProps.RefreshMe
    
    Exit Sub
    
RemoveFromFormLayerList_ERR:
    'MsgBox "RemoveFromFormLayerList_ERR: " & Err.Description
    Debug.Print "RemoveFromFormLayerList_ERR: " & Err.Description
    Resume Next
    
End Sub


Public Sub SetFontInfo(pCurrentLayer As LabelGroup, Optional pCurrentLabel As IDDDText)
Dim pLay As LabelGroup
Dim pLBL As IDDDText
Dim sFontName As String
Dim nFontSize As Long
Dim pColor As IRgbColor
Dim nExtScale As Double

On Error GoTo SetFontInfo_ERR

    If Not pCurrentLayer Is Nothing Then
        If pCurrentLayer.ExtentNeedsInit Then

            g_pLabelEngine.UpdateExtentScale pCurrentLayer, -1, -1, -1, True
            pCurrentLayer.ExtentNeedsInit = False
        End If
        
        Set pLay = pCurrentLayer
    End If
    
    If Not pCurrentLabel Is Nothing Then
        Set pLBL = pCurrentLabel
    End If
    



    With frmProps.CD1
        .FLAGS = cdlCFBoth Or cdlCFEffects Or cdlCFTTOnly
        
        If Not pLay Is Nothing Then
            If Not pLay.FontColor Is Nothing Then .Color = pLay.FontColor.RGB
        ElseIf Not pLBL Is Nothing Then
            If Not pLBL.Color Is Nothing Then .Color = pLBL.Color.RGB
        End If
        
        If Not pLay Is Nothing Then
            .FontName = pLay.FontName
        ElseIf Not pLBL Is Nothing Then
            .FontName = pLBL.FontName
        End If
        
        If Not pLay Is Nothing Then
            
            .FontSize = Round(pLay.FontSize, 0)
        ElseIf Not pLBL Is Nothing Then
           
            .FontSize = pLBL.FontSize
    
        End If
        
        .CancelError = True
        .ShowFont
            
        
        
        sFontName = .FontName
        nFontSize = .FontSize

        Set pColor = New RgbColor
        
        If .Color > -1 Then pColor.RGB = .Color
        
        If Not pLay Is Nothing Then
            If nFontSize > 0 Then pLay.FontSize = nFontSize
            If sFontName <> "" Then pLay.FontName = sFontName
            Set pLay.FontColor = pColor
            UpdateLabels pLay, "FONT"
        ElseIf Not pLBL Is Nothing Then
            If nFontSize > 0 Then pLBL.FontSize = nFontSize
            If sFontName <> "" Then pLBL.FontName = sFontName
            Set pLBL.Color = pColor
            RefreshViewers
        End If
        
        
        
        
        
    End With
    
    Exit Sub
    
SetFontInfo_ERR:
    If Err.Number <> 32755 Then 'canceled:
        Debug.Print "SetFontInfo_ERR: " & Err.Description
    End If

    
End Sub

Public Sub SetFontInfoForSingleLBL(pLBL As IDDDText)
Dim sFontName As String
Dim nFontSize As Long
Dim pColor As IRgbColor

On Error GoTo SetFontInfoForSingleLBL_ERR
    
    With frmProps.CD1
        .FLAGS = cdlCFBoth Or cdlCFEffects
        
        .Color = pLBL.Color.RGB
        
        .FontName = pLBL.FontName
        .FontSize = CInt(pLBL.FontSize)
        
        .ShowFont
            
        If .CancelError Then Exit Sub
        
        sFontName = .FontName
        nFontSize = .FontSize

        Set pColor = New RgbColor
        
        If .Color > -1 Then pColor.RGB = .Color
        
        If nFontSize > 0 Then pLBL.FontSize = nFontSize
        If sFontName <> "" Then pLBL.FontName = sFontName
        
        Set pLBL.Color = pColor
        
        RefreshViewers
        
    End With
    
    Exit Sub
    
SetFontInfoForSingleLBL_ERR:
    Debug.Assert 0
    Debug.Print "SetFontInfoForSingleLBL_ERR: " & Err.Description
    
    
End Sub


'   return the screen coordinates of the current mouse postion, or the center of the screen
'
Public Sub GetCurPos(ByRef outX As Long, ByRef outY As Long, Optional bGetCenterScreenInstead As Boolean)
Dim coord As POINT_TYPE  ' receives coordinates of cursor
Dim retval As Long  ' return value
On Error Resume Next

    If bGetCenterScreenInstead Then
        coord.X = (Screen.Width / 2) / Screen.TwipsPerPixelX
        coord.Y = Screen.Height / 2 / Screen.TwipsPerPixelY
    Else
        retval = GetCursorPos(coord)  ' read cursor location
        With coord
            .X = .X
            .Y = .Y
        End With
    End If
    
    With Screen
        outX = (coord.X * .TwipsPerPixelX)
        outY = (coord.Y * .TwipsPerPixelY)
    End With

   
End Sub

Public Sub DoDebug()
Debug.Assert 0
Dim pDDD As IDDDText
Set pDDD = g_pLabelEngine.LabelGroup(1).Labels(1)
Dim X As Double, Y As Double, z As Double

pDDD.GetAxisRotation X, Y, z

Debug.Print X & "," & Y & "," & z

Debug.Assert 0
    
End Sub

'   call the init of the passed in labelgroup with the defaults:
'
Public Sub ResetToDefaults(p As LabelGroup)
Dim xD As Double, yD As Double, zD As Double
Dim xOffMin As Double, yOffMin As Double, xOffMax As Double, yOffMax As Double
Dim nFont As Double
Dim pFLayer As IFeatureLayer
Dim nExtentScale As Double
Dim nXScale As Double
Dim nYScale As Double
Dim nZScale As Double