module1.bas

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

Attribute VB_Name = "Module1"
Public X() As Double
Public Y() As Double
Public Z() As Double
 Const Nmax = 7 '最大点数
Const Nmin = 3 '最小点数
Public Sxmin As Double
Public Sxmax As Double
Public Symin As Double
Public Symax As Double
 Type grid
  xx As Double
  yy As Double
  zz As Double
  End Type
Public PH(1 To 1000, 1 To 1000) As Integer
Public S As Single
Public DEM() As grid
Public PL() As Integer

  

Public Sub DATARS(ByVal ll As Integer, ByVal rr As Integer, ByRef a() As Double, ByRef b() As Double, ByRef c() As Double, ByRef nn As Integer)

Dim i As Integer
Dim j As Integer

i = PH(ll, rr)

Do While (PL(i) <> 0)
a(nn) = X(i)
b(nn) = Y(i)
c(nn) = Z(i)
nn = nn + 1
i = PL(i)
Loop

End Sub

'Xp,Yp为待插点的坐标
Public Sub dp(ByVal Xp As Double, ByVal Yp As Double, Ax() As Double, By() As Double, Cz() As Double, Zp As Double, nn As Integer)
Dim i As Integer
Dim sum As Double
Dim sump As Double
Dim NUM As Integer
Dim dist() As Double
Dim p() As Double
 Dim aa() As Double
 Dim bb() As Double
 Dim cc() As Double
 ReDim aa(1 To nn) As Double
 ReDim bb(1 To nn) As Double
 ReDim cc(1 To nn) As Double
    Sxmin = Xp - S / 2
    Sxmax = Xp + S / 2
    Symin = Yp - S / 2
    Symax = Yp + S / 2
pppp:
For i = 1 To nn
    If Sxmin <= Ax(i) And Ax(i) <= Sxmax And Symin <= By(i) And By(i) <= Symax Then
   
    NUM = NUM + 1
    aa(NUM) = Ax(i)
    bb(NUM) = By(i)
    cc(NUM) = Cz(i)
    
    End If
   Next i
 ''''''''''''''''''''''''''''''''

 If NUM < Nmin Then
    '提示点数不够加搜索面积
   ' MsgBox ("当前点数为:" & NUM & Chr(13) & "点数不够计算请增加搜索面积")
   
    
    S = S + 10 '+ Val(Text11.Text) ' 增加矩形搜索面积
    Sxmin = Xp - S / 2
    Sxmax = Xp + S / 2
    Symin = Yp - S / 2
   Symax = Yp + S / 2
  NUM = 0
  GoTo pppp
  End If
     If NUM > Nmax Then
       '提示点数多减搜索面积
       ' MsgBox ("当前点数为:" & NUM & Chr(13) & "点数过多误差大请减少搜索面积")
      
       S = S - 10 'Val(Form1.Text12.Text)- Val(Text11.Text) '减少矩形搜索面积
       Sxmin = Xp - S / 2
       Sxmax = Xp + S / 2
       Symin = Yp - S / 2
       Symax = Yp + S / 2
    NUM = 0
    GoTo pppp
    End If
  
  
  ''''''''''''''''''''加权法求高程
  If Nmin <= NUM <= Nmax Then
  ReDim dist(1 To NUM) As Double
  ReDim p(1 To NUM) As Double
  
  For i = 1 To NUM
   dist(i) = Sqr((Xp - aa(i)) * (Xp - aa(i)) + (Yp - bb(i)) * (Yp - bb(i)))
   p(i) = 1 / dist(i)
  Next
   sum = 0
   sump = 0
  For i = 1 To NUM
   sum = sum + cc(i) * p(i)
   sump = sump + p(i)
  Next
   Zp = sum / sump
   nn = 1

End If

 ''''''''''''''''''''''''''''''''''''''''
 
















End Sub