frmtin.frm

构建Delaunay三角的源程序

VERSION 5.00
Begin VB.Form Form1 
   AutoRedraw      =   -1  'True
   Caption         =   "Form1"
   ClientHeight    =   9180
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   10740
   LinkTopic       =   "Form1"
   ScaleHeight     =   9180
   ScaleWidth      =   10740
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command1 
      Caption         =   "End"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   15.75
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   495
      Left            =   6600
      TabIndex        =   3
      Top             =   8520
      Width           =   1575
   End
   Begin VB.CommandButton cmdclear 
      Caption         =   "Clear"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   15.75
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   495
      Left            =   3960
      TabIndex        =   2
      Top             =   8520
      Width           =   1575
   End
   Begin VB.CommandButton cmdtin 
      Caption         =   "Tin"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   15.75
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   495
      Left            =   1560
      TabIndex        =   1
      Top             =   8520
      Width           =   1575
   End
   Begin VB.PictureBox pictin 
      AutoRedraw      =   -1  'True
      Height          =   8175
      Left            =   240
      MousePointer    =   2  'Cross
      ScaleHeight     =   8115
      ScaleWidth      =   10395
      TabIndex        =   0
      Top             =   240
      Width           =   10455
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Type NewType
   Posx As Single
   Posy As Single
End Type
Private Type UsedType
   uspoint1 As NewType
   uspoint2 As NewType
End Type
Dim HaveThird As Boolean  '用来标记是还存在第三点
Dim UsedPoint(32700) As UsedType   '用来存放标记过的基线
Dim UsedCount As Long
Dim nPoint(1000) As NewType  '用此数组来存放所有的点
Dim flag As Integer, nCount As Integer
'******************************************************************************
                    '从左边开始寻找第三点时对点进行判断是否在左边
'******************************************************************************

Private Function IsLeft(ByVal x0 As Single, ByVal y0 As Single, ByVal x1 As Single, y1 As Single, x2 As Single, y2 As Single) As Integer
Dim k As Single
Dim daty As Single, datx As Single, dat As Single
daty = y1 - y0
datx = x1 - x0
dat = (y2 - y1) * (x2 - x0) - (x2 - x1) * (y2 - y0)
If dat > 0 Then
    IsLeft = 1
  ElseIf dat = 0 Then
    IsLeft = 0
  Else
    IsLeft = -1
End If
End Function
'******************************************************************************
                    '求两点距离的函数
'****************************************************************************8
Private Function Distance(ByVal x1 As Single, ByVal y1 As Single, x2 As Single, y2 As Single) As Single
Dim S As Single
S = Sqr((x1 - x2) ^ 2 + (y1 - y2) ^ 2)
Distance = S
End Function
'******************************************************************************
                    '求第三点的函数
'****************************************************************************8
Private Function FindThirdPoint(ByVal x1 As Single, ByVal y1 As Single, ByVal x2 As Single, ByVal y2 As Single, ByRef HaveThird As Boolean) As NewType
Dim n As Integer
Dim a As Single, b As Single, c As Single
Dim Min As Single
Min = 10000000
Dim cosf As Single
Dim F As Integer
Dim third As Integer
HaveThird = False
For n = 1 To nCount
   If IsLeft(x1, y1, x2, y2, nPoint(n).Posx, nPoint(n).Posy) = 1 Then
      a = Distance(nPoint(n).Posx, nPoint(n).Posy, x1, y1)
      b = Distance(nPoint(n).Posx, nPoint(n).Posy, x2, y2)
      c = Distance(x1, y1, x2, y2)
      cosf = (a ^ 2 + b ^ 2 - c ^ 2) / (2 * (a * b))
      If Min > cosf Then
         Min = cosf
         third = n
      End If
      HaveThird = True
  End If
Next
FindThirdPoint = nPoint(third)
End Function
'******************************************************************************
                    '求TIN的函数
'****************************************************************************8
Private Sub TIN(ByVal x1 As Single, y1 As Single, x2 As Single, y2 As Single)
Dim First As NewType
Dim Second As NewType    '用first和second来表示基线点
Dim i As Integer
First.Posx = x1: First.Posy = y1
Second.Posx = x2: Second.Posy = y2
Dim Find As NewType
Dim Have As Boolean
Call FindThirdPoint(First.Posx, First.Posy, Second.Posx, Second.Posy, Have)
   If Have = True Then   'have为truey说明找到了第三点
        Find = FindThirdPoint(First.Posx, First.Posy, Second.Posx, Second.Posy, Have)
'        MsgBox First.Posx & "      " & First.Posy & " 第二点 " & Second.Posx & "    " & Second.Posy & "第三点" & Find.Posx & "      " & Find.Posy
 
   pictin.Line (First.Posx, First.Posy)-(Second.Posx, Second.Posy), vbBlue
   pictin.Line (First.Posx, First.Posy)-(Find.Posx, Find.Posy), vbBlue
   pictin.Line (Find.Posx, Find.Posy)-(Second.Posx, Second.Posy), vbBlue
   '分别把1-2和3-1and 1-3三条基线标记
   UsedCount = UsedCount + 1
   UsedPoint(UsedCount).uspoint1 = First
   UsedPoint(UsedCount).uspoint2 = Second
   UsedCount = UsedCount + 1
   UsedPoint(UsedCount).uspoint1 = Find
   UsedPoint(UsedCount).uspoint2 = First
   UsedCount = UsedCount + 1
   UsedPoint(UsedCount).uspoint1 = Second
   UsedPoint(UsedCount).uspoint2 = Find
   Dim m As Boolean
   Dim n As Boolean
   m = True
   n = True
For i = 1 To UsedCount    '判断1-2是否用过.用过的话里m为false
    If UsedPoint(i).uspoint1.Posx = First.Posx And UsedPoint(i).uspoint1.Posy = First.Posy And UsedPoint(i).uspoint2.Posx = Find.Posx And UsedPoint(i).uspoint2.Posy = Find.Posy Then
      m = False
    End If
Next
For i = 1 To UsedCount  '判断3-2是否用过.用过的话里n为false  注意其实还可以判断2-1用过没有这样也可以不用后面多调用递归
    If UsedPoint(i).uspoint1.Posx = Find.Posx And UsedPoint(i).uspoint1.Posy = Find.Posy And UsedPoint(i).uspoint2.Posx = Second.Posx And UsedPoint(i).uspoint2.Posy = Second.Posy Then
       n = False
    End If
Next
If m = True Then
  Call TIN(First.Posx, First.Posy, Find.Posx, Find.Posy)
End If
If n = True Then
  Call TIN(Find.Posx, Find.Posy, Second.Posx, Second.Posy)
End If
End If
End Sub
Private Sub cmdclear_Click()
pictin.Cls
flag = 0
nCount = 0
End Sub

Private Sub cmdtin_Click()
If nCount = 0 Then
   MsgBox "请先画点"
   Exit Sub
End If
If nCount = 1 Or nCount = 2 Then
  MsgBox "至少为三个点"
  Exit Sub
End If
If nCount > 1000 Then
   MsgBox "你所画的点太多,不好意思,＾○＾"
   Exit Sub
End If
Dim IsFlag(1000) As UsedType
'首先寻找重心点
Dim n As Integer
Dim Min1 As Single, i As Integer, j As Integer, Min2 As Single
Min1 = 10000000   '跟第一个最小数赋初值
Min2 = 10000000
i = -1
j = -1
Dim midpoint As NewType
For n = 1 To nCount
    midpoint.Posx = midpoint.Posx + nPoint(n).Posx
    midpoint.Posy = midpoint.Posy + nPoint(n).Posy
Next
    midpoint.Posx = midpoint.Posx / nCount
    midpoint.Posy = midpoint.Posy / nCount
'计算出每一点到中点的距离,距离最短的一条就是重心点]
For n = 1 To nCount
    If Min1 > Distance(midpoint.Posx, midpoint.Posy, nPoint(n).Posx, nPoint(n).Posy) Then
          Min1 = Distance(midpoint.Posx, midpoint.Posy, nPoint(n).Posx, nPoint(n).Posy)
          i = n
    End If
Next
For n = 1 To nCount
    If Min2 > Distance(nPoint(i).Posx, nPoint(i).Posy, nPoint(n).Posx, nPoint(n).Posy) And Distance(nPoint(i).Posx, nPoint(i).Posy, nPoint(n).Posx, nPoint(n).Posy) <> 0 Then
          Min2 = Distance(nPoint(i).Posx, nPoint(i).Posy, nPoint(n).Posx, nPoint(n).Posy)
          j = n
    End If
Next
If i > 0 And j > 0 Then
    pictin.FillColor = vbRed: pictin.FillStyle = 0: pictin.Circle (nPoint(i).Posx, nPoint(i).Posy), 5, vbBlue
    pictin.FillColor = vbGreen: pictin.FillStyle = 0: pictin.Circle (nPoint(j).Posx, nPoint(j).Posy), 5, vbBlue
    pictin.Line (nPoint(i).Posx, nPoint(i).Posy)-(nPoint(j).Posx, nPoint(j).Posy), vbRed
Else
   MsgBox "你的点数不够"
End If
pictin.FillColor = vbRed: pictin.FillStyle = 0: pictin.Circle (nPoint(i).Posx, nPoint(i).Posy), 5, vbBlue
pictin.FillColor = vbGreen: pictin.FillStyle = 0: pictin.Circle (nPoint(j).Posx, nPoint(j).Posy), 5, vbBlue
pictin.Line (nPoint(i).Posx, nPoint(i).Posy)-(nPoint(j).Posx, nPoint(j).Posy), vbRed
Call TIN(nPoint(i).Posx, nPoint(i).Posy, nPoint(j).Posx, nPoint(j).Posy)
Call TIN(nPoint(j).Posx, nPoint(j).Posy, nPoint(i).Posx, nPoint(i).Posy)
End Sub

Private Sub Command1_Click()
End
End Sub

Private Sub pictin_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
   nCount = nCount + 1
    nPoint(nCount).Posx = x
    nPoint(nCount).Posy = Y
    pictin.FillStyle = 1: pictin.Circle (nPoint(nCount).Posx, nPoint(nCount).Posy), 5, vbRed
'   MsgBox nCount
  End Sub

Private Sub Form_Load()
pictin.Scale (0, 1000)-(1000, 0)
End Sub