frmgrid.frm

这是一个很不错的地理信息系统所用到的三角化程序,是VB写的.也是参照别人的,大家欣赏,经过测试没有错误的!

    bEQBD = False
    For J = Ni To nBD
        If (bBD(J) = True) Then
            bEQBD = True
            Exit For
        End If
    Next J
    If (bEQBD = False) Then
        For J = 1 To Ni - 1
            If (bBD(J) = True) Then
                bEQBD = True
                Exit For
            End If
        Next J
    End If
    Ni = J
    If (bEQBD = False) Then Exit Do
    
    '第Ni边的终点节点
    If (Ni = nBD) Then
        Nj = 1
    Else
        Nj = Ni + 1
    End If
    '第Ni边的后邻
    If (Ni = 1) Then
        Nlast = nBD
    Else
        Nlast = Ni - 1
    End If
    '第Ni边的前邻
    If (Nj = nBD) Then
        Nnext = 1
    Else
        Nnext = Nj + 1
    End If
        
    '第Ni边的三个顶点
    Pi = BD(Ni)
    Pj = BD(Nj)
    Pk = BDij(Ni)
    
    'Begin找下一点
    bCheck = False
    If (Xcontou(Pj) = Xcontou(Pi)) Then
        C1 = Xcontou(Pk) - Xcontou(Pi)
    Else
        A1 = (Ycontou(Pj) - Ycontou(Pi)) / (Xcontou(Pj) - Xcontou(Pi))
        B1 = Ycontou(Pj) - A1 * Xcontou(Pj)
        C1 = Ycontou(Pk) - Xcontou(Pk) * A1 - B1
    End If
    If (C1 <= 0#) Then
        M1 = -1
    Else
        M1 = 1
    End If
    
    Tt = 0#
    For K = 1 To NContou
        If (K = Pi Or K = Pj Or bPoint(K) = 2) Then
        Else
            If (Xcontou(Pj) = Xcontou(Pi)) Then
                C1 = Xcontou(K) - Xcontou(Pi)
            Else
                C1 = Ycontou(K) - Xcontou(K) * A1 - B1
            End If
            If (C1 <= 0#) Then
                M2 = -1
            Else
                M2 = 1
            End If
            If (M1 <> M2) Then
                AA = (Xcontou(Pj) - Xcontou(K)) ^ 2 + (Ycontou(Pj) - Ycontou(K)) ^ 2
                
                BB = (Xcontou(Pi) - Xcontou(K)) ^ 2 + (Ycontou(Pi) - Ycontou(K)) ^ 2
                CC = (Xcontou(Pi) - Xcontou(Pj)) ^ 2 + (Ycontou(Pi) - Ycontou(Pj)) ^ 2
                CosC = 1# - (AA + BB - CC) / (2# * Sqr(AA * BB))
                If (CosC > Tt + 0.00001) Then
                    Tt = CosC
                    Pk = K
                    bCheck = True
                End If
            End If
        End If
    Next K
    'End找下一点
    If (bCheck = True) Then '找到下一点
        bSJX = True
        '找前邻、后邻
        If (Pk = BD(Nlast)) Then '后邻,删除Pi点
            '修改后邻点参数
            BDij(Nlast) = Pi
            bBD(Nlast) = True
            bPoint(Pk) = 1
            
            For J = Ni + 1 To nBD
                BD(J - 1) = BD(J)
                BDij(J - 1) = BDij(J)
                bBD(J - 1) = bBD(J)
            Next J
            
            nBD = nBD - 1       '减少一个边
            bPoint(Pi) = 2      'Pi点位于圈内
        ElseIf (Pk = BD(Nnext)) Then '前邻,删除Pj点
            '修改Ni点参数
            BDij(Ni) = Pj
            bBD(Ni) = True
            bPoint(Pk) = 1
            
            For J = Nj + 1 To nBD
                BD(J - 1) = BD(J)
                BDij(J - 1) = BDij(J)
                bBD(J - 1) = bBD(J)
            Next J
            
            nBD = nBD - 1       '减少一个边
            bPoint(Pj) = 2      'Pj点位于圈内
        ElseIf (bPoint(Pk) < 1) Then '下一点不在边界环上,插入Pk点
            '修改Ni点参数
            BDij(Ni) = Pj
            bBD(Ni) = True
            bPoint(Pk) = 1
            
            '数据后推
            For J = nBD To Ni + 1 Step -1
                BD(J + 1) = BD(J)
                BDij(J + 1) = BDij(J)
                bBD(J + 1) = bBD(J)
            Next J
            nBD = nBD + 1
            
            'Pk点参数
            BD(Ni + 1) = Pk
            BDij(Ni + 1) = Pi
            bBD(Ni + 1) = True
            Ni = Ni + 1
        Else
            bSJX = False
        End If
        If (bSJX = True) Then
            '生成新三角形
            nSJX = nSJX + 1
            ID1(nSJX) = Pi
            ID2(nSJX) = Pj
            ID3(nSJX) = Pk
            
            X1 = Xcontou(Pi)
            X2 = Xcontou(Pj)
            X3 = Xcontou(Pk)
    
            Y1 = Ycontou(Pi)
            Y2 = Ycontou(Pj)
            Y3 = Ycontou(Pk)
            
            PictureGrid.Line (X1, Y1)-(X2, Y2)
            PictureGrid.Line (X2, Y2)-(X3, Y3)
            PictureGrid.Line (X3, Y3)-(X1, Y1)
            DoEvents
        End If
    Else '没找到下一点,该边界不再搜索
        bBD(Ni) = False
    End If
Loop

'整理边界
nBorder = nBD - 1
ReDim BorderX(0 To nBorder + 1), BorderY(0 To nBorder + 1)
For J = 0 To nBorder
    BorderX(J) = Xcontou(BD(J + 1))
    BorderY(J) = Ycontou(BD(J + 1))
Next J
BorderX(nBorder + 1) = BorderX(0)
BorderY(nBorder + 1) = BorderY(0)
End Sub




Private Sub CommandContouMeshWang_Click()
    Dim FalseTrue As Boolean
    
    On Error Resume Next

    CommonDialog1.DialogTitle = "等值线数据文件"
    CommonDialog1.FileName = TheContouFile
    CommonDialog1.Filter = "*.Txt;*.Dat|*.TXT;*.DAT"
    CommonDialog1.InitDir = TheContouPath
    CommonDialog1.FilterIndex = 0
    CommonDialog1.ShowOpen
    If (Err = 0) Then '打开文件
        TheContouFile = CommonDialog1.DialogTitle
        TheContouPath = CommonDialog1.FileName
        Call ReadContouFile
        
        If (DataType = 0) Then
            FalseTrue = False
            MsgBox "已经是网格化数据，无需网格化！", vbOKOnly, "关于网格化"
        Else
            FalseTrue = True
            DX = Sqr((Xmax - Xmin) / (NContou + 1) * (Ymax - Ymin))
            DY = DX

            NX = Fix((Xmax - Xmin) / DX) + 1
            NY = Fix((Ymax - Ymin) / DY) + 1
            DX = (Xmax - Xmin) / (NX - 1)
            DY = (Ymax - Ymin) / (NY - 1)
        
            DX = Val(Format(DX, FMT))
            DY = Val(Format(DY, FMT))
            NX = Fix((Xmax - Xmin) / DX) + 1
            NY = Fix((Ymax - Ymin) / DY) + 1
            
            If ((NX - 1) * DX < Xmax - Xmin) Then NX = NX + 1
            If ((NY - 1) * DY < Ymax - Ymin) Then NY = NY + 1
        End If
        LabelXmin.Enabled = FalseTrue
        TextXmin.Enabled = FalseTrue
        LabelXmax.Enabled = FalseTrue
        TextXmax.Enabled = FalseTrue
        LabelXStep.Enabled = FalseTrue
        TextXStep.Enabled = FalseTrue
        LabelXNX.Enabled = FalseTrue
        TextXNX.Enabled = FalseTrue

        LabelYmin.Enabled = FalseTrue
        TextYmin.Enabled = FalseTrue
        LabelYmax.Enabled = FalseTrue
        TextYmax.Enabled = FalseTrue
        LabelYStep.Enabled = FalseTrue
        TextYStep.Enabled = FalseTrue
        LabelYNY.Enabled = FalseTrue
        TextYNY.Enabled = FalseTrue

        PictureGrid.Enabled = FalseTrue
        CommandGridOK.Enabled = FalseTrue
    
        TextXmin.Text = Xmin
        TextXmax.Text = Xmax
        TextYmin.Text = Ymin
        TextYmax.Text = Ymax
        TextXStep.Text = DX
        TextYStep.Text = DY

        TextXNX.Text = NX
        TextYNY.Text = NY

        Call DrawOld
    End If
End Sub
'读绘等值线的数据
Private Sub ReadContouFile()
Dim IX As Integer, IY As Integer, II As Integer
Dim I As Integer, J As Integer, K As Integer
Dim I1 As Integer, L As Integer, Temp As String, DSAA_DSBB As String * 4, ValueTemp As Single
Dim N0 As Long, N As Long
Dim Xt As Double, Yt As Double
Dim Lat As Double, Lon As Double, Rou As Double
Dim VminTMP As Double, VmaxTMP As Double
Dim iModeOld As Integer, StrMax As String
Dim bSpace As Boolean
Dim lNX As Long, lNY As Long, DouValueTemp As Double, xStep As Double, yStep As Double, VminT As Double, VmaxT As Double


Open TheContouPath For Binary Access Read Lock Read As #1
Get #1, 1, DSAA_DSBB
Close (1)
If (DSAA_DSBB = "DSAA") Then
    Open TheContouPath For Input As #1
    Line Input #1, Temp
    Input #1, NX, NY
    Input #1, Xmin, Xmax
    Input #1, Ymin, Ymax
    Input #1, Vmin, Vmax
    For IX = 1 To NX
        Input #1, ValueTemp
    Next IX
    Line Input #1, Temp
    Close (1)
    If (Len(Trim(Temp)) < 1) Then
        bSpace = True
    Else
        bSpace = False
    End If
    Close (1)

    DataType = 0
    Open TheContouPath For Input As #1
    Line Input #1, Temp
    Input #1, NX, NY
    Input #1, Xmin, Xmax
    Input #1, Ymin, Ymax
    Input #1, Vmin, Vmax
    ReDim Zgrid(1 To NX, 1 To NY), bZgrid(1 To NX, 1 To NY)
    N0 = NX * NY
    ReDim Xcontou(0 To N0), Ycontou(0 To N0), Zcontou(0 To N0)
    
    NContou = -1
    DX = (Xmax - Xmin) / (NX - 1)
    DY = (Ymax - Ymin) / (NY - 1)
    Yt = Ymin - DY
    If (bSpace = False) Then
        For IY = 1 To NY
            Yt = Yt + DY
            Xt = Xmin - DX
            For IX = 1 To NX
                Xt = Xt + DX
                NContou = NContou + 1
                Input #1, Zcontou(NContou)
                Xcontou(NContou) = Xt
                Ycontou(NContou) = Yt
                Zgrid(IX, IY) = Zcontou(NContou)
            Next IX
        Next IY
    Else
        For IY = 1 To NY
            Yt = Yt + DY
            Xt = Xmin - DX
            For IX = 1 To NX
                Xt = Xt + DX
                NContou = NContou + 1
                Input #1, Zcontou(NContou)
                Xcontou(NContou) = Xt
                Ycontou(NContou) = Yt
                Zgrid(IX, IY) = Zcontou(NContou)
            Next IX
            Line Input #1, Temp
        Next IY
    End If
    Close (1)
ElseIf (DSAA_DSBB = "DSBB") Then
    DataType = 0
    Open TheContouPath For Binary Access Read Lock Read As #1
    Seek #1, 5
    Get #1, , NX
    Get #1, , NY
    Get #1, , Xmin
    Get #1, , Xmax
    Get #1, , Ymin
    Get #1, , Ymax
    Get #1, , Vmin
    Get #1, , Vmax
    
    ReDim Zgrid(1 To NX, 1 To NY), bZgrid(1 To NX, 1 To NY)
    
    N0 = NX
    N0 = N0 * NY
    ReDim Xcontou(0 To N0), Ycontou(0 To N0), Zcontou(0 To N0)
    
    NContou = -1
    DX = (Xmax - Xmin) / (NX - 1)
    DY = (Ymax - Ymin) / (NY - 1)
    Yt = Ymin - DY
    For IY = 1 To NY
        Yt = Yt + DY
        Xt = Xmin - DX
        For IX = 1 To NX
            Xt = Xt + DX
            NContou = NContou + 1
            Get #1, , ValueTemp
            
            Xcontou(NContou) = Xt
            Ycontou(NContou) = Yt
            Zcontou(NContou) = ValueTemp
            Zgrid(IX, IY) = ValueTemp
        Next IX
    Next IY
    Close (1)
ElseIf (DSAA_DSBB = "DSRB") Then
    DataType = 0
    Open TheContouPath For Binary Access Read Lock Read As #1
    Seek #1, 17
    Get #1, , lNY
    Get #1, , lNY
    Get #1, , lNX
    Get #1, , XminT
    Get #1, , YminT
    Get #1, , xStep
    Get #1, , yStep
    Get #1, , VminT
    Get #1, , VmaxT
        
    NX = lNX
    NY = lNY
    DX = xStep
    DY = yStep
    Xmin = XminT
    Xmax = Xmin + (NX - 1) * xStep
    Ymin = YminT
    Ymax = Ymin + (NY - 1) * yStep
    Vmin = VminT
    Vmax = VmaxT
    
    ReDim Zgrid(1 To NX, 1 To NY), bZgrid(1 To NX, 1 To NY)
    N0 = NX
    N0 = N0 * NY
    ReDim Xcontou(0 To N0), Ycontou(0 To N0), Zcontou(0 To N0)
    
    Seek #1, 101
    NContou = -1
    Yt = Ymin - DY
    For IY = 1 To NY
        Yt = Yt + DY
        Xt = Xmin - DX
        For IX = 1 To NX
            Xt = Xt + DX
            NContou = NContou + 1
            Get #1, , DouValueTemp
            
            Xcontou(NContou) = Xt
            Ycontou(NContou) = Yt
            Zcontou(NContou) = DouValueTemp
            Zgrid(IX, IY) = DouValueTemp
        Next IX
    Next IY
    Close (1)
Else
    '判断一行有几个数
    Open TheContouPath For Input As #1
    For I = 1 To 3
        Line Input #1, Temp
        Temp = Trim(Temp)
        J = Len(Temp)
        I1 = 2
        K = 1
        Do While I1 < J
            If (Mid(Temp, I1, 1) = " " Or Mid(Temp, I1, 1) = ",") Then
                K = K + 1
                For L = I1 + 1 To J
                    If (Mid(Temp, L, 1) = " " Or Mid(Temp, L, 1) = ",") Then
                        I1 = L
                    Else
                        I1 = I1 + 1