Modifying Callout Label Locations for Features

11-16-2011 01:31 PM
New Contributor
Hi I have this code that moves the callout boxes in a certain orientation so that it is not on top of a point but right now it only works for graphics I wanted some help on modifying it so it works for point features and not just graphics.

Private pMxDocument As IMxDocument
Private pFillSymbol As IFillSymbol
Private pRgbColor As IRgbColor
Private pCallout As ILineCallout
Private pTextSymbol As IFormattedTextSymbol
Private CalloutLocation As IPoint
Private IsDecimalDegrees As Boolean
Private xOffset, yOffset As Double

Sub AddGraphicsCoords()

Dim pActiveView As IActiveView
Dim pGraphicsContainer As IGraphicsContainer
Dim pGraphicsContainerSelect As IGraphicsContainerSelect
Dim Ppoint As IPoint
Dim pPtElement As IElement
Dim pCalloutElement As IElement
Dim pEnumElement As IEnumElement
Dim pGFLayer As IGeoFeatureLayer

Set pMxDocument = ThisDocument

' There should be a selection of points. Check.
Set pActiveView = pMxDocument.ActivatedView
Set pGraphicsContainerSelect = pActiveView
Set pGraphicsContainer = pActiveView
If pGraphicsContainerSelect.ElementSelectionCount < 1 Then
    MsgBox "You must select some point graphics to label."
    Exit Sub
End If

' --------------------------------------------------------------
'  Now we can set some default parameters for ALL callout boxes,
'  whether feature or graphic-based.
' --------------------------------------------------------------

Set pRgbColor = New RgbColor
    With pRgbColor
        .Red = 255
        .Green = 255
        .Blue = 255
    End With

' Remember: an IFormattedTextSymbol is an interface on a TextSymbol.
' A TextSymbol contains one TextBackground. A LineCallout is a type of
' Callout, which is a type of TextBackground. Each LineCallout has
' a Border property, which is a SimpleFillSymbol
Set pFillSymbol = New SimpleFillSymbol
pFillSymbol.Color = pRgbColor
Set pCallout = New LineCallout
Set pCallout.AccentBar = Nothing
Set pCallout.Border = pFillSymbol
pCallout.Gap = 0
Set pTextSymbol = New TextSymbol
Set pTextSymbol.Background = pCallout

' Use this boolean later to set coordinate text formatting
If pMxDocument.FocusMap.MapUnits = esriDecimalDegrees Then
    IsDecimalDegrees = True
    IsDecimalDegrees = False
End If

' Set these so that the callouts don't appear right over the point
xOffset = pMxDocument.ActiveView.Extent.Width / 8
yOffset = pMxDocument.ActiveView.Extent.Width / 20

' Use an enumeration of all the selected points.
Set pEnumElement = pGraphicsContainerSelect.SelectedElements
Set pPtElement = pEnumElement.Next

' Loop through each selected element.
While Not pPtElement Is Nothing
    If TypeOf pPtElement Is IMarkerElement Then
        Set Ppoint = pPtElement.Geometry
        Set pCalloutElement = GetCalloutOnPoint(Ppoint)
        ' Can't call AddElement on an empty Geometry
        pGraphicsContainer.AddElement pCalloutElement, 0
        pCalloutElement.Activate pActiveView.ScreenDisplay
        pActiveView.PartialRefresh esriViewGraphics, pCalloutElement, Nothing
        Set pPtElement = pEnumElement.Next
        MsgBox "Selection must consist only of points!"
        Exit Sub
    End If

Set pFillSymbol = Nothing
Set pRgbColor = Nothing
Set pCallout = Nothing
Set pTextSymbol = Nothing
Set CalloutLocation = Nothing

End Sub

Private Function GetCalloutOnPoint(param_Pt As IPoint) As IElement
' Use point's coordinates to create a new callout.
' Return this as an element, and let calling proc. handle display.

Dim xCoord As Double, xCoordText As String
Dim yCoord As Double, yCoordText As String

Dim pTextElement As ITextElement, outElement As IElement

param_Pt.QueryCoords xCoord, yCoord
If IsDecimalDegrees Then
    xCoordText = FormatNumber(xCoord, 5, vbUseDefault, vbUseDefault, vbFalse)
    yCoordText = FormatNumber(yCoord, 5, vbUseDefault, vbUseDefault, vbFalse)
    xCoordText = FormatNumber(xCoord, 2, vbUseDefault, vbUseDefault, vbFalse)
    yCoordText = FormatNumber(yCoord, 2, vbUseDefault, vbUseDefault, vbFalse)
End If

' Use this code to set the offset for the callout box
Set CalloutLocation = New Point
CalloutLocation.PutCoords xCoord - xOffset, yCoord + yOffset
pCallout.AnchorPoint = param_Pt

Set pTextElement = New TextElement
Set outElement = pTextElement
outElement.Geometry = CalloutLocation
pTextElement.Text = xCoordText & vbCrLf & yCoordText
pTextElement.Symbol = pTextSymbol
Set GetCalloutOnPoint = outElement

End Function
Tags (2)
0 Kudos
0 Replies