form1.frm

有关格网的插值小程序,采用数组指针进行数据分块的还待改善!如果那位下了改善后联系 知道[e-mail]

 ReDim Z(1 To k) As Double
 
ReDim PL(0 To k) As Integer
 For j = 1 To k Step 1
  
    NO(j) = a(4 * (j - 1) + 0)
    X(j) = Val(a(4 * (j - 1) + 1))
    Y(j) = Val(a(4 * (j - 1) + 2))
    Z(j) = Val(a(4 * (j - 1) + 3))

Next j


Dim Xmin As Double
Dim Ymin As Double
Dim Xmax As Double
Dim Ymax As Double
 Xmin = 10000000000000#
 Xmax = -10000000000000#
 Ymin = 10000000000000#
 Ymax = -10000000000000#
'Xmin
For i = 1 To k

 If Xmin <= X(i) Then
  Xmin = Xmin
 
 Else
  Xmin = X(i)
 End If
Next i
'Xmax
For i = 1 To k

 If Xmax >= X(i) Then
  Xmax = Xmax
 
 Else
  Xmax = X(i)
 End If
Next i
'ymin
For i = 1 To k

 If Ymin <= Y(i) Then
  Ymin = Ymin
 
 Else
  Ymin = Y(i)
 End If
Next i
'ymax
For i = 1 To k

 If Ymax >= Y(i) Then
  Ymax = Ymax
 
 Else
  Ymax = Y(i)
 End If
Next i

Text1.Text = Xmin
Text2.Text = Xmax
Text3.Text = Ymin
Text4.Text = Ymax

Text7.Text = Xmin
Text8.Text = Ymin






DX = Val(Text2.Text - Text1.Text)
Dy = Val(Text4.Text - Text3.Text)
area = DX * Dy
D = Sqr(area / (Sqr(k)))

'**************************数据分块**************************
PL(0) = 0
For i = 1 To k
   L = Int(X(i) / D) + 1
   R = Int(Y(i) / D) + 1
    If PH(L, R) = 0 Then
     PH(L, R) = Val(NO(i))
     PL(i) = 0
   
  Else
  If PH(L, R) <> 0 Then
  
   PL(i) = PH(L, R)
   PH(L, R) = NO(i)
   End If
 End If
Next
'********************************************************8







'Xp = 53447
'Yp = 31438











End Sub

Private Sub Command2_Click()




Dim Dlow As Double
Dim Drow As Double

Dim GRD() As grid

'Dim L As Integer
'Dim R As Integer
'Dim S As Integer


'Dim DEM() As Double



DX = Val(Text2.Text - Text1.Text)
Dy = Val(Text4.Text - Text3.Text)
area = DX * Dy

n = Val(Text13.Text)

S = Sqr(50 * area / Val(Text13.Text)) '初始搜索矩形面积 k为点数






Text12.Text = S







low = Val(Text5.Text)
row = Val(Text6.Text)

M = low * row     '格网数
Dlow = DX / low
Drow = Dy / row
'grid GRD(loe, row)


ReDim GRD(0 To low, 0 To row) As grid
Dim Xp As Double
Dim Yp As Double
Dim Zp As Double
Dim Ax(1 To 1000) As Double
Dim By(1 To 1000) As Double
Dim Cz(1 To 1000) As Double
Dim nk As Integer


nk = 1

' GRD(i, j)
 For i = 0 To low
   For j = 0 To row
    
      GRD(i, j).xx = j * Dlow + Val(Text1.Text)  '格网加上西南角坐标
      GRD(i, j).yy = i * Drow + Val(Text3.Text)
     Xp = GRD(i, j).xx
     Yp = GRD(i, j).yy
     L = Int(Xp / D) + 1
     R = Int(Yp / D) + 1
     
      
      Call DATARS(L, R, Ax(), By(), Cz(), nk)
  
  If nk < 8 Then
   L = L - 1                                 'L-1
   R = R - 1                                  'R-1
   Call DATARS(L, R, Ax(), By(), Cz(), nk)
  End If
  If nk < 8 Then
  L = L                                   'L-1,R
  R = R + 1
  Call DATARS(L, R, Ax(), By(), Cz(), nk)
  End If
  If nk < 8 Then
  L = L                                       'L-1,R+1
  R = R + 1
  Call DATARS(L, R, Ax(), By(), Cz(), nk)
  End If
  If nk < 8 Then
  L = L + 1                                    'L,R-1
  R = R - 2
  Call DATARS(L, R, Ax(), By(), Cz(), nk)
  End If
  L = L + 1                                   'L+1,R-1
  R = R
  If nk < 8 Then
  L = L                                       'L+1,R+1
  R = R + 1
  Call DATARS(L, R, Ax(), By(), Cz(), nk)
  End If
  If nk < 8 Then
  L = L + 1                                       'L+1,R
  R = R - 1
  Call DATARS(L, R, Ax(), By(), Cz(), nk)
  End If
  If nk > 8 Then                                 '选择大于八个点的数据快
  Call dp(Xp, Yp, Ax(), By(), Cz(), Zp, nk)
  GRD(i, j).zz = Zp
  End If
  
  Next j
 Next i

'ReDim DEM(NUM * 3) As Double

'For i = 0 To NUM - 1
'DEM(i * 3 + 1) = GRD(i, j).xx
'DEM(i * 3 + 1) = GRD(i, j).yy
'DEM(i * 3 + 1) = GRD(i, j).zz
'Next i
'Sxmin = Xp - S / 2
'Sxmax = Xp + S / 2
'Symin = Yp - S / 2
'Symax = Yp + S / 2
ReDim DEM(0 To low, 0 To low)
  For i = 0 To low
   For j = 0 To row
    DEM(i, j).xx = GRD(i, j).xx
    DEM(i, j).yy = GRD(i, j).yy
    DEM(i, j).zz = GRD(i, j).zz
 Next
Next


    
    
    

  













End Sub

Private Sub Command3_Click()
Dim My_filename2  As String
 Dim i As Integer
 Dim j As Integer
          
          Me.CommonDialog2.FileName = ""
            Me.CommonDialog2.DialogTitle = "保存规则格网插值数据"
            Me.CommonDialog2.Filter = "文件  (*.txt)|*.dat|所有文件  (*.* )|**.*"
            Me.CommonDialog2.FilterIndex = 1
            Me.CommonDialog2.ShowSave
            My_filename2 = Me.CommonDialog2.FileName '
            If My_filename2 <> "" And My_filename2 <> "*.txt" And My_filename2 <> "Empty" Then
            Open My_filename2 For Output As #2 '

            End If
 
 Do Until j > low
    For j = 0 To low
     For i = 0 To low
    'Print #2, Cass_Num & "," & Cass_x & "," & Cass_x & "," & Cass_x & "," & Cass_xyh(2)
        Print #2, Tab(4); Format(DEM(j, i).xx, "00000.000"); Tab(18); Format(DEM(j, i).yy, "00000.000"); Tab(35); Format(DEM(j, i).zz, "000.000")
   
     Next i
    Next j
    Loop
    
    Close #2











End Sub

Private Sub Command4_Click()
End
End Sub

Private Sub Form_Load()
Text1.Text = ""
Text2.Text = ""
Text3.Text = ""
Text4.Text = ""
Text5.Text = ""
Text6.Text = ""
Text7.Text = ""
Text8.Text = ""
Nmin = 3
Nmax = 8
Text9.Text = ""
Text10.Text = ""
Text11.Text = ""
Text12.Text = ""

End Sub

Private Sub UpDown1_DownClick()
Text12.Text = Val(Text12.Text) - Val(Text11.Text)   'Val(Text12.Text)为初始搜索面积
Label12.Caption = "减去右边矩形面积增量后"
 S = Text12.Text '- Val(Text11.Text) '减少矩形搜索面积
       Sxmin = Xp - S / 2
       Sxmax = Xp + S / 2
       Symin = Yp - S / 2
       Symax = Yp + S / 2


End Sub

Private Sub UpDown1_UpClick()
Text12.Text = Val(Text11.Text) + Val(Text12.Text)
Label12.Caption = "增加右边矩形面积增量后"
S = Text12.Text '+ Val(Text11.Text) ' 增加矩形搜索面积
    Sxmin = Xp - S / 2
    Sxmax = Xp + S / 2
    Symin = Yp - S / 2
    Symax = Yp + S / 2


End Sub