frmnewproject.frm

三角形闭合差计算程序

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form frmnewproject 
   Caption         =   "新项目建立"
   ClientHeight    =   5025
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   7905
   LinkTopic       =   "Form2"
   ScaleHeight     =   5025
   ScaleWidth      =   7905
   StartUpPosition =   3  '窗口缺省
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   960
      Top             =   1920
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton CmdView 
      Caption         =   "浏览"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   12
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   6480
      TabIndex        =   5
      Top             =   600
      Width           =   735
   End
   Begin VB.CommandButton CmdExit 
      Caption         =   "退出"
      Height          =   735
      Left            =   5280
      TabIndex        =   3
      Top             =   3480
      Width           =   1575
   End
   Begin VB.CommandButton CmdNewProCreate 
      Caption         =   "创建新项目"
      Height          =   735
      Left            =   2760
      TabIndex        =   2
      Top             =   3480
      Width           =   1455
   End
   Begin VB.TextBox TxtNewProDir 
      Height          =   375
      Left            =   1920
      TabIndex        =   1
      Top             =   600
      Width           =   4335
   End
   Begin VB.Label LblProNewProject 
      Caption         =   "检查上述内容输入准确无误，按创建新项目按钮"
      Height          =   855
      Left            =   360
      TabIndex        =   4
      Top             =   3480
      Width           =   1695
   End
   Begin VB.Label LblNewProDir 
      Caption         =   "输入项目名（包括盘符和文件夹):"
      Height          =   855
      Left            =   360
      TabIndex        =   0
      Top             =   600
      Width           =   1095
   End
End
Attribute VB_Name = "frmnewproject"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim wgridcol As Integer
Dim wgridrow As Integer
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
  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:\" Or Drive1 = "F:\") 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 D(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.MnuReportPrint.Enabled = True
   Unload Me
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 Form_Load()
      Me.Left = (Screen.Width - Me.Width) / 2
      Me.Top = (Screen.Height - Me.Height) / 2
End Sub

Function Direxists(path As String) As Boolean
    On Error Resume Next
    Direxists = (Dir$(path & "\nul") <> "")
End Function
Private Sub TxtNewProDir_Change()
    g_ProjectFile = TxtNewProDir.Text
End Sub
Private Sub Cmdexit_Click()
    Unload frmnewproject
End Sub