标题:求大神们帮我看看这个程序哪里出错了,为什么不能用啊
只看楼主
vb好难
Rank: 1
等 级:新手上路
帖 子:11
专家分:0
注 册:2012-12-4
结帖率:100%
已结贴  问题点数:20 回复次数:4 
求大神们帮我看看这个程序哪里出错了,为什么不能用啊
Option Explicit

Dim strFileName As String
Dim lujing As String
Dim nn%, un%, tn%, hn%              '已知点个数,未知点个数,总点数,观测值个数
Dim Pname() As String               '点名数组
Dim Hknown() As Double              '已知高程数组,存放已知点高程和高程近似值
Dim be%(), en%()                    '观测值的起点和终点编号数组,存储的是点序号
Dim h#(), s#()                      '高差观测值数组和距离观测值数组
Dim A#(), X#(), P#(), L#(), V#(), V0#(), X0#(), L0#()      '间接平差的系数阵、解向量、权阵和常数向量

Private Sub Command1_Click()
txtshow.Text = ""
Text1.Text = ""
Dim i As Integer                    '循环变量
    Dim strT1 As String, strT2 As String
    lujing = App.Path
    CDg1.InitDir = lujing
    CDg1.Filter = "文本文件(*.txt)|*.txt|所有文件(*.*)|*.*"
    CDg1.ShowOpen                       '打开对话框
    strFileName = CDg1.FileName         '获得选中的文件名和路径
    If strFileName = "" Then
    Exit Sub
    End If
   
   
   
    Open strFileName For Input As #1    '打开文件
        Input #1, nn, un, hn            '读入已知点个数,未知点个数,观测值个数
        tn = nn + un
        ReDim Pname(1 To tn), Hknown(1 To tn)
        ReDim h(1 To hn), s(1 To hn), be(1 To hn), en(1 To hn)
        For i = 1 To tn                 '读入点名
            Input #1, Pname(i)
        Next i
        For i = 1 To nn                 '读入已知高程
            Input #1, Hknown(i)
        Next i
        For i = 1 To hn                 '读入各观测值
            Input #1, strT1, strT2, h(i), s(i)
            be(i) = Order(strT1):    en(i) = Order(strT2)    '给起终点数组排序
        Next i
        
        '显示读入的数据
        txtshow.Text = txtshow.Text & "//==读入的水准网数据==\\" & vbCrLf
        txtshow.Text = txtshow.Text & "已知点" & nn & "个,未知点" & un & "个,观测值" & hn & "个。" & vbCrLf
        txtshow.Text = txtshow.Text & "网中涉及的点名有:"
        For i = 1 To tn
            txtshow.Text = txtshow.Text & Pname(i) & ","
        Next i
        txtshow.Text = txtshow.Text & vbCrLf
        txtshow.Text = txtshow.Text & "已知点点号、高程" & vbCrLf
        For i = 1 To nn
            txtshow.Text = txtshow.Text & Pname(i) & "的高程为:" & Hknown(i) & vbCrLf
        Next i
        txtshow.Text = txtshow.Text & "//==各观测值分别为==\\" & vbCrLf
        txtshow.Text = txtshow.Text & "起点" & "    " & "终点" & "   " & "高差观测值(m) " & " 距离观测值(km)" & vbCrLf
        For i = 1 To hn
            txtshow.Text = txtshow.Text & Left(Pname(be(i)) & "           ", 8) & Left(Pname(en(i)) & "            ", 8) & Left(Format(h(i), "0.000") & "                                 ", 16) & Format(s(i), "0.000") & vbCrLf
        Next i
    Close #1                            '关闭文件
    Command2.Enabled = True
End Sub

Private Sub Command2_Click()
command3.Enabled = True
Text1.Text = ""
'计算近似高程
    Dim i%, j%
     For i = 1 To un
        For j = 1 To hn
            If be(j) = nn + i And en(j) < nn + i Then   '找到一个起点相同且终点已知的观测值
                Hknown(nn + i) = Hknown(en(j)) - h(j)
                Exit For
            End If
            If en(j) = nn + i And be(j) < nn + i Then   '找到一个终点相同且起点已知的观测值
                Hknown(nn + i) = Hknown(be(j)) + h(j)
                Exit For
            End If
        Next j
    Next i
   
    '显示近似高程计算结果
    Text1.Text = Text1.Text & "//==近似高程计算结果==\\ " & vbCrLf
    For i = 1 To un
        Text1.Text = Text1.Text & Pname(i + nn) & ":" & Format(Hknown(i + nn), "0.000") & vbCrLf
    Next i

'列立误差方程:给A、P、L赋值
   
    ReDim A(1 To hn, 1 To un), L(1 To hn), P(1 To hn, 1 To hn)
   
    '对每个观测值列误差方程
    For i = 1 To hn
        If en(i) > nn Then A(i, en(i) - nn) = 1     '若终点未知,则给终点对应的系数矩阵元素赋值
        If be(i) > nn Then A(i, be(i) - nn) = -1    '若起点未知,则给起点对应的系数矩阵元素赋值
        L(i) = -(Hknown(en(i)) - Hknown(be(i)) - h(i))  '根据起终点计算常数项
        P(i, i) = 1 / s(i)                          '以距离的倒数为权
    Next i
   
    '显示误差方程
     Text1.Text = Text1.Text & "//==得到的A矩阵与L矩阵(V=Ax-L)==\\:" & vbCrLf
     For i = 1 To hn
        For j = 1 To un
            Text1.Text = Text1.Text & Left(A(i, j) & "        ", 5)
        Next j
        Text1.Text = Text1.Text & "     " & Format(L(i), "0.0000") & vbCrLf
     Next i
     '显示权矩阵
     Text1.Text = Text1.Text & "//==权矩阵(取1km的观测高差为单位权观测)==\\:" & vbCrLf
     For i = 1 To hn
        For j = 1 To hn
            Text1.Text = Text1.Text & Format(P(i, j), "0.0000") & "  "
        Next j
        Text1.Text = Text1.Text & vbCrLf
     Next i

'-----------------------------------平差计算
    ReDim X(1 To un)
    InAdjust A, P, L, X         '调用间接平差的通用过程求解
'-----------------------------------平差计算结束
   
'----------------------------------------------开始计算中误差
ReDim X0(1 To un, 1 To 1)
ReDim L0(1 To hn, 1 To 1)
ReDim V(1 To hn, 1 To 1)
ReDim m(1 To hn)
Dim mm#, mmm#

'将一维数组转化为二维矩阵数组
For i = 1 To un
X0(i, 1) = X(i)
Next i

For i = 1 To hn
L0(i, 1) = L(i)
Next i

MatrixMulti A, X0, V0       '矩阵 A*X
 Debug.Print "The At matrix is:"
 ShowMatrix V0

For i = 1 To hn           'V=A*X-L
V(i, 1) = V0(i, 1) - L(i)
Next i

mm = 0  '开始计算PV*V
 For i = 1 To hn
 m(i) = P(i, i) * V(i, 1) * V(i, 1)
 mm = mm + m(i)
 Next i
 
mmm = 1000 * Sqr(mm / (hn - un)) '计算中误差
'-----------------------------------中误差计算结束


'-------------------------------------------------------------------计算并显示高程平差结果
    Text1.Text = Text1.Text & "//==平差计算结果==\\:" & vbCrLf
    Text1.Text = Text1.Text & "每公里水准测量中误差= +/-" & Format(mmm, "0.0") & " mm" & vbCrLf
    Text1.Text = Text1.Text & "点号   初始高程(m)  高程改正数(m)  平差后高程(m)" & vbCrLf
    For i = 1 To un
        Text1.Text = Text1.Text & Pname(nn + i) & "       " & Format(Hknown(nn + i), "0.0000")
        Hknown(nn + i) = Hknown(nn + i) + X(i)
        Text1.Text = Text1.Text & "      " & Format(X(i), "0.0000") & "         " & Format(Hknown(nn + i), "0.0000") & vbCrLf
    Next i
    Text1.Text = Text1.Text & vbCrLf
End Sub





Private Sub command3_Click()
CDg1.CancelError = True
 CDg1.Filter = "文本文件(*.txt)|*.txt|所有文件(*.*)|*.*"
    CDg1.ShowSave
    strFileName = CDg1.FileName
    Open strFileName For Output As #1
        Print #1, txtshow.Text
        Print #1, Text1.Text
    Close #1
End Sub

Private Sub Command4_Click()
Unload Me
End Sub


Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label16.ForeColor = vbRed
Label16.Font.Underline = False
End Sub

Private Sub Label16_Click()
CreateObject("wscript.shell").run "http://www.
Label16.ForeColor = vbRed
Label16.Font.Underline = False
End Sub

Private Sub Label16_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label16.ForeColor = vbBlue
Me.MousePointer = 0
Label16.Font.Underline = True
End Sub
'点名 序号转换程序
Public Function Order(str As String) As Integer
    Dim i%
    For i = 1 To tn
        If str = Pname(i) Then
            Order = i
            Exit For
        End If
    Next i
End Function

搜索更多相关主题的帖子: 起点 
2012-12-04 22:24
vb好难
Rank: 1
等 级:新手上路
帖 子:11
专家分:0
注 册:2012-12-4
得分:0 
木有人帮忙啊。。。。。。
2012-12-05 12:12
Artless
Rank: 19Rank: 19Rank: 19Rank: 19Rank: 19Rank: 19
等 级:贵宾
威 望:103
帖 子:4211
专家分:28888
注 册:2009-4-8
得分:14 
怎么不能用?

无知
2012-12-05 12:31
vb好难
Rank: 1
等 级:新手上路
帖 子:11
专家分:0
注 册:2012-12-4
得分:0 
回复 3楼 Artless
你能不能帮我试试,那个txt的文档输入,读取的不对啊,现实下标超限。。。。
2012-12-05 14:06
vb好难
Rank: 1
等 级:新手上路
帖 子:11
专家分:0
注 册:2012-12-4
得分:0 
来大神帮帮忙好么。。。。。。
2012-12-05 15:15



参与讨论请移步原网站贴子:https://bbs.bccn.net/thread-389599-1-1.html




关于我们 | 广告合作 | 编程中国 | 清除Cookies | TOP | 手机版

编程中国 版权所有,并保留所有权利。
Powered by Discuz, Processed in 0.277594 second(s), 9 queries.
Copyright©2004-2024, BCCN.NET, All Rights Reserved