frmmain.frm

该程序是三角网平差程序

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "Mscomctl.ocx"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form FrmMain 
   Caption         =   "三角网平差"
   ClientHeight    =   4485
   ClientLeft      =   165
   ClientTop       =   810
   ClientWidth     =   8055
   LinkTopic       =   "Form1"
   ScaleHeight     =   4485
   ScaleWidth      =   8055
   StartUpPosition =   3  '窗口缺省
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   2040
      Top             =   1680
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin MSComctlLib.Toolbar Toolbar1 
      Align           =   1  'Align Top
      Height          =   420
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   8055
      _ExtentX        =   14208
      _ExtentY        =   741
      ButtonWidth     =   609
      ButtonHeight    =   582
      Appearance      =   1
      ImageList       =   "imlToolbarIcons"
      _Version        =   393216
      BeginProperty Buttons {66833FE8-8583-11D1-B16A-00C0F0283628} 
         NumButtons      =   5
         BeginProperty Button1 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Style           =   3
         EndProperty
         BeginProperty Button2 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Key             =   "保存"
            Object.ToolTipText     =   "保存"
            ImageKey        =   "Save"
         EndProperty
         BeginProperty Button3 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Key             =   "OPENFOLD"
            ImageKey        =   "OPENFOLD"
         EndProperty
         BeginProperty Button4 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Key             =   "打印"
            Object.ToolTipText     =   "打印"
            ImageKey        =   "Print"
         EndProperty
         BeginProperty Button5 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Style           =   3
         EndProperty
      EndProperty
   End
   Begin MSComctlLib.ImageList imlToolbarIcons 
      Left            =   240
      Top             =   1560
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   12632256
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   3
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "FrmMain.frx":0000
            Key             =   "Save"
         EndProperty
         BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "FrmMain.frx":0112
            Key             =   "Print"
         EndProperty
         BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "FrmMain.frx":0224
            Key             =   "OPENFOLD"
         EndProperty
      EndProperty
   End
   Begin MSComctlLib.StatusBar StatusBar1 
      Align           =   2  'Align Bottom
      Height          =   585
      Left            =   0
      TabIndex        =   1
      Top             =   3900
      Width           =   8055
      _ExtentX        =   14208
      _ExtentY        =   1032
      _Version        =   393216
      BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628} 
         NumPanels       =   6
         BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            Alignment       =   1
            Object.Width           =   2646
            MinWidth        =   2646
         EndProperty
         BeginProperty Panel2 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
         EndProperty
         BeginProperty Panel3 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
         EndProperty
         BeginProperty Panel4 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
         EndProperty
         BeginProperty Panel5 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            Style           =   6
            Alignment       =   1
            Object.Width           =   2117
            MinWidth        =   2117
            TextSave        =   "2008-4-8"
         EndProperty
         BeginProperty Panel6 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            Style           =   5
            Alignment       =   1
            Object.Width           =   1412
            MinWidth        =   1412
            TextSave        =   "16:54"
         EndProperty
      EndProperty
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   11.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin VB.Menu MnuProject 
      Caption         =   "项目"
      Begin VB.Menu MnuOpenProject 
         Caption         =   "打开项目"
      End
      Begin VB.Menu MnuNewProject 
         Caption         =   "新项目"
      End
      Begin VB.Menu step1 
         Caption         =   "-"
      End
      Begin VB.Menu MnuSaveProjectAs 
         Caption         =   "另存为"
      End
      Begin VB.Menu MnuCloseProject 
         Caption         =   "关闭"
      End
      Begin VB.Menu step2 
         Caption         =   "-"
      End
      Begin VB.Menu MnuLastProject 
         Caption         =   "最近打开项目"
      End
      Begin VB.Menu MnuExitProject 
         Caption         =   "退出"
      End
   End
   Begin VB.Menu MnuDataInput 
      Caption         =   "数据"
      Begin VB.Menu MnuObsData 
         Caption         =   "观测数据"
      End
   End
   Begin VB.Menu MnuCalc 
      Caption         =   "计算"
      Begin VB.Menu MnuadjustCal 
         Caption         =   "平差计算"
      End
   End
   Begin VB.Menu MnuProjectPrint 
      Caption         =   "报表打印"
   End
End
Attribute VB_Name = "FrmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Private Sub Form_Initialize()
    MnuSaveProjectAs.Enabled = False
    MnuadjustCal.Enabled = False
    MnuCloseProject.Enabled = False
    MnuObsData.Enabled = False
End Sub

Private Sub Form_Load()
Dim ReturnLength As Long, i As Long
     Me.Left = (Screen.Width - Me.Width) / 2
     Me.Top = (Screen.Height - Me.Height) / 2
     FrmMain.MnuLastProject.Caption = GetSetting(App.EXEName, "Startup", "Backup")
     FrmMain.MnuLastProject.Enabled = True
     If FrmMain.MnuLastProject.Caption = "" Then
          FrmMain.MnuLastProject.Caption = "最新项目"
          FrmMain.MnuLastProject.Enabled = False
     End If
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
    Call TrangleClosureError
    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

    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 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
End Sub

Private Sub MnuObsData_Click()
    Load Frmdatainput1
    Frmdatainput1.Show
End Sub



Private Sub MnuOpenproject_Click()
   On Error Resume Next
   
      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
End Sub


Private Sub MnuProjectPrint_Click()
   Frmprint.Show
   
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComCtlLib.Button)
    On Error Resume Next
    Select Case Button.Key
        Case "OPENFOLD"
              MnuNewProject_Click
   
        Case "保存"
            '应做:添加 '保存' 按钮代码。
            MsgBox "添加 '保存' 按钮代码。"
        Case "打印"
            '应做:添加 '打印' 按钮代码。
            MsgBox "添加 '打印' 按钮代码。"
    End Select
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 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