判断点是否在多边形内部的演示程序
判断点是否在多边形内部的演示程序 点“开始”按钮后，鼠标在矩形框内区域点击就自动连成折线，最后一个点用右击，形成封闭的多边形。然后程序自动开始在区域内逐点涂色：在多边形外的涂蓝色，内部的不涂色。由于是每个点都要计算是否在内部，因此涂色过程较慢，中途可按“返回”键中断。
包含的文件有：
模块Graphic.bas:
Attribute VB_Name = 'GraphMod'
Option Base 0
Option Explicit
Type Point
X As Double
Y As Double
End Type
Public Sub GetStdLine(ps As Point, pe As Point, ByRef a As Double, ByRef b As Double, ByRef c As Double)
'根据两个点的坐标求经过两点的直线的标准方程参数A、B、C
Dim xs As Double, ys As Double, xe As Double, ye As Double
xs = ps.X: ys = ps.Y: xe = pe.X: ye = pe.Y
Dim p1 As Double, p2 As Double
p1 = xs * ye: p2 = xe * ys
If (p1 = p2) Then
If (xs = 0) Then
If (xe = 0) Then
a = 1: b = 0: c = 0
ElseIf (ys = 0) Then
a = ye: b = -xe: c = 0
End If
ElseIf (ye = 0) Then
If (ys = 0) Then
a = 0: b = 1: c = 0
ElseIf (xe = 0) Then
a = -ys: b = xs: c = 0
End If
End If
Else
a = (ys - ye) / (p1 - p2): c = 1
If (ys = 0) Then
If (ye = 0) Then
b = 1: c = 0
Else
b = -(a * xe + 1) / ye
End If
Else
b = -(a * xs + 1) / ys
End If
End If
End Sub
Public Function InPoly(poly() As Point, p As Point) As Boolean
'判断点是否在多边形内部
Dim i As Integer, f As Integer, xi As Double
Dim a As Double, b As Double, c As Double
Dim ps As Point, pe As Point
For i = 0 To UBound(poly)
ps = poly(i)
If (i < UBound(poly)) Then pe = poly(i + 1) Else pe = poly(0)
GetStdLine ps, pe, a, b, c
If (a <> 0) Then
xi = -(b * p.Y + c) / a
If (xi = p.X) Then
InPoly = True
ElseIf (xi < p.X) Then
f = f + Sgn(pe.Y - p.Y) - Sgn(ps.Y - p.Y)
End If
End If
Next i
InPoly = (f <> 0)
End Function
窗体frmDemo.frm:
VERSION 5.00
Begin VB.Form frmDemo
Caption = 'GraphicDemo'
ClientHeight = 3090
ClientLeft = 60
ClientTop = 450
ClientWidth = 4680
LinkTopic = 'Form1'
LockControls = -1 'True
ScaleHeight = 3090
ScaleWidth = 4680
StartUpPosition = 3 '窗口缺省
Begin VB.CommandButton cmdReturn
Caption = '返回'
Height = 375
Left = 1560
TabIndex = 1
Top = 2640
Visible = 0 'False
Width = 1455
End
Begin VB.CommandButton cmdStart
Caption = '开始'
Height = 375
Left = 1560
TabIndex = 0
Top = 1800
Width = 1455
End
Begin VB.Shape Shape1
Height = 2415
Left = 120
Top = 120
Width = 4455
End
End
Attribute VB_Name = 'frmDemo'
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim poly() As Point, x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer
Private Sub cmdStart_Click()
cmdStart.Visible = False
cmdReturn.Visible = True
ReDim poly(0) As Point
frmDemo.Tag = 'Begin'
End Sub
Private Sub cmdReturn_Click()
cmdStart.Visible = True
cmdReturn.Visible = False
frmDemo.Tag = ''
Line (x1, y1)-(x2, y2), vbButtonFace, BF
End Sub
Private Sub Form_Initialize()
With Shape1
x1 = .Left + 12
y1 = .Top + 12
x2 = .Left + .Width - 24
y2 = .Top + .Height - 24
End With
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If cmdStart.Visible Then Exit Sub
If (frmDemo.Tag = 'Begin' And X > x1 And X < x2 And Y > y1 And Y < y2) Then
DrawWidth = 2
PSet (X, Y), vbBlue
Dim b As Integer: b = UBound(poly)
poly(b).X = X: poly(b).Y = Y
If (b > 0) Then Line (poly(b - 1).X, poly(b - 1).Y)-(X, Y), vbBlue
If (Button = 2) Then
Line (poly(b).X, poly(b).Y)-(poly(0).X, poly(0).Y), vbBlue
frmDemo.Tag = 'Busy'
Dim i As Integer, j As Integer, p As Point
DrawWidth = 1
For i = x1 To x2
For j = y1 To y2
DoEvents
If (frmDemo.Tag <> 'Busy') Then Exit For
p.X = i: p.Y = j
If (Not InPoly(poly, p)) Then PSet (i, j), vbWhite
Next j
If (frmDemo.Tag <> 'Busy') Then Exit For
Next i
Else
ReDim Preserve poly(0 To b + 1) As Point
End If
End If
End Sub
