如何划箭头！

[prodeng]

我在picture中要用LINE方法画带箭头的直线应该如何写代码呢？在线等。。。

[lovebeethoven]

gz

• 打赏
• 举报

回复 赞

[chinaren502]

建议楼楼上 贴出代码好吗?

• 打赏
• 举报

回复 赞

[hhyttppd]

那是人家的劳动成果，怎么能说人家自私，没事的时候我写完了贴出来。

• 打赏
• 举报

回复 赞

[prodeng]

给一点代码吧！我急着要用，这里多谢了！

• 打赏
• 举报

回复 赞

[junglerover]

算了，也不是多好的东西，我就不藏私了。首先声明如下：

我这里指的箭头图形是一个长条矩形顶着一个等腰三角形那种。就是形如WORD里，“自选图形|箭头总汇”里面的第一种箭头；

以下代码放在GDI.BAS模块里：

Option Explicit

Public Type POINTAPI
X As Long
Y As Long
End Type
Public WIN_DIR As String
Public WINSYS_DIR As String

Private Declare Function GetPrivateProfileString Lib "kernel32" _
Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, ByVal lpDefault As String, _
ByVal lpReturnedString As String, ByVal nSize As Long, _
ByVal lpFileName As String) As Long

Private Declare Function WritePrivateProfileString Lib "kernel32" _
Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) _
As Long

Public Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As Any, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Public Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As Any, ByVal nCount As Long) As Long
Public Declare Function FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
Public Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function SetDCBrushColor Lib "gdi32.dll" (ByVal hdc As Long, ByVal colorref As Long) As Long
Public Declare Function SetDCPenColor Lib "gdi32.dll" (ByVal hdc As Long, ByVal colorref As Long) As Long

Public Const ALTERNATE = 1 ' ALTERNATE and WINDING are
Public Const WINDING = 2 ' constants for FillMode.
Public Const BLACKBRUSH = 1
Public Const DC_PEN = 19

• 打赏
• 举报

回复 赞

[junglerover]

以下代码放在CArrow.Cls里：注意这里的属性获取和设置，都做了从TWIP到PIXEL的转换工作。

Option Explicit

Private Const CON_DIS = 45
Dim mX1 As Long
Dim mY1 As Long
Dim mX2 As Long
Dim mY2 As Long

Dim mWidth As Long
Dim mArrowWidth As Long
Dim mArrowHeight As Long

Dim TWIP_PER_PIXEL As Long

Public Color As Long '颜色
Public FillStyle As Long '填充模式 0－空心 1－实心

'在指定的句柄设备上将自己画出来
Public Sub DrawMe(ByVal hdc As Long, ByVal hWnd As Long)
Dim tAStartX As Long, tAStartY As Long
Dim tAng1 As Double
Dim tOffsetX As Long, tOffsetY As Long
Dim tPoly(1 To 7) As POINTAPI
Dim NumCoords As Integer
Dim hBrush As Long, hRgn As Long

NumCoords = UBound(tPoly)
'计算线段的倾斜角度
If mX1 < mX2 Then
tAng1 = Atn((mY2 - mY1) / (mX2 - mX1))
ElseIf mX1 > mX2 Then
tAng1 = 3.14159 - Atn((mY2 - mY1) / (mX1 - mX2))
Else
If mY2 > mY1 Then
tAng1 = 3.14159 / 2
Else
tAng1 = 0 - 3.14159 / 2
End If
End If

'计算箭头起始点的坐标
tAStartX = mX2 - Cos(tAng1) * mArrowHeight
tAStartY = mY2 - Sin(tAng1) * mArrowHeight

'计算矩形偏移量
tOffsetX = (mWidth / 2) * Sin(tAng1)
tOffsetY = (mWidth / 2) * Cos(tAng1)

'计算矩形各个顶点的坐标
tPoly(1).X = mX1 + tOffsetX: tPoly(1).Y = mY1 - tOffsetY
tPoly(2).X = mX1 - tOffsetX: tPoly(2).Y = mY1 + tOffsetY
tPoly(3).X = tAStartX - tOffsetX: tPoly(3).Y = tAStartY + tOffsetY
tPoly(7).X = tAStartX + tOffsetX: tPoly(7).Y = tAStartY - tOffsetY

'计算箭头偏移量
tOffsetX = (mWidth / 2 + mArrowWidth) * Sin(tAng1)
tOffsetY = (mWidth / 2 + mArrowWidth) * Cos(tAng1)

tPoly(4).X = tAStartX - tOffsetX: tPoly(4).Y = tAStartY + tOffsetY
tPoly(6).X = tAStartX + tOffsetX: tPoly(6).Y = tAStartY - tOffsetY

tPoly(5).X = mX2: tPoly(5).Y = mY2
Call Polygon(hdc, tPoly(1), NumCoords)
DoEvents

'设置颜色
Call SetDCPenColor(hdc, Color)

' 获得画刷
hBrush = GetStockObject(DC_PEN)
DoEvents
' 为了填充颜色创建区域
DoEvents
'如果创建成功，且需要填充，就使用颜色填充

Debug.Print hRgn, FillStyle

If FillStyle Then
hRgn = 0
Do While hRgn Mod 2 = 0
hRgn = CreatePolygonRgn(tPoly(1), NumCoords, ALTERNATE)
DoEvents
Loop

Call FillRgn(hdc, hRgn, hBrush)
DoEvents
End If
End Sub

Private Sub Class_Initialize()
mArrowWidth = 5
mArrowHeight = 5
FillStyle = 1

TWIP_PER_PIXEL = Screen.TwipsPerPixelX
End Sub

Public Property Get X1() As Long
X1 = mX1 * TWIP_PER_PIXEL
End Property

Public Property Get X2() As Long
X2 = mX2 * TWIP_PER_PIXEL
End Property

Public Property Get Y1() As Long
Y1 = mY1 * TWIP_PER_PIXEL
End Property

Public Property Get Y2() As Long
Y2 = mY2 * TWIP_PER_PIXEL
End Property

Public Property Get Width() As Long
Width = mWidth * TWIP_PER_PIXEL
End Property

Public Property Get ArrowWidth() As Long
ArrowWidth = mArrowWidth * TWIP_PER_PIXEL
End Property

Public Property Get ArrowHeight() As Long
ArrowHeight = mArrowHeight * TWIP_PER_PIXEL
End Property

Public Property Let X1(newVal As Long)
mX1 = newVal / TWIP_PER_PIXEL
End Property

Public Property Let X2(newVal As Long)
mX2 = newVal / TWIP_PER_PIXEL
End Property

Public Property Let Y1(newVal As Long)
mY1 = newVal / TWIP_PER_PIXEL
End Property

Public Property Let Y2(newVal As Long)
mY2 = newVal / TWIP_PER_PIXEL
End Property

Public Property Let Width(newVal As Long)
mWidth = newVal / TWIP_PER_PIXEL
End Property

Public Property Let ArrowWidth(newVal As Long)
mArrowWidth = newVal / TWIP_PER_PIXEL
End Property

Public Property Let ArrowHeight(newVal As Long)
mArrowHeight = newVal / TWIP_PER_PIXEL
End Property

• 打赏
• 举报

回复 赞

[junglerover]

最后新建一个窗体FORM1，上面放上一个PICTUREBOX, 一个COMMANDBUTTON:

贴入以下代码：
Option Explicit

Private Sub Command1_Click()
Dim tArrow As CArrow
Set tArrow = New CArrow

tArrow.X1 = 150: tArrow.Y1 = 150
tArrow.X2 = 1500: tArrow.Y2 = 2400
tArrow.Width = 90
tArrow.ArrowWidth = 90: tArrow.ArrowHeight = 300
tArrow.Color = vbBlue

Call tArrow.DrawMe(Picture1.hdc, Picture1.hWnd)
Picture1.Refresh
End Sub

• 打赏
• 举报

回复 赞

[junglerover]

哈哈，我最近刚做了个箭头类，只要定义箭头的各个属性后，就可以直接在PICTUREBOX中直接画出箭头。不过我也做了一下午，可不能白给你。就简单提点你两句吧：

1。使用以下API：
Public Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As Any, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long

Public Declare Function FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long

以上两个API，第一个用于创建一个任意多边形区域，第二个用于填充该多边形区域。

2。方法提示：
箭头图形一共7个顶点。通过解析几何方法，算出所有顶点的坐标，创建多边形区域。然后填充该多边形，就画出箭头来了。

• 打赏
• 举报

回复 赞

[dongge2000]

楼上好自私啊，共享一下吧！

• 打赏
• 举报

回复 赞