Imports System.Collections.ObjectModel Imports System.Runtime.CompilerServices Imports NetTopologySuite.Features Imports NetTopologySuite.Operation.Overlay Imports ThinkGeo.MapSuite.Drawing Imports ThinkGeo.MapSuite.Shapes Imports ThinkGeo.MapSuite.Styles Imports Wintellect.PowerCollections Friend Class MoveableLableStyle Inherits PositionStyle Public Sub New(ByVal sMoveableLabelName As String) 'sMoveableLabelName should be MoveableLabel Me.MoveableLabelStyle(sMoveableLabelName) End Sub Public Sub MoveableLabelStyle(textColumnName As String) Me.TextColumnName = textColumnName Dim oGC As New GeoColor(175, GeoColor.StandardColors.White) Dim fontStyles As New DrawingFontStyles fontStyles = DrawingFontStyles.Regular Me.Font = New GeoFont("Arial", 8, fontStyles) Me.PointPlacement = PointPlacement.Center Me.DuplicateRule = LabelDuplicateRule.UnlimitedDuplicateLabels Me.OverlappingRule = LabelOverlappingRule.AllowOverlapping 'Me.Mask = AreaStyles.CreateSimpleAreaStyle(GeoColors.White, GeoColor.SimpleColors.Black, 2) Me.Mask = AreaStyles.CreateSimpleAreaStyle(oGC, GeoColor.SimpleColors.Black, 2) Me.MaskType = MaskType.RoundedCorners Me.MaskMargin = 3 Me.LeaderLineStyle = New LineStyle(New GeoPen(GeoColor.SimpleColors.Black, 2)) End Sub Protected Overrides Sub DrawCore(features As IEnumerable(Of ThinkGeo.MapSuite.Shapes.Feature), canvas As GeoCanvas, labelsInThisLayer As Collection(Of SimpleCandidate), labelsInAllLayers As Collection(Of SimpleCandidate)) Dim oGC As New GeoColor(225, 0, 50) For Each feature In features If feature.GetWellKnownType = WellKnownType.Line Then Dim lineShape As LineShape lineShape = feature.GetShape Dim newFeature As ThinkGeo.MapSuite.Shapes.Feature newFeature = New ThinkGeo.MapSuite.Shapes.Feature(lineShape.Vertices(0)) newFeature.ColumnValues.Add(TextColumnName, feature.ColumnValues(TextColumnName)) Dim labelingCandidates As Collection(Of LabelingCandidate) labelingCandidates = GetLabelingCandidates(newFeature, canvas) For Each labelingCandidate In labelingCandidates Dim maskArea As PolygonShape maskArea = ConvertPolygonShapeToWorldCoordinate(labelingCandidate.ScreenArea, canvas.CurrentWorldExtent, canvas.Width, canvas.Height) Dim closestPoint As PointShape closestPoint = maskArea.GetClosestPointTo(New PointShape(lineShape.Vertices(1)), canvas.MapUnit) If closestPoint IsNot Nothing Then lineShape.Vertices(0) = New Vertex(closestPoint.X, closestPoint.Y) LeaderLineStyle.Draw(New LineShape() {lineShape}, canvas, labelsInThisLayer, labelsInAllLayers) End If DrawMask(labelingCandidate, canvas, labelsInThisLayer, labelsInAllLayers) For Each labelInfo In labelingCandidate.LabelInformation Dim textPathInScreen As ScreenPointF textPathInScreen = New ScreenPointF(labelInfo.PositionInScreenCoordinates.X, labelInfo.PositionInScreenCoordinates.Y) 'RDJ - fix this where the brush is defined properly 'canvas.DrawText(labelInfo.Text, Font, TextSolidBrush, HaloPen, New ScreenPointF() {textPathInScreen}, DrawingLevel, 0, 0, labelInfo.RotationAngle, DrawingTextAlignment.Default) TextSolidBrush = New GeoSolidBrush(oGC) canvas.DrawText(labelInfo.Text, Font, TextSolidBrush, HaloPen, New ScreenPointF() {textPathInScreen}, DrawingLevel, 0, 0, labelInfo.RotationAngle, DrawingTextAlignment.Default) Next Next End If Next 'MyBase.DrawCore(features, canvas, labelsInThisLayer, labelsInAllLayers) End Sub Private Function ConvertPolygonShapeToWorldCoordinate(simplePolygon As PolygonShape, currentWorldExtent As RectangleShape, canvasWidth As Single, canvasHeight As Single) As PolygonShape Dim upperLeftX As Double Dim upperLeftY As Double Dim extentWidth As Double Dim extentHeight As Double Dim widthFactor As Double Dim heightFactor As Double upperLeftX = currentWorldExtent.UpperLeftPoint.X upperLeftY = currentWorldExtent.UpperLeftPoint.Y extentWidth = currentWorldExtent.Width extentHeight = currentWorldExtent.Height widthFactor = extentWidth / canvasWidth heightFactor = extentHeight / canvasHeight Dim count As Integer count = simplePolygon.InnerRings.Count + 1 Dim ringShape As RingShape = Nothing Dim verticesCount As Integer = 0 Dim i As Integer For i = 0 To count - 1 If i = 0 Then ringShape = simplePolygon.OuterRing Else ringShape = simplePolygon.InnerRings(i - 1) End If verticesCount = verticesCount + ringShape.Vertices.Count Next Dim wellKnownBinary() As Byte Dim header() As Byte ReDim header(5) header = {1, 3, 0, 0, 0} ReDim wellKnownBinary(9 + (count * 4) + (verticesCount * 16)) CopyToArray(header, wellKnownBinary, 0) CopyToArray(BitConverter.GetBytes(count), wellKnownBinary, 5) Dim index As Integer = 9 For i = 0 To count - 1 If i = 0 Then ringShape = simplePolygon.OuterRing Else ringShape = simplePolygon.InnerRings(i - 1) End If CopyToArray(BitConverter.GetBytes(ringShape.Vertices.Count), wellKnownBinary, index) index = index + 4 Dim j As Integer For j = 0 To ringShape.Vertices.Count - 1 Dim pointX As Double Dim pointY As Double Dim worldPointX As Double Dim worldPointY As Double pointX = ringShape.Vertices(j).X pointY = ringShape.Vertices(j).Y worldPointX = pointX * widthFactor + upperLeftX worldPointY = upperLeftY - pointY * heightFactor CopyToArray(BitConverter.GetBytes(worldPointX), wellKnownBinary, index) index = index + 8 CopyToArray(BitConverter.GetBytes(worldPointY), wellKnownBinary, index) index = index + 8 Next Next Return New PolygonShape(wellKnownBinary) End Function Private Sub CopyToArray(sourceArray As Byte(), destinateArray As Byte(), destinateIndex As Long) Dim i As Integer For i = 0 To sourceArray.Length - 1 destinateArray(destinateIndex + i) = sourceArray(i) Next End Sub End Class