frmgrid.frm

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

                        Exit For
                    End If
                Next L
            Else
                I1 = I1 + 1
            End If
        Loop
        If (K <> 3) Then Exit For
    Next I
    Close (1)
    If (K <> 3) Then
        MsgBox "非本程序识别格式!请按如下格式存放:" + Chr(10) + Chr(13) + "纬度,经度,观测值", vbOKOnly, "关于绘平面图等"
        Exit Sub
    End If
    N0 = 1000
    ReDim Xcontou(0 To N0), Ycontou(0 To N0), Zcontou(0 To N0)
    N = -1
    Open TheContouPath For Input As #1
    Do While Not EOF(1)
        N = N + 1
        If (N > N0) Then
            N0 = N0 + 100
            ReDim Preserve Xcontou(0 To N0), Ycontou(0 To N0), Zcontou(0 To N0)
        End If
        Input #1, Ycontou(N), Xcontou(N), Zcontou(N)
    Loop
    NContou = N
    Close (1)
    Call SortXY(Xcontou, Ycontou, Zcontou, NContou)
    
    '判断是否是网格数据
    Call CheckGrid(Xcontou, Ycontou, NContou, NX, NY)
    If (DataType = 0) Then
        ReDim Zgrid(1 To NX, 1 To NY), bZgrid(1 To NX, 1 To NY)
        II = -1
        For IX = 1 To NX
            For IY = 1 To NY
                II = II + 1
                Zgrid(IX, IY) = Zcontou(II)
            Next IY
        Next IX
    End If
    
    Xmin = Xcontou(0)
    Xmax = Xcontou(0)
    Ymin = Ycontou(0)
    Ymax = Ycontou(0)
    Vmin = Zcontou(0)
    Vmax = Zcontou(0)
    For I = 0 To NContou
        If (Xcontou(I) < Xmin) Then Xmin = Xcontou(I)
        If (Xcontou(I) > Xmax) Then Xmax = Xcontou(I)
            
        If (Ycontou(I) < Ymin) Then Ymin = Ycontou(I)
        If (Ycontou(I) > Ymax) Then Ymax = Ycontou(I)
            
        If (Zcontou(I) < Vmin) Then Vmin = Zcontou(I)
        If (Zcontou(I) > Vmax) Then Vmax = Zcontou(I)
    Next I

    'Begin判断经纬度是否颠倒
    If (Ymin >= -180 And Ymax <= 180 And Xmin >= -90 And Xmax <= 90) Then
        ReDim Xcontou(0 To NContou), Ycontou(0 To NContou), Zcontou(0 To NContou)
        Open TheContouPath For Input As #1
        For I = 0 To NContou
            Input #1, Xcontou(I), Ycontou(I), Zcontou(I)
        Next I
        Close (1)
        Call SortXY(Xcontou, Ycontou, Zcontou, NContou)
    
        '判断是否是网格数据
        Call CheckGrid(Xcontou, Ycontou, NContou, NX, NY)
        If (DataType = 0) Then
            ReDim Zgrid(1 To NX, 1 To NY), bZgrid(1 To NX, 1 To NY)
            II = -1
            For IX = 1 To NX
                For IY = 1 To NY
                    II = II + 1
                    Zgrid(IX, IY) = Zcontou(II)
                Next IY
            Next IX
        End If
    
        Xmin = Xcontou(0)
        Xmax = Xcontou(0)
        Ymin = Ycontou(0)
        Ymax = Ycontou(0)
        Vmin = Zcontou(0)
        Vmax = Zcontou(0)
        For I = 0 To NContou
            If (Xcontou(I) < Xmin) Then Xmin = Xcontou(I)
            If (Xcontou(I) > Xmax) Then Xmax = Xcontou(I)
            
            If (Ycontou(I) < Ymin) Then Ymin = Ycontou(I)
            If (Ycontou(I) > Ymax) Then Ymax = Ycontou(I)
            
            If (Zcontou(I) < Vmin) Then Vmin = Zcontou(I)
            If (Zcontou(I) > Vmax) Then Vmax = Zcontou(I)
        Next I
    End If
    'End判断经纬度是否颠倒
End If

'设置等值线参数
Call MaxnDec(Vmin, Vmax, nDec, StrMax, FMT)

Vmin = Val(Format(Vmin, FMT))
Vmax = Val(Format(Vmax, FMT))

Xmin0 = Xmin
Xmax0 = Xmax
Ymin0 = Ymin
Ymax0 = Ymax
End Sub


'判断是否为网格数据
Private Sub CheckGrid(X() As Double, Y() As Double, N As Long, NX As Integer, NY As Integer)
Dim IX As Long, IY As Long
Dim RR() As Double, VV() As Double, V As Double, C As Double
Dim Xtemp As Double, Ytemp As Double, Error1 As Integer
Dim I As Long

DataType = 0
'判断是否是网格数据
Xtemp = X(0)
Ytemp = Y(0)
NX = 0
NY = 0
DY = Y(2) - Y(1)
For I = 0 To N
    If (X(I) <> Xtemp) Then Exit For
    NY = NY + 1
Next I
If (NY < 3) Then 'X方向数据小于3个,肯定非网格数据
    DataType = 1
    GoTo Error1
End If
NX = Fix((N + 1) / NY)
If (NY * NX = N + 1) Then '有可能是网格数据
    DataType = 0
    '判断X坐标是否等间距
    DX = X(NY) - X(0)
    For IX = 2 To NX - 1
        Xtemp = X(IX * NY) - X((IX - 1) * NY)
        If (Abs(Xtemp - DX) > 0.000001) Then
            DataType = 1
            GoTo Error1
        End If
    Next IX
    '判断Y是否等间距
    DY = Y(1) - Y(0)
    For IY = 2 To NY - 1
        Ytemp = Y(IY) - Y(IY - 1)
        If (Abs(Ytemp - DY) > 0.000001) Then
            DataType = 1
            GoTo Error1
        End If
    Next IY
Else '肯定不是网格数据
    DataType = 1
End If
Error1:
End Sub

'数据按X、Y排序
Private Sub SortXY(X() As Double, Y() As Double, Z() As Double, N As Long)
Dim N1 As Long, N2 As Long, X1 As Double
Dim I As Long, J As Long

'按X坐标排序
Call ShellSort(X, Y, Z, N, 0, N)
'按Y坐标排序
X1 = X(0)
N1 = 0
N2 = 0
For I = 1 To N
    If (X(I) = X1) Then
        N2 = N2 + 1
    Else
        If (N2 > N1) Then '相同X按Y坐标排序
            Call ShellSort(Y, X, Z, N, N1, N2)
        End If
        X1 = X(I)
        N1 = I
        N2 = I
    End If
Next I
If (N2 > N1) Then '相同X按Y坐标排序
    Call ShellSort(Y, X, Z, N, N1, N2)
End If

'平均重合点
J = -1
X1 = Z(0)
N1 = 1
For I = 1 To N
    If (Abs(X(I) - X(I - 1)) + Abs(Y(I) - Y(I - 1)) < 0.00001) Then
        X1 = X1 + Z(I)
        N1 = N1 + 1
    Else
        J = J + 1
        Z(J) = X1 / N1
        X(J) = X(I - 1)
        Y(J) = Y(I - 1)
        X1 = Z(I)
        N1 = 1
    End If
Next I
J = J + 1
Z(J) = X1 / N1
X(J) = X(N)
Y(J) = Y(N)
N = J
End Sub
'排序子程序
Private Sub ShellSort(X() As Double, Y() As Double, Z() As Double, N As Long, N1 As Long, N2 As Long)
Dim B As Long, M As Long, L As Long, I As Long, J As Long, K As Long
Dim Xtemp As Double, Ytemp As Double, Ztemp As Double, jk As Long

B = N2 - N1 + 1
B = Log(B) / Log(2#)
M = B
L = 2 ^ M
For I = 1 To M
    K = L - 1
    L = L / 2
    For J = K + N1 To N2
        Xtemp = X(J)
        Ytemp = Y(J)
        Ztemp = Z(J)
        jk = J - K
        Do While (jk > N1 - 1 And X(jk) > Xtemp)
            X(jk + K) = X(jk)
            Y(jk + K) = Y(jk)
            Z(jk + K) = Z(jk)
            jk = jk - K
            If (jk < 0) Then Exit Do
        Loop
        X(jk + K) = Xtemp
        Y(jk + K) = Ytemp
        Z(jk + K) = Ztemp
    Next J
Next I
End Sub

Private Sub MaxnDec(Ymin As Single, Ymax As Single, nDec As Integer, StrMax As String, FormatTMP As String)
Dim ValueMax As Single, Delta As Single, StrYmin As String, StrYmax As String

If (Abs(Ymax) > Abs(Ymin)) Then
    ValueMax = Abs(Ymax)
Else
    ValueMax = Abs(Ymin)
End If
Delta = Abs(Ymax - Ymin)
If (Delta < 0.001 Or ValueMax < 0.001) Then
    nDec = 5
    FormatTMP = "######0.00000"
    StrYmin = Format(Ymin, "######0.00000")
    StrYmax = Format(Ymax, "######0.00000")
ElseIf (Delta < 0.01 Or ValueMax < 0.01) Then
    nDec = 4
    FormatTMP = "######0.0000"
    StrYmin = Format(Ymin, "######0.0000")
    StrYmax = Format(Ymax, "######0.0000")
ElseIf (Delta < 0.1 Or ValueMax < 0.1) Then
    nDec = 3
    FormatTMP = "######0.000"
    StrYmin = Format(Ymin, "######0.000")
    StrYmax = Format(Ymax, "######0.000")
ElseIf (Delta < 1# Or ValueMax < 1#) Then
    nDec = 2
    FormatTMP = "######0.00"
    StrYmin = Format(Ymin, "######0.00")
    StrYmax = Format(Ymax, "######0.00")
ElseIf (Delta < 10# Or ValueMax < 10#) Then
    nDec = 1
    FormatTMP = "######0.0"
    StrYmin = Format(Ymin, "######0.0")
    StrYmax = Format(Ymax, "######0.0")
Else
    FormatTMP = "######0"
    StrYmin = Format(Ymin, "######0")
    StrYmax = Format(Ymax, "######0")
    nDec = 0
End If
StrMax = StrYmax
If (Len(StrYmin) > Len(StrMax)) Then StrMax = StrYmin

End Sub
Private Sub DrawOld()
Dim Dx0 As Double, Dy0 As Double, I As Integer, J As Integer
Dim X As Double, Y As Double, YmaxNew As Double, XmaxNew As Double

PictureGrid.Picture = LoadPicture()
PictureGrid.DrawWidth = 1

XminT = Val(TextXmin.Text)
XmaxT = Val(TextXmax.Text)
YminT = Val(TextYmin.Text)
YmaxT = Val(TextYmax.Text)

DX = Val(TextXStep.Text)
DY = Val(TextYStep.Text)
NX = Val(TextXNX.Text)
NY = Val(TextYNY.Text)
If (XmaxT < XminT + DX * (NX - 1)) Then XmaxT = XminT + DX * (NX - 1)
If (YmaxT < YminT + DY * (NY - 1)) Then YmaxT = YminT + DY * (NY - 1)
If (Xmin < XminT) Then
    Xmin0 = Xmin
Else
    Xmin0 = XminT
End If
If (Ymin < YminT) Then
    Ymin0 = Ymin
Else
    Ymin0 = YminT
End If
If (Xmax > XmaxT) Then
    Xmax0 = Xmax
Else
    Xmax0 = XmaxT
End If
If (Ymax > YmaxT) Then
    Ymax0 = Ymax
Else
    Ymax0 = YmaxT
End If


Dx0 = 30
Dy0 = 30
Dx0 = Dx0 * (Xmax0 - Xmin0) / (PictureGrid.Width - 2 * Dx0)
Dy0 = Dy0 * (Ymax0 - Ymin0) / (PictureGrid.Height - 2 * Dy0)
PictureGrid.ScaleLeft = Xmin0 - Dx0
PictureGrid.ScaleWidth = (Xmax0 + Dx0) - (Xmin0 - Dy0)
PictureGrid.ScaleTop = Ymax0 + Dy0
PictureGrid.ScaleHeight = (Ymin0 - Dy0) - (Ymax0 + Dy0)

PictureGrid.ForeColor = 0 ' QBColor(4)
Dx0 = 3
Dx0 = Dx0 * (XmaxT - XminT) / (PictureGrid.Width - 2 * Dx0)
PictureGrid.DrawMode = 13
For I = 0 To NContou
    PictureGrid.Circle (Xcontou(I), Ycontou(I)), Dx0
Next I
PictureGrid.ForeColor = QBColor(8)
PictureGrid.DrawMode = 10

XmaxNew = XminT + (NX - 1) * DX
YmaxNew = YminT + (NY - 1) * DY
X = XminT - DX
For I = 1 To NX
    X = X + DX
    PictureGrid.Line (X, YminT)-(X, YmaxNew)
Next I

Y = YminT - DY
For I = 1 To NY
    Y = Y + DY
    PictureGrid.Line (XminT, Y)-(XmaxNew, Y)
Next I
PictureGrid.ForeColor = QBColor(0)

End Sub

Private Sub Form_Load()
    TheInstallPath = App.Path
    If (Right(TheInstallPath, 1) <> "\") Then
        TheInstallPath = App.Path + "\"
    End If

    TheContouPath = TheInstallPath + "等值线数据\"
    TheContouFile = ""
End Sub

Private Sub TextXmax_KeyDown(KeyCode As Integer, Shift As Integer)
If (KeyCode = 13) Then
    Call DrawOld
End If
End Sub


Private Sub TextXmin_KeyDown(KeyCode As Integer, Shift As Integer)
If (KeyCode = 13) Then
    Call DrawOld
End If
End Sub


Private Sub TextXNX_KeyDown(KeyCode As Integer, Shift As Integer)
If (KeyCode = 13) Then
    Call DrawOld
End If
End Sub

Private Sub TextXStep_KeyDown(KeyCode As Integer, Shift As Integer)
If (KeyCode = 13) Then
    Call DrawOld
End If
End Sub

Private Sub TextYmax_KeyDown(KeyCode As Integer, Shift As Integer)
If (KeyCode = 13) Then
    Call DrawOld
End If

End Sub


Private Sub TextYmin_KeyDown(KeyCode As Integer, Shift As Integer)
If (KeyCode = 13) Then
    Call DrawOld
End If

End Sub


Private Sub TextYNY_KeyDown(KeyCode As Integer, Shift As Integer)
If (KeyCode = 13) Then
    Call DrawOld
End If
End Sub

Private Sub TextYStep_KeyDown(KeyCode As Integer, Shift As Integer)
If (KeyCode = 13) Then
    Call DrawOld
End If
End Sub