frmnewproject.frm

该程序是三角网平差程序

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form FrmNewProject 
   Caption         =   "Form1"
   ClientHeight    =   4485
   ClientLeft      =   60
   ClientTop       =   405
   ClientWidth     =   6450
   LinkTopic       =   "Form1"
   ScaleHeight     =   4485
   ScaleWidth      =   6450
   StartUpPosition =   3  '窗口缺省
   Begin VB.TextBox TxtNewProDir 
      Height          =   375
      Left            =   2040
      TabIndex        =   4
      Top             =   600
      Width           =   2895
   End
   Begin VB.CommandButton CmdView 
      Caption         =   "......................"
      Height          =   375
      Left            =   5160
      TabIndex        =   3
      Top             =   600
      Width           =   495
   End
   Begin VB.CommandButton CmdNewProCreate 
      Caption         =   "创建新项目"
      Default         =   -1  'True
      Height          =   495
      Left            =   2040
      TabIndex        =   0
      Top             =   2880
      Width           =   1215
   End
   Begin VB.CommandButton CmdExit 
      Caption         =   "退出"
      Height          =   495
      Left            =   4560
      TabIndex        =   1
      Top             =   2880
      Width           =   1215
   End
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   480
      Top             =   2280
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.Label LblNewProDir 
      Caption         =   "输入项目名（包括盘符和文件夹)"
      Height          =   495
      Left            =   360
      TabIndex        =   5
      Top             =   600
      Width           =   1455
   End
   Begin VB.Label LblProNewProject 
      Caption         =   "检查上述内容输入准确无误，按创建新项目按钮"
      Height          =   615
      Left            =   600
      TabIndex        =   2
      Top             =   2880
      Width           =   1335
   End
End
Attribute VB_Name = "FrmNewProject"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub Form_Load()
      Me.Left = (Screen.Width - Me.Width) / 2
      Me.Top = (Screen.Height - Me.Height) / 2
End Sub
Private Sub CmdView_Click()
    CommonDialog1.CancelError = True
    On Error GoTo errhandler
    CommonDialog1.Flags = cdlOFNHideReadOnly
    CommonDialog1.Filter = "Project(*.Mdb)|*.Mdb"
    CommonDialog1.FilterIndex = 1
    CommonDialog1.ShowOpen
    TxtNewProDir.Text = CommonDialog1.FileName
errhandler:
End Sub
'Private Sub TxtNewProDir_Change()
' g_projectfile = TxtNewProDir.Text
'End Sub
Private Sub CmdExit_Click()
 Unload FrmNewProject
End Sub

'创建新工程
Private Sub CmdNewProCreate_Click()
  Dim Drive1 As String
  
  Dim Drive2 As String
  Dim Drive3 As String
  Dim path1 As String
  Dim sum As Integer
  Dim i As Long
  Dim J As Long
  g_projectfile = TxtNewProDir.Text
  For i = 1 To Len(g_projectfile)
     If Left$(Right$(g_projectfile, i), 1) = "\" Then
        J = i
        GoTo lll
     End If
  Next i
lll:
  g_ProDir = Left(g_projectfile, Len(g_projectfile) - J)
  If Right$(g_ProDir, 1) <> "\" Then
  Else
    g_ProDir = Left(g_ProDir, Len(g_ProDir) - 1)
  End If
  Drive1 = Left$(UCase$(g_ProDir), 3)
  Drive2 = Left$(CurDir$, 3)
  path1 = Mid$(g_ProDir, 3)
  If Not (Drive1 = "C:\" Or Drive1 = "D:\" Or Drive1 = "E:\") Then
       MsgBox "没有盘符名,请重输!"
    Exit Sub
  End If
  If path1 = "" Then
       MsgBox "没有文件夹名，请重输!"
       Exit Sub
  End If
  If Right$(UCase(g_projectfile), 4) <> ".MDB" Then
        If Left$(Right$(g_ProDir, 4), 1) <> "." Then
                g_projectfile = g_projectfile & ".Mdb"
             Else
                MsgBox "项目的扩展名名必须是“ Mdb”,请重输 !"
                Exit Sub
         End If
  End If
  If Drive1 <> Drive2 Then
     ChDrive Drive1
  End If
  If Direxists(path1) Then
  Else
     MkDir path1
  End If
  Call DB_T_Def(i)
  If i <> 0 Then
    MsgBox "Error In DataBase"
    Unload Me
    Exit Sub
  End If
  FrmMain.Caption = g_projectfile
  FrmMain.MnuNewProject.Enabled = False
  FrmMain.MnuOpenProject.Enabled = False
  FrmMain.MnuSaveProjectAs.Enabled = True
  FrmMain.MnuCloseProject.Enabled = True
  FrmMain.MnuObsData.Enabled = True
  FrmMain.MnuadjustCal.Enabled = True
'  FrmMain.MnuViewObsData.Enabled = True
'  FrmMain.MnuViewResult.Enabled = True
'  FrmMain.MenuReportPrn.Enabled = True
   Unload Me
 End Sub
Function Direxists(path As String) As Boolean
    On Error Resume Next
    Direxists = (Dir$(path & "\nul") <> "")
End Function