VB绘制带箭头直线的代码

一江秋水

VB绘制带箭头直线的代码

　　我们在绘图时常常需要画带箭头的直线，以前我在自编的程序上画箭头时，都是先画一条直线，然后在线端点的两边各画一条短斜线，这样不但麻烦，而且画出来的箭头不标准，不好看。于是我就决定在程序中增加画箭头的代码。
　　新建一个窗体，上面只放置一个Line控件。代码如下：

Option Explicit

Dim editX As Single     '画线时鼠标的初始X坐标
Dim editY As Single     '画线时鼠标的初始Y坐标
Dim ArrowPos As Integer '箭头位置：0-无箭头，1-鼠标按下端，2-鼠标抬起端，3-两端均有

Private Sub Form_Load()
Line1.Visible = False
DrawWidth = 3
Line1.BorderWidth = DrawWidth
ScaleMode = 3
AutoRedraw = True
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
  Case 38: ArrowPos = IIf(ArrowPos = 0, 2, IIf(ArrowPos = 3, 1, IIf(ArrowPos = 2, 0, 3))) '↑单次按在鼠标抬起端画箭头，双次按取消
  Case 40: ArrowPos = IIf(ArrowPos = 0, 1, IIf(ArrowPos = 3, 2, IIf(ArrowPos = 1, 0, 3))) '↓单次按在鼠标按下端画箭头，双次按取消
End Select
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
editX = X: editY = Y
Line1.X1 = X: Line1.Y1 = Y: Line1.Visible = True
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Line1.X2 = X: Line1.Y2 = Y
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Line1.Visible = False
Line (editX, editY)-(X, Y), 0
If ArrowPos Then DrawArrow editX, editY, X, Y, Shift
End Sub

Private Sub DrawArrow(X1!, Y1!, X2!, Y2!, s%)
Dim LineL%     '直线长
Dim FlankL%    '箭头中间线长
Dim sMidW%     '箭头边线终点与中间线的距离
Dim bx!, by!   '箭头边线终点连线与中间线交点坐标
Dim sLX!, sLY! '箭头左边线终点坐标
Dim sRX!, sRY! '箭头右边线终点坐标
Dim X3!, Y3!, X4!, Y4!

FlankL = 50
sMidW = 20
LineL = Sqr(((X2 - X1) ^ 2 + (Y2 - Y1) ^ 2)) '由勾股定理求直线长

Select Case ArrowPos '画箭头
  Case 1: GoSub 100 '在鼠标按下端画箭头
  Case 2: GoSub 200 '在鼠标抬起端画箭头
  Case 3: GoSub 100: GoSub 200 '两端都画箭头
End Select

Exit Sub

100
bx = X1 + FlankL / LineL * (X2 - X1)
by = Y1 + FlankL / LineL * (Y2 - Y1)
sLX = bx + sMidW * (Y1 - by) / FlankL
sLY = by - sMidW * (X1 - bx) / FlankL
sRX = bx - sMidW * (Y1 - by) / FlankL
sRY = by + sMidW * (X1 - bx) / FlankL
X3 = X1: Y3 = Y1
X4 = X1 + FlankL / 2 / LineL * (X2 - X1)
Y4 = Y1 + FlankL / 2 / LineL * (Y2 - Y1)
GoSub 300
Return

200
bx = X2 - FlankL / LineL * (X2 - X1)
by = Y2 - FlankL / LineL * (Y2 - Y1)
sLX = bx + sMidW * (Y2 - by) / FlankL
sLY = by - sMidW * (X2 - bx) / FlankL
sRX = bx - sMidW * (Y2 - by) / FlankL
sRY = by + sMidW * (X2 - bx) / FlankL
X3 = X2: Y3 = Y2
X4 = X2 - FlankL / 2 / LineL * (X2 - X1)
Y4 = Y2 - FlankL / 2 / LineL * (Y2 - Y1)
GoSub 300
Return

300
If s = 2 Then '如果在松开鼠标前按下【Ctrl】键，连结箭头两边线，并去掉箭头中间线
  Line (X3, Y3)-(bx, by), BackColor
  Line (sLX, sLY)-(sRX, sRY), 0
End If
Line (X3, Y3)-(sLX, sLY), 0
Line (X3, Y3)-(sRX, sRY), 0
Return

End Sub

　　简要说明：
　　按下【↑】键，箭头画在鼠标抬起端，按下【↓】键，箭头画在鼠标按下端。如果在松开鼠标前按下【Ctrl】键不放，则连结箭头两边线(三角形箭头)。