frmmain.frm

来自「对ACCESS数据库的数据根据用户的选择做简单分类」· FRM 代码 · 共 359 行

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.MDIForm frmMain 
   BackColor       =   &H8000000C&
   Caption         =   "工程1"
   ClientHeight    =   3480
   ClientLeft      =   165
   ClientTop       =   735
   ClientWidth     =   6795
   LinkTopic       =   "MDIForm1"
   StartUpPosition =   3  '窗口缺省
   Begin MSComDlg.CommonDialog dlgDatabase 
      Left            =   3000
      Top             =   1920
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin MSComctlLib.StatusBar sbStatusBar 
      Align           =   2  'Align Bottom
      Height          =   270
      Left            =   0
      TabIndex        =   0
      Top             =   3210
      Width           =   6795
      _ExtentX        =   11986
      _ExtentY        =   476
      _Version        =   393216
      BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628} 
         NumPanels       =   3
         BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            AutoSize        =   1
            Object.Width           =   6297
            Text            =   "状态"
            TextSave        =   "状态"
         EndProperty
         BeginProperty Panel2 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            Style           =   6
            AutoSize        =   2
            TextSave        =   "02-3-13"
         EndProperty
         BeginProperty Panel3 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            Style           =   5
            AutoSize        =   2
            TextSave        =   "22:07"
         EndProperty
      EndProperty
   End
   Begin MSComctlLib.ImageList imlToolbarIcons 
      Left            =   2160
      Top             =   1320
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   12632256
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   13
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmMain.frx":0000
            Key             =   "New"
         EndProperty
         BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmMain.frx":0112
            Key             =   "Open"
         EndProperty
         BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmMain.frx":0224
            Key             =   "Save"
         EndProperty
         BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmMain.frx":0336
            Key             =   "Print"
         EndProperty
         BeginProperty ListImage5 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmMain.frx":0448
            Key             =   "Cut"
         EndProperty
         BeginProperty ListImage6 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmMain.frx":055A
            Key             =   "Copy"
         EndProperty
         BeginProperty ListImage7 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmMain.frx":066C
            Key             =   "Paste"
         EndProperty
         BeginProperty ListImage8 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmMain.frx":077E
            Key             =   "Bold"
         EndProperty
         BeginProperty ListImage9 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmMain.frx":0890
            Key             =   "Italic"
         EndProperty
         BeginProperty ListImage10 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmMain.frx":09A2
            Key             =   "Underline"
         EndProperty
         BeginProperty ListImage11 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmMain.frx":0AB4
            Key             =   "Align Left"
         EndProperty
         BeginProperty ListImage12 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmMain.frx":0BC6
            Key             =   "Center"
         EndProperty
         BeginProperty ListImage13 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmMain.frx":0CD8
            Key             =   "Align Right"
         EndProperty
      EndProperty
   End
   Begin VB.Menu mnuFile 
      Caption         =   "文件(&F)"
      Begin VB.Menu mnuFileOpen 
         Caption         =   "打开数据库文件(&O)"
      End
      Begin VB.Menu mnuFileNew 
         Caption         =   "新数据库(&N)"
         Enabled         =   0   'False
      End
      Begin VB.Menu mnuFileSaveAs 
         Caption         =   "另存数据库(&A)"
         Enabled         =   0   'False
      End
      Begin VB.Menu Bar1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileExit 
         Caption         =   "退出(&X)"
      End
   End
   Begin VB.Menu mnuP 
      Caption         =   "最优分类(&P)"
      Begin VB.Menu frmPW 
         Caption         =   "三麦油菜(&W)"
      End
   End
   Begin VB.Menu mnuO 
      Caption         =   "输出(&O)"
      Begin VB.Menu frmOW 
         Caption         =   "WORD文件(&W)"
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "帮助(&H)"
      Begin VB.Menu mnuAbout 
         Caption         =   "关于帮助(&A)"
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Const EM_UNDO = &HC7

Private Declare Function OSWinHelp% Lib "user32" Alias "WinHelpA" (ByVal hwnd&, ByVal HelpFile$, ByVal wCommand%, dwData As Any)

Option Explicit


Private Sub frmIUM_Click()
    On Error GoTo ErrorExit
        WhichTable = "IUM"
        frmAREA_R.Show
        Me.Enabled = False
        
ErrorExit:
End Sub

Private Sub frmOW_Click()
    On Error GoTo ErrorExit
        frmWOPCL_P.Show
        Me.Enabled = False
        
ErrorExit:
End Sub

Private Sub frmPW_Click()
    On Error GoTo ErrorExit
        frmWOPCL_M.Show
        Me.Enabled = False
        
ErrorExit:
End Sub

Private Sub mnuAbout_Click()
        frmAbout.Show
        Me.Enabled = False
End Sub
Private Sub mnuFileExit_click()
     End
End Sub

Private Sub mnuFileNew_Click()
'根据已经打开的数据库文件建立一个新的数据库文件，文件的结构与打开的文件一样
     Dim NewDatabase As String, sFile As String
     Dim dbsSrc As Database
    ' On Error GoTo HandleError
   
     With dlgDatabase
            .DialogTitle = "新文件"
            .CancelError = False
            'ToDo: 设置 common dialog 控件的标志和属性
            .Filter = "Database files (*.mdb)|*.mdb" '|All files (*.*)|*.*"
            .ShowOpen
            If Len(.FileName) = 0 Then
                Exit Sub
            End If
            NewDatabase = .FileName
     End With
     
     If Dir(NewDatabase) <> "" Then
          MsgBox NewDatabase & "已经存在！"
          Exit Sub
     End If
     
     CopyDatabase gstNewdatabase, NewDatabase
     
     
'display Main form
       frmMain.Show
SubExit:
       Exit Sub
HandleError:
       Select Case Err.Number
           Case 3004, 3024, 3044
               If gstNewdatabase = "" Then
                   MsgBox "No database was selected.", vbExclamation, " Database Error "
                 Else
                   Set db = OpenDatabase(gstNewdatabase)  'new database location
                   Resume 'open the database
                End If
             Case Else

                  MsgBox Err.Description, vbOKOnly + vbExclamation, " UnexPected Error "
                  End ' exit the project
             End Select
End Sub

Private Sub mnuFileOpen_Click()
' Select a different database (FBE)
     On Error GoTo HandleError

     With frmMain.dlgDatabase
           .FileName = gstNewdatabase
           .Filter = "Database files (*.mdb)|*.mdb|All files (*.*)|*.*"
          ' if err0r encountered, skip next comand
            On Error Resume Next
            .ShowOpen
            If Err.Number = cdlCancel Then
                gstNewdatabase = ""
              Else
' set return filename to selected file
                gstNewdatabase = .FileName
                frmMain.Caption = .FileTitle & " Database"
            End If
     End With
       
     If gstNewdatabase <> "" Then
         mnuFileSaveAs.Enabled = True
         mnuFileNew.Enabled = True
     End If
     
'display Main fom
       frmMain.Show
SubExit:
       Exit Sub
HandleError:
       Select Case Err.Number
           Case 3004, 3024, 3044
               If gstNewdatabase = "" Then
                   MsgBox "No database was selected.", vbExclamation, " Database Error "
                 Else
                   Set db = OpenDatabase(gstNewdatabase)  'new database location
                   Resume 'open the database
                End If
             Case Else

                  MsgBox Err.Description, vbOKOnly + vbExclamation, " UnexPected Error "
                  End ' exit the project
             End Select
End Sub

Private Sub MDIForm_Load()
    Me.Left = GetSetting(App.Title, "Settings", "MainLeft", 1000)
    Me.Top = GetSetting(App.Title, "Settings", "MainTop", 1000)
    Me.Width = GetSetting(App.Title, "Settings", "MainWidth", 12500)
    Me.Height = GetSetting(App.Title, "Settings", "MainHeight", 8500)
    gstNewdatabase = ""
End Sub
Private Sub MDIForm_Unload(Cancel As Integer)
    If Me.WindowState <> vbMinimized Then
        SaveSetting App.Title, "Settings", "MainLeft", Me.Left
        SaveSetting App.Title, "Settings", "MainTop", Me.Top
        SaveSetting App.Title, "Settings", "MainWidth", Me.Width
        SaveSetting App.Title, "Settings", "MainHeight", Me.Height
    End If
End Sub

Private Sub mnuFileSaveAs_Click()
     Dim NewDatabase As String, iResp As Integer, stMsg As String
     
    ' On Error GoTo HandleError

     With dlgDatabase
      '     .FileName = gstNewdatabase
           .Filter = "Database files (*.mdb)" '|*.mdb|All files (*.*)|*.*"
          ' if err0r encountered, skip next comand
            On Error Resume Next
            .ShowSave
            NewDatabase = .FileName
            frmMain.Caption = .FileTitle & " Database"
          
     End With
     
     If NewDatabase = "" Then GoTo SubExit
     
     If Dir(NewDatabase) <> "" Then
           stMsg = NewDatabase & "已经存在，覆盖它吗?"
           iResp = MsgBox(stMsg, vbYesNo + vbQuestion, "选择数据库")
 
           If iResp = vbNo Then
                  NewDatabase = ""
                  GoTo SubExit
           End If
     End If
     
     CopyDatabase gstNewdatabase, NewDatabase
     CopyData gstNewdatabase, NewDatabase
     
'display Main fom
       frmMain.Show
SubExit:
       Exit Sub
HandleError:
       Select Case Err.Number
           Case 3004, 3024, 3044
               If gstNewdatabase = "" Then
                   MsgBox "No database was selected.", vbExclamation, " Database Error "
                 Else
                   Set db = OpenDatabase(gstNewdatabase)  'new database location
                   Resume 'open the database
                End If
             Case Else

                  MsgBox Err.Description, vbOKOnly + vbExclamation, " UnexPected Error "
                  End ' exit the project
             End Select
End Sub