frmmain.frm

此程序为水准网平差

    Load FrmPrint
    FrmPrint.Show
End Sub

Private Sub MnuAdjustCal_Click()
    If g_ProjectFile = "" Then
        MsgBox "项目没有打开。", , "提示信息！"
        Exit Sub
    End If
    If g_Info1 = 0 Then
        MsgBox "必须先输完观测数据！", , "信息提示!"
       Exit Sub
    End If
    Call TakeValue
'    On Error GoTo Bottum
    Call Lev_Adjust
    g_Info2 = 1
    Set arecord = g_d_Base.OpenRecordset("信息表", dbOpenTable)
        With arecord
           .Edit
           .Fields(1) = 1
           .Update
           .Close
        End With
        StatusBar1.Panels(2).Text = "平差计算已完成"
End Sub

Private Sub MnuCloseProject_Click()
Dim nTemp As Integer
Dim sTemp As String
  If g_ProjectFile = "" Then
    MsgBox "项目没有打开。", , "提示信息！"
    Exit Sub
End If

  sTemp = "你真的想关闭当前工程吗？"
  nTemp = MsgBox(sTemp, vbYesNo, "信息提示!")
  If nTemp = vbYes Then
      If g_ProjectFile <> "" Then
          SaveSetting App.EXEName, "Startup", "Backup", g_ProjectFile
          g_d_Base.Close
          g_MyWs.Close
          Set g_d_Base = Nothing
          Set g_MyWs = Nothing
          FrmMain.Caption = ""
          g_ProjectFile = ""
       End If
       StatusBar1.Panels(1).Text = ""
       StatusBar1.Panels(2).Text = ""
       FrmMain.MnuNewProject.Enabled = True
       FrmMain.MnuOpenProject.Enabled = True
       MnuSaveProjectAs.Enabled = False
       MnuCloseProject.Enabled = False
       MnuObsData.Enabled = False
       MnuAdjustCal.Enabled = False
       MnuViewObsData.Enabled = False
       MnuViewResult.Enabled = False
       MenuReportPrn.Enabled = False
    End If
End Sub

Private Sub MnuExitProject_Click()
  Dim nTemp As Integer
  Dim sTemp As String
  sTemp = "你真的想退出吗？"
  nTemp = MsgBox(sTemp, vbYesNo, "信息提示!")
  If nTemp = vbYes Then
      If g_ProjectFile <> "" Then
          SaveSetting App.EXEName, "Startup", "Backup", g_ProjectFile
          g_d_Base.Close
          g_MyWs.Close
          Set g_d_Base = Nothing
          Set g_MyWs = Nothing
       End If
       End
  End If
End Sub


Private Sub mnuHelpAbout_Click()
    FrmAbout.Show
End Sub

Private Sub mnuHelpTopics_Click()
      Const HelpCNT = &HB
      CommonDialog1.HelpFile = App.path & "\Lev_Adj_help.hlp"
      CommonDialog1.HelpCommand = HelpCNT Or cdlHelpSetContents
      CommonDialog1.ShowHelp
      
End Sub

Private Sub MnuLastProject_Click()
Dim TmpFile As String, Reply As String
Dim arecord As Recordset

    If g_ProjectFile <> "" Then
        Reply = "项目 " + g_ProjectFile + " 已经打开！"
        MsgBox Reply, , "信息提示!"
        Exit Sub
    End If

    TmpFile = GetSetting(App.EXEName, "Startup", "Backup")
    
    If Dir(TmpFile) = "" Then
            MsgBox "文件" + TmpFile + "不存在！", , "信息提示!"
            Exit Sub
    End If
        
        If FileLen(TmpFile) <= 0 Then
            MsgBox "文件" + TmpFile + "不存在！", , "信息提示!"
            Exit Sub
        End If
    
    g_ProjectFile = TmpFile
    Set g_MyWs = DBEngine.Workspaces(0)
    Set g_d_Base = g_MyWs.OpenDatabase(g_ProjectFile)
    Me.Caption = g_ProjectFile
    Set arecord = g_d_Base.OpenRecordset("项目信息表", dbOpenTable)
    With arecord
        .MoveFirst
        g_ProDir = .Fields(0)
    End With
    arecord.Close
     '将该项目的基本信息取出
    Set arecord = g_d_Base.OpenRecordset("信息表", dbOpenTable)
    With arecord
        .MoveFirst
        g_Info1 = .Fields(0)
        g_Info2 = .Fields(1)
    End With
    arecord.Close
    If g_Info1 = 1 Then
       StatusBar1.Panels(1).Text = "观测数据已完成"
'       Call TakeValue
    End If
    If g_Info2 = 1 Then
       StatusBar1.Panels(2).Text = "平差计算已完成"
    End If
    FrmMain.MnuNewProject.Enabled = False
    FrmMain.MnuOpenProject.Enabled = False
    MnuSaveProjectAs.Enabled = True
    MnuCloseProject.Enabled = True
    MnuObsData.Enabled = True
    MnuAdjustCal.Enabled = True
    MnuViewObsData.Enabled = True
    MnuViewResult.Enabled = True
    MenuReportPrn.Enabled = True
    
End Sub

Private Sub MnuNewProject_Click()
    Dim Reply As String
    Dim i As Integer
    If g_ProjectFile <> "" Then
      Reply = "项目 " + g_ProjectFile + " 已经打开，关闭或保存后再新建！"
      MsgBox Reply, , "信息提示!"
      Exit Sub
    End If
    Load FrmNewProject
    FrmNewProject.Show
End Sub
Private Sub MnuOpenProject_Click()
    Dim Reply As String
    Dim i As Integer
    Dim arecord As Recordset
    Reply = "项目 " & g_ProjectFile + " 已经打开，关闭或退出后再打开其它项目！"
    If g_ProjectFile <> "" Then
        MsgBox Reply, , "提示信息"
        Exit Sub
    End If
    CommonDialog1.CancelError = True
    CommonDialog1.Flags = cdlOFNHideReadOnly
    CommonDialog1.Filter = "工程 (*.Mdb)|*.Mdb"
    CommonDialog1.FilterIndex = 1
    CommonDialog1.ShowOpen
    g_ProjectFile = CommonDialog1.FileName
    If Dir(g_ProjectFile) = "" Or Len(g_ProjectFile) = 0 Then
        MsgBox ("项目不存在!")
        Exit Sub
    End If
    Set g_MyWs = DBEngine.Workspaces(0)
    Set g_d_Base = g_MyWs.OpenDatabase(g_ProjectFile)
    FrmMain.Caption = g_ProjectFile
    Set arecord = g_d_Base.OpenRecordset("项目信息表", dbOpenTable)
    With arecord
        .MoveFirst
        g_ProDir = .Fields(0)
    End With
    arecord.Close
    '将该项目的信息取出
    Set arecord = g_d_Base.OpenRecordset("信息表", dbOpenTable)
    With arecord
        .MoveFirst
        g_Info1 = .Fields(0)
        g_Info2 = .Fields(1)
    End With
    arecord.Close
    If g_Info1 = 1 Then
       StatusBar1.Panels(1).Text = "观测数据已完成"
     End If
    If g_Info2 = 1 Then
       StatusBar1.Panels(2).Text = "平差计算已完成"
    End If
'    Call TakeValue
    FrmMain.MnuNewProject.Enabled = False
    FrmMain.MnuOpenProject.Enabled = False
    MnuSaveProjectAs.Enabled = True
    MnuCloseProject.Enabled = True
    MnuObsData.Enabled = True
    MnuAdjustCal.Enabled = True
    MnuViewObsData.Enabled = True
    MnuViewResult.Enabled = True
    MenuReportPrn.Enabled = True
   Exit Sub
End Sub


Private Sub MnuObsData_Click()
    Load FrmVerDataInput1
    FrmVerDataInput1.Show
End Sub
Private Sub MnuSaveProjectAs_Click()
Dim TmpFile As String, Reply As String

If g_ProjectFile = "" Then
    MsgBox "项目没有打开。", , "提示信息！"
    Exit Sub
End If

CommonDialog1.CancelError = True
On Error GoTo errhandler

CommonDialog1.Flags = cdlOFNHideReadOnly

CommonDialog1.Filter = "工程 (*.Mdb)|*.Mdb"

CommonDialog1.FilterIndex = 1

CommonDialog1.ShowOpen
    
    TmpFile = CommonDialog1.FileName
    
    If Trim(UCase(TmpFile)) = Trim(UCase(g_ProjectFile)) Then Exit Sub
    If Dir(TmpFile) <> "" Then
        Reply = MsgBox("项目" + TmpFile + "已存在! 覆盖吗?", vbYesNo + vbCritical + vbDefaultButton2)
        If Reply = vbYes Then
            Kill TmpFile
        Else
            Exit Sub
        End If
    End If
    g_d_Base.Close
    g_MyWs.Close
    Set g_d_Base = Nothing
    Set g_MyWs = Nothing
     FileCopy g_ProjectFile, TmpFile
    g_ProjectFile = TmpFile
    Set g_MyWs = DBEngine.Workspaces(0)
    Set g_d_Base = g_MyWs.OpenDatabase(g_ProjectFile)
    Me.Caption = g_ProjectFile
    Exit Sub
errhandler:
End Sub

Private Sub MnuViewObsData_Click()
If g_ProjectFile = "" Then
        MsgBox "项目没有打开。", , "提示信息！"
        Exit Sub
    End If
    If g_Info1 = 0 Then
        MsgBox "必须先输观测数据！", , "信息提示!"
       Exit Sub
    End If
'    If g_Info2 = 0 Then
'        MsgBox "必须先进行平差计算！", , "信息提示!"
'       Exit Sub
'    End If
    g_ModifyType = 1
    Load frmModify
    frmModify.Show
End Sub

Private Sub MnuViewResult_Click()
    If g_ProjectFile = "" Then
        MsgBox "项目没有打开。", , "提示信息！"
        Exit Sub
    End If
    If g_Info1 = 0 Then
        MsgBox "必须先输观测数据！", , "信息提示!"
       Exit Sub
    End If
    If g_Info2 = 0 Then
        MsgBox "必须先进行平差计算！", , "信息提示!"
       Exit Sub
    End If
    g_ModifyType = 2
    Load frmModify
    frmModify.Show
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
     Select Case Button.Key
        Case "New"
             MnuNewProject_Click
        Case "Open"
             MnuOpenProject_Click
        Case "SaveAs"
             MnuSaveProjectAs_Click
        Case "Close"
             MnuCloseProject_Click
        Case "Exit"
             MnuExitProject_Click
        Case "Calculate"
             MnuAdjustCal_Click
        Case "View"
             MnuViewResult_Click
        Case "Print"
             MenuReportPrn_Click
     End Select
End Sub