【VB开源代码栏目提醒】：网学会员--在 VB开源代码编辑为广大网友搜集整理了：三角网Delaunay算法VB源代码及用法2 - 技术总结绩等信息，祝愿广大网友取得需要的信息，参考学习。

    

±??????????lzwln??±??× Delaunay.bas ??????????ú???????????????? Attribute VB_Name Module1 Credit to Paul Bourke pbourkeswin.edu.au for the original Fortran 77 Program : Conversion by EluZioN EluZioNcasesladder.com You can use this code however you like providing the above credits remain in tact Option Explicit Points Vertices Public Type dVertex x As Long y As Long z As Long End Type Created Triangles vv are the vertex pointers Public Type dTriangle vv0 As Long vv1 As Long vv2 As Long End Type Set these as applicable Public Const MaxVertices 500 Public Const MaxTriangles 1000 Our points Public VertexMaxVertices As dVertex Our Created Triangles Public TriangleMaxTriangles As dTriangle Private Function InCirclexp As Long yp As Long x1 As Long y1 As Long x2 As Long y2 As Long x3 As Long y3 As Long ByRef xc ByRef yc ByRef r As Boolean Return TRUE if the point xpyp lies inside the circumcircle made up by points x1y1 x2y2 x3y3 The circumcircle centre is returned in xcyc and the radius r NOTE: A point on the edge is inside the circumcircle Dim eps As Double Dim m1 As Double Dim m2 As Double Dim mx1 As Double Dim mx2 As Double Dim my1 As Double Dim my2 As Double Dim dx As Double Dim dy As Double Dim rsqr As Double Dim drsqr As Double eps 0.000001 InCircle False If Absy1 - y2 eps And Absy2 - y3 eps Then MsgBox INCIRCUM - F - Points are coincident Exit Function End If If Absy2 - y1 eps Then m2 -x3 - x2 / y3 - y2 mx2 x2 x3 / 2 my2 y2 y3 / 2 xc x2 x1 / 2 yc m2 xc - mx2 my2 ElseIf Absy3 - y2 eps Then m1 -x2 - x1 / y2 - y1 mx1 x1 x2 / 2 my1 y1 y2 / 2 xc x3 x2 / 2 yc m1 xc - mx1 my1 Else m1 -x2 - x1 / y2 - y1 m2 -x3 - x2 / y3 - y2 mx1 x1 x2 / 2 mx2 x2 x3 / 2 my1 y1 y2 / 2 my2 y2 y3 / 2 xc m1 mx1 - m2 mx2 my2 - my1 / m1 - m2 yc m1 xc - mx1 my1 End If dx x2 - xc dy y2 - yc rsqr dx dx dy dy r Sqrrsqr dx xp - xc dy yp - yc drsqr dx dx dy dy If drsqr xmax Then xmax Vertexi.x If Vertexi.y ymin Then ymin Vertexi.y If Vertexi.y ymax Then ymax Vertexi.y Next i dx xmax - xmin dy ymax - ymin If dx dy Then dmax dx Else dmax dy End If xmid xmax xmin / 2 ymid ymax ymin / 2 Set up the supertriangle This is a triangle which encompasses all the sample points. The supertriangle coordinates are added to the end of the vertex list. The supertriangle is the first triangle in the triangle list. Vertexnvert 1.x xmid - 2 dmax Vertexnvert 1.y ymid - dmax Vertexnvert 2.x xmid Vertexnvert 2.y ymid 2 dmax Vertexnvert 3.x xmid 2 dmax Vertexnvert 3.y ymid - dmax Triangle1.vv0 nvert 1 Triangle1.vv1 nvert 2 Triangle1.vv2 nvert 3 Complete1 False ntri 1 Include each point one at a time into the existing mesh For i 1 To nvert Nedge 0 Set up the edge buffer. If the point Vertexi.xVertexi.y lies inside the circumcircle then the three edges of that triangle are added to the edge buffer. j 0 Do j j 1 If Completej True Then inc InCircleVertexi.x Vertexi.y VertexTrianglej.vv0.x VertexTrianglej.vv0.y VertexTrianglej.vv1.x VertexTrianglej.vv1.y VertexTrianglej.vv2.x VertexTrianglej.vv2.y xc yc r Include this if points are sorted by X If xc r Vertexi.x Then completej True Else If inc Then Edges1 Nedge 1 Trianglej.vv0 Edges2 Nedge 1 Trianglej.vv1 Edges1 Nedge 2 Trianglej.vv1 Edges2 Nedge 2 Trianglej.vv2 Edges1 Nedge 3 Trianglej.vv2 Edges2 Nedge 3 Trianglej.vv0 Nedge Nedge 3 Trianglej.vv0 Trianglentri.vv0 Trianglej.vv1 Trianglentri.vv1 Trianglej.vv2 Trianglentri.vv2 Completej Completentri j j - 1 ntri ntri - 1 End If End If End If Loop While j ntri Tag multiple edges Note: if all triangles are specified anticlockwise then all interior edges are opposite pointing in direction. For j 1 To Nedge - 1 If Not Edges1 j 0 And Not Edges2 j 0 Then For k j 1 To Nedge If Not Edges1 k 0 And Not Edges2 k 0 Then If Edges1 j Edges2 k Then If Edges2 j Edges1 k Then Edges1 j 0 Edges2 j 0 Edges1 k 0 Edges2 k 0 End If End If End If Next k End If Next j Form new triangles for the current point Skipping over any tagged edges. All edges are arranged in clockwise order. For j 1 To Nedge If Not Edges1 j 0 And Not Edges2 j 0 Then ntri ntri 1 Trianglentri.vv0 Edges1 j Trianglentri.vv1 Edges2 j Trianglentri.vv2 i Completentri False End If Next j Next i Remove triangles with supertriangle vertices These are triangles which have a vertex number greater than NVERT i 0 Do i i 1 If Trianglei.vv0 nvert Or Trianglei.vv1 nvert Or Trianglei.vv2 nvert Then Trianglei.vv0 Trianglentri.vv0 Trianglei.vv1 Trianglentri.vv1 Trianglei.vv2 Trianglentri.vv2 i i - 1 ntri ntri - 1 End If Loop While i ntri Triangulate ntri End Function delaunay.frm??????????????????ú???????? VERSION 5.00 Begin VB.Form Form1 Caption Triangulate ClientHeight 5685 ClientLeft 165 ClientTop 315 ClientWidth 7035 LinkTopic Form1 ScaleHeight 5685 ScaleWidth 7035 StartUpPosition 1 ??ù???????????????? Begin VB.PictureBox Picture1 AutoRedraw -1 True BackColor H00FFFFFF Height 7935 Left 120 ScaleHeight 7875 ScaleWidth 13155 TabIndex 0 Top 600 Width 13215 End Begin VB.Label Label1 Caption Click The Pic Box to add points Height 375 Left 4200 TabIndex 3 Top 120 Width 2655 End Begin VB.Label lblTris Height 375 Left 2040 TabIndex 2 Top 120 Width 1935 End Begin VB.Label lblPoints Height 375 Left 120 TabIndex 1 Top 120 Width 1455 End End Attribute VB_Name Form1 Attribute VB_GlobalNameSpace False Attribute VB_Creatable False Attribute VB_PredeclaredId True Attribute VB_Exposed False Dim tPoints As Integer Variable for total number of points vertices Private Sub Form_Load Initiate total points to 1 using base 0 causes problems in the functions tPoints 1 End Sub Private Sub Picture1_MouseDownButton As Integer Shift As Integer x As Single y As Single variable to hold how many triangles are created by the triangulate function Dim HowMany As Integer Set Vertex coordinates where you clicked the pic box VertextPoints.x x VertextPoints.y y Perform Triangulation Function if there are more than 2 points If tPoints 2 Then Clear the Picture Box Picture1.Cls Returns number of triangles created. HowMany TriangulatetPoints Else Draw a circle where you clicked so it does something Picture1.Circle VertextPoints.x VertextPoints.y 50 vbBlack End If Increment the total number of points tPoints tPoints 1 Display the total points and total triangles lblPoints.Caption Points: tPoints lblTris.Caption Triangles: HowMany Draw the created triangles For i 1 To HowMany Picture1.Line VertexTrianglei.vv0.x VertexTrianglei.vv0.y-VertexTrianglei.vv1.x VertexTrianglei.vv1.y Picture1.Line VertexTrianglei.vv1.x VertexTrianglei.vv1.y-VertexTrianglei.vv2.x VertexTrianglei.vv2.y Picture1.Line VertexTrianglei.vv0.x VertexTrianglei.vv0.y-VertexTrianglei.vv2.x VertexTrianglei.vv2.y Next i End Sub ±??TXT??????°????????±????±????????:http://www.mozhua.net/wenkubao