www.pudn.com > DataCollectionSystem.rar > modFangan1.bas, change:2003-05-22,size:2637b


Attribute VB_Name = "fanganone" 
Option Explicit 
'这个方案可能测站坐标有问题 
Public Sub bxgz(czx As Double, czy As Double, czz As Double, H1() As Double, v1() As Double, sxj1() As Double, dianshu2 As Integer, ip1 As Double, lp1 As Double) 
 
Dim i As Integer 
Dim dp As Double '改正后的斜距 
Dim pj As Double, pj0 As Double  'pj改正后的平距 pj0改正前的平距 
Dim gc As Double, gc0 As Double  'gc改正后的高差 gc1改正前的高差 
Dim hChangetemp As Double 
 
ip1 = 0 
lp1 = 0 
 
For i = 1 To dianshu2 
dp = sxj1(i) - deltad * sxj1(i) '斜距的改正 
'方位角改正 
 
hChangetemp = H1(i) - deltah 
'高差改正后前的值 
 
gc = dp * Cos(v1(i)) - c * dp * dp * Sin(v1(i)) * Sin(v1(i)) + ip1 - lp1 
'gc0 = sxj1(i) * Sin(v1(i)) 
 
'平距离改正后前的值 
 pj = Sqr(dp ^ 2 - gc ^ 2) 
 
 'pj0 = Sqr((sxj1(i)) ^ 2 - gc0 ^ 2) 
'dp 改正过的斜距  dp0(i)原始斜距离 
 
xresult(i) = pj * Cos(hChangetemp) + czx 
yresult(i) = pj * Sin(hChangetemp) + czy 
zresult(i) = gc + czz 
Next i 
 
 
End Sub 
 
Public Sub qiudeltad(x() As Double, y() As Double, z() As Double, h() As Double, v() As Double, sxj() As Double, x1() As Double, y1() As Double, z1() As Double, H1() As Double, v1() As Double, sxj1() As Double, czx As Double, czy As Double, czz As Double) 
'c ,deltad, deltah为公共变量 
Dim i As Integer 
Dim max2(3) As Integer 
Dim temp As Double 
deltah = 0 
 
Call RelevantFixPtMax(x(), y(), z(), czx, czy, czz, M, max2()) 
 
 
For i = 1 To 3 
'    d0 = Sqr((x(max2(i)) - czx) ^ 2 + (y(max2(i)) - czy) ^ 2 + (z(max2(i)) - czz) ^ 2) 
'    d1 = Sqr((x1(max2(i)) - czx) ^ 2 + (y1(max2(i)) - czy) ^ 2 + (z1(max2(i)) - czz) ^ 2) 
'    deltad = deltad + (d1 - d0) / d1 
deltah = deltah + H1(max2(i)) - h(max2(i)) 
deltad = deltad + (sxj1(max2(i)) - sxj(max2(i))) / sxj1(max2(i)) 
temp = sxj1(max2(i)) * Sin(v1(max2(i))) 
c = c + (z1(max2(i)) - z(max2(i))) / temp / temp 
Next i 
deltad = deltad / 3 
c = c / 3 
deltah = deltah / 3 
 
 End Sub 
 
  
 
'某一变形点与基准点边长最长的三条 
Public Sub RelevantFixPtMax(xxx() As Double, yyy() As Double, zzz() As Double, x As Double, y As Double, z As Double, m1, max1() As Integer) 
Dim i As Integer 
Dim j As Integer 
Dim temps As Double 
Dim maxtemp As Double 
Dim k2 As Integer 
maxtemp = 0 
For i = 1 To 3 
    max1(i) = 0 
Next i 
 
For j = 1 To 3 
    For i = 1 To m1 
        If ((i <> max1(1)) And (i <> max1(2)) And (i <> max1(3))) Then 
            temps = Sqr((xxx(i) - x) ^ 2 + (yyy(i) - y) ^ 2 + (zzz(i) - z) ^ 2) 
            If temps > maxtemp Then 
                maxtemp = temps 
                k2 = i 
            End If 
        End If 
    Next i 
    maxtemp = 0 
    max1(j) = k2 
Next j 
 
End Sub