水准平差.frm

用VB编写的水准平差软件

End Sub


Private Sub Form_Resize()
    On Error Resume Next
    If Me.Width < 3000 Then Me.Width = 3000
    SizeControls imgSplitter.Left
End Sub


Private Sub grid_EnterCell()
    Dim row_sel As Integer
    row_sel = grid.RowSel
    grid.TextMatrix(row_sel, 0) = "**"
End Sub



Private Sub grid_LeaveCell()
    Dim row_sel As Integer
    row_sel = grid.RowSel
    grid.TextMatrix(row_sel, 0) = " "
End Sub

Private Sub grid1_EnterCell()
    Dim row_sel As Integer
    row_sel = grid1.RowSel
    grid1.TextMatrix(row_sel, 0) = "**"
End Sub

Private Sub grid1_LeaveCell()
    Dim row_sel As Integer
    row_sel = grid1.RowSel
    grid1.TextMatrix(row_sel, 0) = " "
End Sub

Private Sub imgSplitter_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    With imgSplitter
        picSplitter.Move .Left, .Top, .Width \ 2, .Height - 20
    End With
    picSplitter.Visible = True
    mbMoving = True
    
End Sub


Private Sub imgSplitter_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim sglPos As Single
    If mbMoving Then
        sglPos = x + imgSplitter.Left
        If sglPos < sglSplitLimit Then
            picSplitter.Left = sglSplitLimit
        ElseIf sglPos > Me.Width - sglSplitLimit Then
            picSplitter.Left = Me.Width - sglSplitLimit
        Else
            picSplitter.Left = sglPos
        End If
    End If
    'Call VMenu.Refresh
End Sub


Private Sub imgSplitter_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    SizeControls picSplitter.Left
    picSplitter.Visible = False
    mbMoving = False
    'Call VMenu.Refresh
End Sub


Private Sub todo_Click()
    MsgBox "生成报告！！！"
    result.Show
End Sub

Private Sub vmenu_DragDrop(Source As Control, x As Single, y As Single)
    If Source = imgSplitter Then
        SizeControls x
    End If
End Sub


Sub SizeControls(x As Single)
    On Error Resume Next
    

    'set the width
    If x < 500 Then x = 500
    If x > (Me.Width - 500) Then x = Me.Width - 500
    VMenu.Width = x
    imgSplitter.Left = x
    Frame2.Left = x + 40
    'grid1.Left = x + 40
    Frame2.Width = Me.Width - (VMenu.Width + 140)
    'grid1.Width = Me.Width - (VMenu.Width + 140)

    If tbToolBar.Visible Then
        VMenu.Top = tbToolBar.Height + picTitles.Height
    Else
        VMenu.Top = picTitles.Height
    End If
   Frame2.Top = VMenu.Top
  ' grid1.Top = VMenu.Top
    If sbStatusBar.Visible Then
        VMenu.Height = Me.ScaleHeight - (picTitles.Top + picTitles.Height + sbStatusBar.Height)
    Else
        VMenu.Height = Me.ScaleHeight - (picTitles.Top + picTitles.Height)
    End If
    Frame2.Height = VMenu.Height
    'grid1.Height = VMenu.Height - 1000
    imgSplitter.Top = VMenu.Top
    imgSplitter.Height = VMenu.Height
End Sub

Private Sub VMenu_MenuItemClick(MenuNumber As Long, MenuItem As Long)
    VMenu.MenuCur = MenuNumber
    VMenu.MenuItemCur = MenuItem
   If VMenu.MenuCur = 1 Then
        grid.Visible = True
        grid1.Visible = False
        todo.Visible = False
        Command3.Visible = True
    ElseIf VMenu.MenuCur = 2 Then
        grid.Visible = False
        grid1.Visible = True
        Command3.Visible = False
        todo.Visible = True
    Else
        Frame2.Visible = False
    End If
    If VMenu.MenuCur = 3 And VMenu.MenuItemCur = 1 Then
        FormConver.Show 1
    End If
    If VMenu.MenuCur = 3 And VMenu.MenuItemCur = 2 Then
        FormGuassZ.Show 1
    End If
    If VMenu.MenuCur = 3 And VMenu.MenuItemCur = 3 Then
        FormGuassF.Show 1
    End If
    If VMenu.MenuCur = 3 And VMenu.MenuItemCur = 4 Then
        FormBaselZ.Show 1
    End If
    If VMenu.MenuCur = 3 And VMenu.MenuItemCur = 5 Then
        FormBaselF.Show 1
    End If
    If VMenu.MenuCur = 3 And VMenu.MenuItemCur = 6 Then
        GuassProjectionZ.Show 1
    End If
    If VMenu.MenuCur = 3 And VMenu.MenuItemCur = 7 Then
        GuassProjectionF.Show 1
    End If
    If VMenu.MenuCur = 1 And VMenu.MenuItemCur = 1 Then
        grid.Visible = True
        grid1.Visible = False
    ElseIf VMenu.MenuCur = 1 And VMenu.MenuItemCur = 2 Then
        Call open_shuizhunshoubo
    ElseIf VMenu.MenuCur = 1 And VMenu.MenuItemCur = 3 Then
        Call save_shuizhunshoubo
    ElseIf VMenu.MenuCur = 2 And VMenu.MenuItemCur = 1 Then
        'grid1.Show
        grid.Visible = False
    ElseIf VMenu.MenuCur = 2 And VMenu.MenuItemCur = 2 Then
        Call open_pingcha
    ElseIf VMenu.MenuCur = 2 And VMenu.MenuItemCur = 3 Then
        Call save_pingcha
    'todo more
    End If
End Sub

Private Sub open_shuizhunshoubo()
'    Dim txt As String
'    Dim i As Integer
'    shuizhunshoubo.ShowOpen
'    If (shuizhunshoubo.FileName <> "") Then
'        Open shuizhunshoubo.FileName For Input As #22
'        'Dim ccc As Integer
'        ccc = 1
'        Do While Not EOF(22)
'        Line Input #22, txt
'        BBmat = Split(txt, ",", -1, 1)
'        ReDim Preserve CCmat(10, ccc)
'        For i = (ccc - 1) To (ccc - 1)
'            For j = 0 To Module1.count(BBmat, "hangshu")
'                CCmat(j, i) = BBmat(j)
'                grid.TextMatrix(i + 6, j + 1) = CCmat(j, i)
'            Next j
'        Next i
'        ccc = ccc + 1
'        Loop
'        'Command3.Enabled = True
'        Close #13
'    Else
'        'todo
'    End If
        shuizhunshoubo.ShowOpen
    mTempFile = shuizhunshoubo.FileName
    DoEvents
    '打开用户选定文件,并处理数据后,添加到输出文件
    Set aExcel = CreateObject("excel.application") '创建EXCEL应用程序对象，启动EXCEL应用程序
    Set aBook = aExcel.Workbooks.open(mTempFile)  '打开工作薄，并将其赋给xbook
    Set aSheet = aBook.Worksheets(1) '将xbook工作薄中的第一个表赋给xsheet
    'Debug.Print aSheet.cells(1, 1), aSheet.cells(1, 2)
    '寻找导入表终点
    Label6.Caption = "正在查找表格内条目数……"
    For mIndex = 3 To 4096
        If aSheet.cells(mIndex, 2) = "" Then
            aEofSheet = mIndex
            Exit For
        End If
    Next
    grid.Rows = aEofSheet + 2
    '将导入表内容输入到最终表
    
    Dim i, j As Long
    mIndex = 0
        For i = 1 To aEofSheet - 4
            For j = 1 To 11
                grid.TextMatrix(i + 5, j) = aSheet.cells(i + 4, j)
                Call grid.Merge(i + 5, 2, i + 5, 3)
                Call grid.Merge(i + 5, 4, i + 5, 5)
                Label6.Caption = "正在将" & mTempFile & "内容导入到" & mXLS & "请稍候......."
            Next
            Label6.Caption = "正在将" & mTempFile & "内容导入到" & mXLS & "请稍候..."

        Next
    
        For i = 6 To grid.Rows - 1
            For j = 2 To 10
                Label6.Caption = " " & mTempFile & "已经导入到" & mXLS & "，正在进行格式匹配，请稍候......"
                grid.row = i
                grid.col = j
               ' .CellFontBold = True
                grid.CellAlignment = 4
                If ((j >= 2 And j <= 5) Or (j >= 7 And j <= 10)) And grid.TextMatrix(i, j) <> "" And grid.TextMatrix(i, j) <> " " Then
                    grid.TextMatrix(i, j) = Round(grid.TextMatrix(i, j), 3)
                Else
                End If
            Next
                Label6.Caption = " " & mTempFile & "已经导入到" & mXLS & "，正在进行格式匹配，请稍候.."
        Next
    Label6.Caption = "数据已经全部导入……"
                      
    aBook.Close
    DoEvents
    
    Set aSheet = Nothing
    Set aBook = Nothing
    Set aExcel = Nothing
    
    ReDim Preserve mOpenFile(mOpenNum)
    mOpenFile(mOpenNum) = shuizhunshoubo.FileName
    mOpenNum = mOpenNum + 1
    
    'Form1!Label6.Caption = "成功将" & mTempFile & "内容导入到" & mXLS & "中。"
    'XlsMsg XlsOpenCD.FileName & "———添加人数为：" & aEofSheet - 1
    
    
    'Form1!Label6.Caption = "执行了取消操作，等待继续操作……"
End Sub
Private Sub save_shuizhunshoubo()
'    Dim i As Integer
'    Dim overwrite As Integer
'    shuizhunshoubo.ShowSave
'    If Dir(shuizhunshoubo.FileName) <> "" Then
'        overwrite = MsgBox("次文件已经存在，是否需要覆盖？", vbOKCancel)
'        If (overwrite = vbOK) Then
'            GoTo save
'        Else
            'todo
'        End If
'    Else
'save:         Open shuizhunshoubo.FileName For Output As #23


'Close #23
'End If
'On Error GoTo mErr

'添加并处理数据EXCEL
'设置打开对话框
    shuizhunshoubo.ShowSave
    Call ConstructXls(shuizhunshoubo.FileName)
   

End Sub
Public Function ConstructXls(ByVal xlsPathName As String) As Boolean
    On Error GoTo mErr
    If Dir(xlsPathName) <> "" Then
        If MsgBox("表格 " & xlsPathName & " 已存在,要删除它吗?" & vbCrLf & "注意:如果不删除将无法继续!", vbYesNo) = vbYes Then Kill xlsPathName Else Exit Function
    End If
    Label6.Caption = "正在建立工作薄和表格……"
    Set mExcel = CreateObject("excel.application") '创建EXCEL应用程序对象，启动EXCEL应用程序
    Set mBook = mExcel.Workbooks.Add '新建一个工作簿，并将其赋给mbook
    Set mSheet = mBook.Worksheets(1) '将mbook工作薄中的第一个表赋给msheet
    mBook.saveas (xlsPathName)
    'x.Visible = True '让EXCEL可视
    mSheet.Columns("A:A").ColumnWidth = 14  '调节第一列的宽度
        mSheet.cells(1, 1) = "水准表格"
        mSheet.cells(2, 1) = "测站编号"
        mSheet.cells(2, 2) = "后尺"
        mSheet.cells(2, 3) = "下丝"
        mSheet.cells(3, 3) = "上丝"
        mSheet.cells(2, 4) = "前尺"
        mSheet.cells(2, 5) = "下丝"
        mSheet.cells(3, 5) = "上丝"
        mSheet.cells(2, 6) = "方向及尺号"
        mSheet.cells(2, 7) = "标尺读数"
        mSheet.cells(4, 7) = "基本分划"
        mSheet.cells(4, 8) = "辅助分划"
        mSheet.cells(2, 9) = "基＋K 减辅"
        mSheet.cells(2, 10) = "高差中数"
        mSheet.cells(4, 2) = "后距"
        mSheet.cells(4, 4) = "前距"
        mSheet.cells(5, 2) = "视距差d"
        mSheet.cells(5, 4) = "视距差累计差D"
        mSheet.cells(2, 11) = "备注"
    Dim i, j As Integer
           For i = 6 To grid.Rows
                For j = 1 To 11
                    mSheet.cells(i, j) = grid.TextMatrix(i, j)
                    Label6.Caption = "正在向工作薄写入数据......"
                 Next j
                 Label6.Caption = "正在向工作薄写入数据.."
            Next i
    DoEvents
    ConstructXls = True
    Label6.Caption = "已经保存完毕！"

mErr:
    If Err.Number = 70 Then
        'If MsgBox("表格 " & xlsPathName & "正在被使用,无法正确删除,要结束调用它的程序后继续吗?" & vbCrLf & "注意:如果选择“是”，将关闭全部的EXCEL程序", vbYesNo) = vbYes Then killEx xlsPathName Else Exit Function
    End If
        Resume Next

End Function

Private Sub open_pingcha()
    pingcha.ShowOpen
    mTempFile = pingcha.FileName
    DoEvents
    '打开用户选定文件,并处理数据后,添加到输出文件
    Set aExcel = CreateObject("excel.application") '创建EXCEL应用程序对象，启动EXCEL应用程序
    Set aBook = aExcel.Workbooks.open(mTempFile)  '打开工作薄，并将其赋给xbook
    Set aSheet = aBook.Worksheets(1) '将xbook工作薄中的第一个表赋给xsheet
    'Debug.Print aSheet.cells(1, 1), aSheet.cells(1, 2)
    '寻找导入表终点
    Label6.Caption = "正在查找表格内条目数……"
    For mIndex = 1 To 4096
        If aSheet.cells(mIndex, 3) = "" Then
            aEofSheet = mIndex
            Exit For
        End If
    Next
    grid1.Rows = aEofSheet + 1
    '将导入表内容输入到最终表
    
    Dim i, j As Long
    mIndex = 0
        For i = 2 To aEofSheet - 1
            For j = 1 To 5
                grid1.TextMatrix(i + 1, j) = aSheet.cells(i, j)
                Label6.Caption = "正在将" & mTempFile & "内容导入到" & mXLS & "请稍候......."
            Next
            Label6.Caption = "正在将" & mTempFile & "内容导入到" & mXLS & "请稍候..."

        Next
    
        For i = 3 To grid1.Rows - 1
            For j = 1 To 5
                Label6.Caption = " " & mTempFile & "已经导入到" & mXLS & "，正在进行格式匹配，请稍候......"
                grid1.row = i
                grid1.col = j
               ' .CellFontBold = True
                grid1.CellAlignment = 4
                If (j = 4 Or j = 5) And grid1.TextMatrix(i, j) <> "" Then
                    grid1.TextMatrix(i, j) = Round(grid1.TextMatrix(i, j), 4)
                Else
                End If
            Next
                Label6.Caption = " " & mTempFile & "已经导入到" & mXLS & "，正在进行格式匹配，请稍候.."
        Next
    Label6.Caption = "数据已经全部导入……"
                      
    aBook.Close
    DoEvents
    
    Set aSheet = Nothing
    Set aBook = Nothing
    Set aExcel = Nothing
    
    ReDim Preserve mOpenFile(mOpenNum)
    mOpenFile(mOpenNum) = shuizhunshoubo.FileName
    mOpenNum = mOpenNum + 1
    
    'Form1!Label6.Caption = "成功将" & mTempFile & "内容导入到" & mXLS & "中。"
    'XlsMsg XlsOpenCD.FileName & "———添加人数为：" & aEofSheet - 1
    
    
    'Form1!Label6.Caption = "执行了取消操作，等待继续操作……"
End Sub

Private Sub save_pingcha()
    pingcha.ShowSave
    xlsPathName = pingcha.FileName
        On Error GoTo mErr
    If Dir(xlsPathName) <> "" Then
        If MsgBox("表格 " & xlsPathName & " 已存在,要删除它吗?" & vbCrLf & "注意:如果不删除将无法继续!", vbYesNo) = vbYes Then Kill xlsPathName Else Exit Sub
    End If
    Label6.Caption = "正在建立工作薄和表格……"
    Set mExcel = CreateObject("excel.application") '创建EXCEL应用程序对象，启动EXCEL应用程序
    Set mBook = mExcel.Workbooks.Add '新建一个工作簿，并将其赋给mbook
    Set mSheet = mBook.Worksheets(1) '将mbook工作薄中的第一个表赋给msheet
    mBook.saveas (xlsPathName)
    'x.Visible = True '让EXCEL可视
    mSheet.Columns("A:A").ColumnWidth = 14  '调节第一列的宽度
        mSheet.cells(1, 1) = "测段号"
        mSheet.cells(1, 2) = "起点"
        mSheet.cells(1, 3) = "终点"
        mSheet.cells(1, 4) = "水平距离"
        mSheet.cells(1, 5) = "高差"
        Dim i, j As Integer
           For i = 3 To grid.Rows
                For j = 1 To 6
                    mSheet.cells(i - 1, j) = grid1.TextMatrix(i, j)
                    Label6.Caption = "正在向工作薄写入数据......"
                 Next j
                 Label6.Caption = "正在向工作薄写入数据.."
            Next i
    DoEvents
    Label6.Caption = "已经保存完毕！"

mErr:
    If Err.Number = 70 Then
        'If MsgBox("表格 " & xlsPathName & "正在被使用,无法正确删除,要结束调用它的程序后继续吗?" & vbCrLf & "注意:如果选择“是”，将关闭全部的EXCEL程序", vbYesNo) = vbYes Then killEx xlsPathName Else Exit Function
    End If
        Resume Next

End Sub
Public Sub mMDir(ByVal mPath As String)
'路径查询,如果不存在则建立目录
If Dir(mPath, vbDirectory) <> "." Then MkDir (mPath)
End Sub