关于箭头的绘制

本节内容可以参考文件"\CaseStudy\流程图\纯代码流程图\纯代码绘制之七.Table"

我们用GDI+绘制流程图的目通常是：

1、内置形状种类不够，一些特别的形状需要用GDI+绘制

2、内置形状无法设置文字，文字和形状是分离的，用GDI+绘制则可以将文字和形状融合在一起。

前面的章节我们用代码绘制了各种形状， 但箭头使用的依然是Map控件的内置形状，这也是一般情况下的推荐做法，因为内置的箭头一般足够用了，而且箭头也没必要设置文字。

如果你觉得内置的箭头不够用，需要用GDI+绘制更多样式的箭头，有一个问题你需要考虑：

GDI+的绘制区域是一个矩形，而折线箭头的存在会导致这个矩形区域的尺寸过大，可能会遮掩其他形状，从而影响其他形状触发事件。

解决这个问题思路是：

在GetDrawingBounds事件取第一段线条作为箭头的绘制区域， 你也不用担心影响箭头剩余线段的绘制，因为这个绘制区域并没有约束力，我们依然可以在这个区域之外绘制，实际上GetDrawingBounds设置的是形状响应鼠标事件的矩形区域，而不是绘制区域，只是通常二者是一致的，所以文档用绘制区域这个更通俗的表述。

示例

本示例基于上述思路绘制了下面的流程图，图中有两种类型的箭头：

1、窗口的AfterLoad事件代码：


'初始化地图控件，不是必须的，只是使得地图控件更适合作为流程图控件使用:
Dim map As GeoMap = e.Form.Controls("Map1").GeoMap
map.UseGallPetersProjection = True '采用Gall Peters投影方式
map.Viewport.Limits.MaxLat = 60 '排除高纬度地区，因为高纬度地区变形大
map.Viewport.Limits.MinLat = -60
map.Zoom = 12 '缩放指数设置为12，留足够的区间用于放大和缩小
map.CenterTo( - 160, 50) '中心点设置在有效区域的左上，因为通常都是往右下绘制，同时也留有一定的余地往左上绘制
'增加矢量层:
Dim layer As New VectorLayer()
map.Layers.Add(layer)
layer.Style.Stroke.Width = 2
layer.Style.Font = New Font("微软雅黑", 12)
'用代码绘制流程图，注意以下定位均采用像素，在绘制时候要转为经纬度，
Dim xStart As Integer = 50 '本流程图整体是从左到右，所以起点在左中位置
Dim yStart As Integer = 200
Dim xStep As Integer = 96 '默认形状宽度，也是箭头的默认长度
Dim yStep As Integer = 64 '默认形状高度，宽高比大概是3:2, 96*2/3 = 64
For Each dr As DataRow In DataTables("流程图").DataRows '绘制流程图
    Dim gps As New List(Of GeoPoint)
    Dim pts() As String = dr("位置").Split(",")
    For idx As Integer = 0 To pts.Length - 1 Step 2
        Dim dx As Integer = xStart + Val(pts(idx)) * xStep
        Dim dy As Integer = yStart + Val(pts(idx + 1)) * yStep
        Dim p As New Point(dx, dy)
        gps.Add(map.ToGeoPoint(p))
    Next
    Dim mark As New VectorPlacemark()
    mark.Geometry = gps(0)
    mark.Marker.Shape = MarkerShape.Custom '指定采用标记使用自定形状
    mark.Marker.CustomShape = map.CreateMarkShape(dr) '将数据行设置为ShapeTag，方便OwerDrawMark事件调用
    mark.Tag = dr '将tag设置为对应的数据行，用于响应事件
    layer.Items.Add(mark)
Next

2、Map控件的GetDrawingBounds事件代码：

'注意，这些变量的值要和AFterLoad事件中同名变量的值保持一致。
Dim xStart As Integer = 50 '本流程图整体是从左到右，所以起点在左中位置
Dim yStart As Integer = 200
Dim xStep As Integer = 96 '默认形状宽度，也是箭头的默认长度
Dim yStep As Integer = 64 '默认形状高度，宽高比大概是3:2, 96*2/3 = 64
If e.ShapeTag IsNot Nothing AndAlso TypeOf e.ShapeTag Is DataRow Then
    Dim dr As DataRow = e.ShapeTag
    Select Case dr("类型")
        Case "四边形", "菱形"
            Dim cx As Single = e.Bounds.X + e.Bounds.Width / 2 '先计算中心点位置
            Dim cy As Single = e.Bounds.Y + e.Bounds.Height / 2
            e.Bounds = New RectangleF(cx - xStep / 2 , cy - yStep / 2 , xStep, yStep)
        Case "箭头" '取线条的第一段做为形状的尺寸
            Dim points As New List(Of Point)
            Dim pts() As String = dr("位置").Split(",")
            For idx As Integer = 0 To pts.Length - 1 Step 2
                Dim dx As Integer = xStart + Val(pts(idx)) * xStep
                Dim dy As Integer = yStart + Val(pts(idx + 1)) * yStep
                points.Add(New Point(dx, dy))
            Next
            If pts.Length >= 2 Then '取线条的第一段做为形状的尺寸
                Dim x As Integer = points(0).X
                Dim y As Integer = points(0).Y
                Dim width As Integer = points(1).X - x
                Dim height As Integer = points(1).Y - y
                If width > height Then '水平线
                    e.Bounds = New RectangleF(x, y, width, 8)
                Else '垂直线
                    e.Bounds = New RectangleF(x, y, 8, height)
                End If
            End If
    End Select
End If

3、Map控件的OwerDrawMark事件：

'注意，这些变量的值要和AFterLoad事件中同名变量的值保持一致
Dim xStart As Integer = 50 '本流程图整体是从左到右，所以起点在左中位置
Dim yStart As Integer = 200
Dim xStep As Integer = 96 '默认形状宽度，也是箭头的默认长度
Dim yStep As Integer = 64 '默认形状高度，宽高比大概是3:2, 96*2/3 = 64
If e.ShapeTag IsNot Nothing AndAlso TypeOf e.ShapeTag Is DataRow Then
    Dim dr As DataRow = e.ShapeTag
    Dim brush As Brush = Brushes.Black
    Dim pen As New Pen(color.Black)
    pen.Width = 2
    Dim rect As Rectangle = Rectangle.Round(e.Bounds)
    Select Case dr("类型")
        Case "四边形"
            e.Graphics.DrawRectangle(pen, rect)
        Case "菱形"
            Dim p1 As New PointF(rect.X, rect.Y + rect.Height / 2) '左顶点
            Dim p2 As New PointF(rect.X + rect.Width / 2, rect.Y) '上顶点
            Dim p3 As New PointF(rect.X + rect.Width , rect.Y + rect.Height / 2) '右顶点
            Dim p4 As New PointF(rect.X + rect.Width / 2, rect.Y + rect.Height) '下顶点
            e.Graphics.DrawPolygon(pen, {p1, p2, p3, p4}) '绘制菱形
        Case "箭头"
            '绘制箭杆
            pen.Width = 1
            Pen.DashStyle = dr("线型")
            If pen.DashStyle <> DashStyle.Solid Then
                pen.Color = color.Red '非实线改为红色
            End If
            Dim points As New List(Of Point)
            Dim pts() As String = dr("位置").Split(",")
            For idx As Integer = 0 To pts.Length - 1 Step 2
                Dim dx As Integer = xStart + Val(pts(idx)) * xStep
                Dim dy As Integer = yStart + Val(pts(idx + 1)) * yStep
                points.Add(New Point(dx, dy))
            Next
            e.Graphics.DrawLines(pen, points.ToArray())
            '绘制箭头
            Dim prevP As Point = points(points.Count - 2)
            Dim lastP As Point = points(points.Count - 1)
            points.Clear()
            Dim length As Integer = -12
            If Math.Abs(lastp.X - prevP.X) > Math.Abs(lastp.Y - prevP.Y) Then
                If lastP.X < prevp.X Then length = 12
                points.Add( New Point(lastP.X + length , lastP.Y - 7))
                points.Add(lastP)
                points.Add( New Point(lastP.X + length, lastP.Y + 7))
                If pen.DashStyle <> DashStyle.Solid Then '非实线箭头内凹
                    points.Add( New Point(lastP.X + length / 2, lastP.Y))
                End If
            Else
                If lastP.y < prevp.y Then length = 12
                points.Add( New Point(lastp.X - 7, lastP.Y + length))
                points.Add(lastP)
                points.Add( New Point(lastp.X + 7, lastP.Y + length))
                If pen.DashStyle <> DashStyle.Solid Then '非实线箭头内凹
                    points.Add( New Point(lastP.X , lastP.Y + length / 2))
                End If
            End If
            e.Graphics.FillPolygon(brushes.Red, points.ToArray())
    End Select
    Dim fnt As New Font("微软雅黑", 12)
    Dim fmt As New StringFormat()
    fmt.Alignment = StringAlignment.Center
    fmt.LineAlignment = StringAlignment.Center
    If dr("类型") = "箭头" Then
        If rect.Width > rect.Height Then
            rect.Height = rect.Height + 20
        Else
            rect.Width = rect.Width + 20
        End If
    End If
    e.Graphics.DrawString(dr("文本"), fnt, brush, rect, fmt)
End If