www.pudn.com > contour234.zip > Module1.bas, change:2004-11-24,size:15559b
Attribute VB_Name = "Module1"
Type dot
X As Double
Y As Double
Z As Integer
End Type
Type edge
dot1 As dot
dot2 As dot
sign As Boolean
End Type
Type CircleRROO
RR As Double
OO As dot
End Type
Type Sdot
DD As dot
JJ As Boolean
End Type
Type triangle
A As dot
B As dot
C As dot
End Type
Public STdot(1000) As dot
Public STedge(3000) As edge
Public STtriangle(2000) As triangle
Public i As Integer
Public MaxNdot As Integer
Public MaxNedge As Integer
Public NedgeNOuse As Integer
Public Ntriangle As Integer
Public Sub GetFirstEdge() '寻找第一条边，也即两条基线
Dim L1, L2 As Double
Dim Center As dot
Dim Mark1, Mark2 As Integer
Dim Dnear, Dnear2, Dcurrent, Dcurrent2 As Double
Dim biaMaxndot As edge
Dim Xmin, Xmax, Ymin, Ymax As Integer
Dim kj, kj2, kj3 As Integer
Dim Esp4 As Double
Esp4 = 0.0000001
'//////////////////////////////////找中间点，找近点的中心
Xmin = STdot(0).X
Xmax = STdot(0).X
Ymin = STdot(0).Y
Ymin = STdot(0).Y
For kj = 0 To MaxNdot
If STdot(kj).X Xmin Then
Xmin = STdot(kj).X
End If
If STdot(kj).X > Xmax Then
Xmax = STdot(kj).X
End If
If STdot(kj).Y Ymin Then
Ymin = STdot(kj).Y
End If
If STdot(kj).Y > Ymax Then
Ymax = STdot(kj).Y
End If
Next kj
Center.X = (Xmin + Xmax) / 2
Center.Y = (Ymin + Ymax) / 2
Form1.Pic1.DrawWidth = 5
Form1.Pic1.PSet (Center.X, Center.Y)
Form1.Pic1.DrawWidth = 1
' Form1.Pic1.Circle (Center.h, Center.v), 200
Dnear = (Center.X - STdot(0).X) ^ 2 + (Center.Y - STdot(0).Y) ^ 2 '假设第一个点到中心的距离最近
Mark1 = 0
For kj2 = 1 To MaxNdot
' L1 = (Abs(stdot(kj2).h - Center.h) + Abs(stdot(kj2).v - Center.v))
' If L1 > Esp4 Then
Dcurrent = (Center.X - STdot(kj2).X) ^ 2 + (Center.Y - STdot(kj2).Y) ^ 2
If Dcurrent Dnear Then
Mark1 = kj2
Dnear = Dcurrent
End If
' End If
Next kj2 'first yellow
'MsgBox (Mark1)
Form1.Pic1.Circle (STdot(Mark1).X, STdot(Mark1).Y), 200, RGB(255, 0, 0)
'////////////////////////////////////////////////////////////////////////////////////
'找第二个点
'////////////////////////////////////////////////////////////////////////////////////
'////////////////////////////////////////////////////////////////////////////////////
Dnear2 = (STdot(Mark1).X - STdot(0).X) ^ 2 + (STdot(Mark1).Y - STdot(0).Y) ^ 2 '如果第一个点是距离中心最近的点
Mark2 = 0
If Abs(Dnear2) Esp4 Then '设离第一点最近的点是第二个点
Dnear2 = (STdot(Mark1).X - STdot(1).X) ^ 2 + (STdot(Mark1).Y - STdot(1).Y) ^ 2
Mark2 = 1
End If
For kj3 = 0 To MaxNdot
L2 = (Abs(STdot(kj3).X - STdot(Mark1).X) + Abs(STdot(kj3).Y - STdot(Mark1).Y)) '保证取点不是MARK1同一点
If L2 > Esp4 Then
Dcurrent2 = (STdot(Mark1).X - STdot(kj3).X) ^ 2 + (STdot(Mark1).Y - STdot(kj3).Y) ^ 2
If Dcurrent2 Dnear2 Then
Mark2 = kj3
Dnear2 = Dcurrent2
End If
End If
Next kj3
'MsgBox (Mark2)
Form1.Pic1.Circle (STdot(Mark2).X, STdot(Mark2).Y), 200, RGB(0, 0, 255)
' Form1.Pic1.Line (stdot(Mark1).h, stdot(Mark1).v)-(stdot(Mark2).h, stdot(Mark2).v)
'////////////////////////////////////////////////////////////////////////////////////
Form1.Text1.Text = Mark1
Form1.Text2.Text = Mark2
STedge(0).dot1 = STdot(Mark1)
STedge(0).dot2 = STdot(Mark2)
STedge(0).sign = False
STedge(1).dot1 = STdot(Mark2)
STedge(1).dot2 = STdot(Mark1)
STedge(1).sign = False
End Sub
Public Function OnLeft(A1 As dot, B1 As dot, C1 As dot) As Boolean '判断有无点在线段左边
Dim km As Double
Dim bm As Double
Dim Esp1 As Double
Esp1 = 0.0000001
OnLeft = FA1lse
If A1.X <> B1.X Then '构造直线
km = (B1.Y - A1.Y) / (B1.X - A1.X)
bm = ((A1.Y - km * A1.X) + (B1.Y - km * B1.X)) / 2
If B1.X > A1.X Then
If C1.Y - (km * C1.X + bm) > Esp1 Then
OnLeft = True
End If
ElseIf B1.X A1.X Then
If (km * C1.X + bm) - C1.Y > Esp1 Then
OnLeft = True
End If
Else
End If
ElseIf A1.X = B1.X Then
If B1.Y > A1.Y Then
If A1.X - C1.X > Esp1 Then
OnLeft = True
End If
ElseIf B1.Y A1.Y Then
If C1.X - A1.X > Esp1 Then
OnLeft = True
End If
Else
End If
Else
End If
End Function
Public Function CreateCircle(A As dot, B As dot, C As dot) As CircleRROO ' 获得外接圆的半径，圆心
Dim Km1 As Double
Dim Km2 As Double
Dim Bm1 As Double
Dim Bm2 As Double
Dim Mid1 As dot
Dim Mid2 As dot
Dim YX As dot
Dim BJ As Double
' MsgBox "CreateCircle"
Mid1.X = (A.X + B.X) / 2
Mid1.Y = (A.Y + B.Y) / 2
Mid2.X = (A.X + C.X) / 2
Mid2.Y = (A.Y + C.Y) / 2
If A.Y = B.Y Then
'MsgBox "CreateCircle:A.Y = B.Y"
YX.X = Mid1.X
Km2 = -(C.X - A.X) / (C.Y - A.Y)
Bm2 = Mid2.Y - Km2 * Mid2.X
YX.Y = Km2 * YX.X + Bm2
End If
If A.Y = C.Y Then
' MsgBox "CreateCircle:A.Y = C.Y"
YX.X = Mid2.X
YX.Y = Mid2.Y
Km1 = -(B.X - A.X) / (B.Y - A.Y)
Bm1 = Mid1.Y - Km1 * Mid1.X
YX.Y = Km1 * YX.X + Bm1
End If
If A.Y <> B.Y And A.Y <> C.Y Then
'MsgBox "CreateCircle:A.Y <> B.Y AND A.Y <> C.Y "
Km1 = -(B.X - A.X) / (B.Y - A.Y)
Bm1 = Mid1.Y - Km1 * Mid1.X
Km2 = -(C.X - A.X) / (C.Y - A.Y)
Bm2 = Mid2.Y - Km2 * Mid2.X
YX.X = -(Bm2 - Bm1) / (Km2 - Km1)
YX.Y = ((Km1 * YX.X + Bm1) + (Km2 * YX.X + Bm2)) / 2
End If
BJ = Sqr((A.X - YX.X) ^ 2 + (A.Y - YX.Y) ^ 2)
CreateCircle.OO = YX
CreateCircle.RR = BJ
End Function
Public Function NullCircle(O As dot, R As Double) As Boolean '判断是否是空圆
Dim Esp2 As Double
Dim L As Double
' MsgBox "NullCircle"
Esp2 = 0.0000001
NullCircle = True
For i = 0 To MaxNdot
L = Sqr((STdot(i).X - O.X) ^ 2 + (STdot(i).Y - O.Y) ^ 2)
If R - L > Esp2 Then
NullCircle = False
Exit Function
End If
Next i
End Function
Public Function GetThirdDot(F As dot, S As dot) As Sdot '寻找合适的第三点，找到返回该点，找不到，返回false
Dim j1 As Integer
Dim YX As dot
Dim BJ As Double
Dim DSD As dot
GetThirdDot.JJ = False
' MsgBox "GetThirdDot"
For j1 = 0 To MaxNdot
If OnLeft(F, S, STdot(j1)) = True Then
YX = CreateCircle(F, S, STdot(j1)).OO
BJ = CreateCircle(F, S, STdot(j1)).RR
If NullCircle(YX, BJ) = True Then
GetThirdDot.JJ = True
GetThirdDot.DD = STdot(j1)
MsgBox (j1)
'储存边，记录三角形
Exit Function
End If
End If
Next j1
'存储边
End Function
Public Sub Deal2Dot(A2 As dot, B2 As dot) '找不到合适第三点时，处理该边
Dim j2 As Integer
Dim Lx, Ly, Rx, Ry As Double
Dim Nunber1 As Double
Dim Esp3 As Double
Esp3 = 0.0000001
For j2 = 0 To MaxNedge
Lx = STedge(j2).dot1.X: Ly = STedge(j2).dot1.Y
Rx = STedge(j2).dot2.X: Ry = STedge(j2).dot2.Y
Nunber1 = Abs(Lx - A2.X) + Abs(Ly - A2.Y) + Abs(Ry - B2.Y) + Abs(Ry - B2.Y)
If Nunber1 Esp3 Then '找到原来位置，修改原来的基线,修改可用边数
'If STedge(j2).sign = False Then
STedge(j2).sign = True
NedgeNOuse = NedgeNOuse - 1
Form1.Pic1.Line (A2.X, A2.Y)-(B2.X, B2.Y), RGB(255, 0, 0)
'Else
' MaxNedge = MaxNedge + 1
' STedge(MaxNedge).dot1 = A2
' STedge(MaxNedge).dot2 = B2
' STedge(MaxNedge).sign = True
End If
Next j2
End Sub
Public Sub Deal3Dot(A3 As dot, B3 As dot, C3 As dot) '修改可用边数，存储边，存储三角形
Dim j31, j32, j33, j34, j35, j36 As Integer
Dim WAB, WBC, WCA, WBA, WCB, WAC As Double
Dim LnowX, LnowY, RnowX, RnowY As Double
Dim Esp5 As Double
Esp5 = 0.0000001
STedge(MaxNedge + 1).dot1 = A3: STedge(MaxNedge + 1).dot2 = B3: STedge(MaxNedge + 1).sign = True
STedge(MaxNedge + 2).dot1 = B3: STedge(MaxNedge + 2).dot2 = C3: STedge(MaxNedge + 2).sign = True
STedge(MaxNedge + 3).dot1 = C3: STedge(MaxNedge + 3).dot2 = A3: STedge(MaxNedge + 3).sign = True
STedge(MaxNedge + 4).dot1 = B3: STedge(MaxNedge + 4).dot2 = A3: STedge(MaxNedge + 4).sign = False
STedge(MaxNedge + 5).dot1 = C3: STedge(MaxNedge + 5).dot2 = B3: STedge(MaxNedge + 5).sign = False
STedge(MaxNedge + 6).dot1 = A3: STedge(MaxNedge + 6).dot2 = C3: STedge(MaxNedge + 6).sign = False
NedgeNOuse = NedgeNOuse + 3
For j31 = 0 To MaxNedge
LnowX = STedge(j31).dot1.X: LnowY = STedge(j31).dot1.Y
RnowX = STedge(j31).dot2.X: RnowY = STedge(j31).dot2.Y
WAB = Abs(LnowX - A3.X) + Abs(LnowY - A3.Y) + Abs(RnowX - B3.X) + Abs(RnowY - B3.Y)
If WAB Esp5 Then '找到原来位置，修改原来的基线,修改可用边数
If STedge(j31).sign = False Then
STedge(j31).sign = True
' MsgBox "change NedgeNOuse"
NedgeNOuse = NedgeNOuse - 1
' Form1.Text5.Text = NedgeNOuse
' MsgBox "change"
End If
End If
Next j31
For j32 = 0 To MaxNedge
LnowX = STedge(j32).dot1.X: LnowY = STedge(j32).dot1.Y
RnowX = STedge(j32).dot2.X: RnowY = STedge(j32).dot2.Y
WBC = Abs(LnowX - B3.X) + Abs(LnowY - B3.Y) + Abs(RnowX - C3.X) + Abs(RnowY - C3.Y)
If WBC Esp5 Then '找到原来位置，修改原来的基线,修改可用边数
If STedge(j32).sign = False Then
STedge(j32).sign = True
NedgeNOuse = NedgeNOuse - 1
End If
End If
Next j32
For j33 = 0 To MaxNedge
LnowX = STedge(j33).dot1.X: LnowY = STedge(j33).dot1.Y
RnowX = STedge(j33).dot2.X: RnowY = STedge(j33).dot2.Y
WCA = Abs(LnowX - C3.X) + Abs(LnowY - C3.Y) + Abs(RnowX - A3.X) + Abs(RnowY - A3.Y)
If WCA Esp5 Then '找到原来位置，修改原来的基线,修改可用边数
' MsgBox "3-1"
If STedge(j33).sign = False Then
STedge(j33).sign = True
NedgeNOuse = NedgeNOuse - 1
End If
End If
Next j33
For j34 = 0 To MaxNedge
LnowX = STedge(j34).dot1.X: LnowY = STedge(j34).dot1.Y
RnowX = STedge(j34).dot2.X: RnowY = STedge(j34).dot2.Y
WBA = Abs(LnowX - B3.X) + Abs(LnowY - B3.Y) + Abs(RnowX - A3.X) + Abs(RnowY - A3.Y)
If WBA Esp5 Then '找到原来位置，修改原来的基线,修改可用边数
If STedge(j34).sign = True Then
STedge(MaxNedge + 4).sign = True
NedgeNOuse = NedgeNOuse - 1
End If
End If
Next j34
For j35 = 0 To MaxNedge
LnowX = STedge(j35).dot1.X: LnowY = STedge(j35).dot1.Y
RnowX = STedge(j35).dot2.X: RnowY = STedge(j35).dot2.Y
WCB = Abs(LnowX - C3.X) + Abs(LnowY - C3.Y) + Abs(RnowX - B3.X) + Abs(RnowY - B3.Y)
If WCB Esp5 Then '找到原来位置，修改原来的基线,修改可用边数
If STedge(j35).sign = True Then
' MsgBox " 第5条基线原来用过，现在未用了，修改 "
STedge(MaxNedge + 5).sign = True
NedgeNOuse = NedgeNOuse - 1
' Form1.Text5.Text = NedgeNOuse
End If
End If
Next j35
For j36 = 0 To MaxNedge
LnowX = STedge(j36).dot1.X: LnowY = STedge(j36).dot1.Y
RnowX = STedge(j36).dot2.X: RnowY = STedge(j36).dot2.Y
WAC = Abs(LnowX - A3.X) + Abs(LnowY - A3.Y) + Abs(RnowX - C3.X) + Abs(RnowY - C3.Y)
If WAC Esp5 Then '找到原来位置，修改原来的基线,修改可用边数
' MsgBox "1-3"
If STedge(j36).sign = True Then
' MsgBox " 第6条基线原来用过，现在未用了，修改 "
STedge(MaxNedge + 6).sign = True
NedgeNOuse = NedgeNOuse - 1
' MsgBox "change"
End If
End If
Next j36
MaxNedge = MaxNedge + 6
End Sub
Public Sub DrawTriangle(D1 As dot, D2 As dot, D3 As dot) ' 画线
Form1.Pic1.Line (D1.X, D1.Y)-(D2.X, D2.Y), RGB(0, 100, 255)
Form1.Pic1.Line (D2.X, D2.Y)-(D3.X, D3.Y), RGB(0, 100, 255)
Form1.Pic1.Line (D3.X, D3.Y)-(D1.X, D1.Y), RGB(0, 100, 255)
End Sub
Public Sub Delaunay(F2 As dot, S2 As dot)
Dim T2 As dot
Dim jm As Integer
Dim Esp6 As Double
Dim wx As Double
Esp6 = 0.0000001
For jm = 0 To MaxNedge
wx = Abs(F2.X - STedge(jm).dot1.X) + Abs(F2.Y - STedge(jm).dot1.Y) + Abs(S2.X - STedge(jm).dot2.X) + Abs(S2.Y - STedge(jm).dot2.Y)
If wx Esp6 Then
If STedge(jm).sign = True Then
Exit Sub
End If
End If
Next jm
If GetThirdDot(F2, S2).JJ = True Then
T2 = GetThirdDot(F2, S2).DD
Call DrawTriangle(F2, S2, T2)
Call Deal3Dot(F2, S2, T2)
'Ntriangle = Ntriangle + 1
'Form1.TexNtri.Text = Ntriangle
Call StoreTriangle(F2, S2, T2)
Else
Call Deal2Dot(F2, S2)
Exit Sub
End If
Call Delaunay(F2, T2)
Call Delaunay(T2, S2)
Call Delaunay(S2, F2)
End Sub
Public Sub StoreTriangle(F3 As dot, S3 As dot, T3 As dot)
Ntriangle = Ntriangle + 1
STtriangle(Ntriangle).A = F3
STtriangle(Ntriangle).B = S3
STtriangle(Ntriangle).C = T3
End Sub
Public Sub DrawContour(Tri As triangle, Ho As Integer)
Dim A4 As dot
Dim B4 As dot
Dim C4 As dot
Dim Node1 As dot
Dim Node2 As dot
Dim HA4, HB4, HC4 As Double
Dim Esp6 As Double
Esp6 = 0.0000001
Node1.Z = Ho
Node2.Z = Ho
A4 = Tri.A: B4 = Tri.B: C4 = Tri.C
HA4 = Tri.A.Z: HB4 = Tri.B.Z: HC4 = Tri.C.Z
If HA4 - Ho > Esp6 And HB4 - Ho > Esp6 And HC4 - Ho > Esp6 Then
Exit Sub
End If
If Ho - HA4 > Esp6 And Ho - HB4 > Esp6 And Ho - HC4 > Esp6 Then
Exit Sub
End If
If (Abs(HA4 - HB4) * Abs(HB4 - HC4) * Abs(HC4 - HA4)) > Esp6 Then
If (HA4 - Ho) * (HB4 - Ho) > 0 Then
Node1.X = C4.X - ((C4.X - B4.X) * (HC4 - Ho) / (HC4 - HB4))
Node1.Y = C4.Y - ((C4.Y - B4.Y) * (HC4 - Ho) / (HC4 - HB4))
Node2.X = C4.X - ((C4.X - A4.X) * (HC4 - Ho) / (HC4 - HA4))
Node2.Y = C4.Y - ((C4.Y - A4.Y) * (HC4 - Ho) / (HC4 - HA4))
ElseIf (HB4 - Ho) * (HC4 - Ho) > 0 Then
Node1.X = A4.X - ((A4.X - C4.X) * (HA4 - Ho) / (HA4 - HC4))
Node1.Y = A4.Y - ((A4.Y - C4.Y) * (HA4 - Ho) / (HA4 - HC4))
Node2.X = A4.X - ((A4.X - B4.X) * (HA4 - Ho) / (HA4 - HB4))
Node2.Y = A4.Y - ((A4.Y - B4.Y) * (HA4 - Ho) / (HA4 - HB4))
ElseIf (HB4 - Ho) * (HA4 - Ho) > 0 Then
Node1.X = B4.X - ((B4.X - A4.X) * (HB4 - Ho) / (HB4 - HA4))
Node1.Y = B4.Y - ((B4.Y - A4.Y) * (HB4 - Ho) / (HB4 - HA4))
Node2.X = B4.X - ((B4.X - C4.X) * (HB4 - Ho) / (HB4 - HC4))
Node2.Y = B4.Y - ((B4.Y - C4.Y) * (HB4 - Ho) / (HB4 - HC4))
Else
End If
Form1.Pic1.Line (Node1.X, Node1.Y)-(Node2.X, Node2.Y)
End If
End Sub