Master 95 #1/MASTER95_1.iso/microsof/vbasic4/vb4-6.cab/vdmdi.frm

Visual Basic Form | 1995-07-26 | 40.0 KB | 1,340 lines

VERSION 4.00
Begin VB.MDIForm frmMDI
   BackColor       =   &H00808000&
   Caption         =   "VisData"
   ClientHeight    =   4140
   ClientLeft      =   1050
   ClientTop       =   1710
   ClientWidth     =   10185
   Height          =   4830
   HelpContextID   =   2016116
   Icon            =   "VDMDI.frx":0000
   Left            =   990
   LinkTopic       =   "MDIForm1"
   LockControls    =   -1  'True
   Top             =   1080
   Width           =   10305
   Begin VB.PictureBox picStatusBar
      Align           =   2  'Align Bottom
      Appearance      =   0  'Flat
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   395
      Left            =   0
      ScaleHeight     =   390
      ScaleWidth      =   10185
      TabIndex        =   13
      TabStop         =   0   'False
      Top             =   3750
      Width           =   10185
      Begin VB.TextBox txtStatusMsg
         BackColor       =   &H8000000F&
         Height          =   285
         Left            =   60
         TabIndex        =   19
         TabStop         =   0   'False
         Text            =   "Ready"
         Top             =   60
         Width           =   10065
      End
   End
   Begin VB.PictureBox picToolBar
      Align           =   1  'Align Top
      Appearance      =   0  'Flat
      ForeColor       =   &H80000008&
      Height          =   735
      Left            =   0
      ScaleHeight     =   715.842
      ScaleMode       =   0  'User
      ScaleWidth      =   10174.6
      TabIndex        =   14
      TabStop         =   0   'False
      Top             =   0
      Width           =   10185
      Begin VB.PictureBox picFormType
         Appearance      =   0  'Flat
         BorderStyle     =   0  'None
         ForeColor       =   &H80000008&
         Height          =   735
         Left            =   3000
         ScaleHeight     =   735
         ScaleWidth      =   2175
         TabIndex        =   15
         TabStop         =   0   'False
         Top             =   0
         Width           =   2175
         Begin VB.OptionButton optDataGrid
            Caption         =   "DBGrid Control"
            Height          =   255
            Left            =   0
            TabIndex        =   6
            Top             =   460
            Width           =   1935
         End
         Begin VB.OptionButton optNoDataCtl
            Caption         =   "No Data Control"
            Height          =   255
            Left            =   0
            TabIndex        =   5
            Top             =   220
            Width           =   1935
         End
         Begin VB.OptionButton optDataCtl
            Caption         =   "Data Control"
            Height          =   255
            Left            =   0
            TabIndex        =   4
            Top             =   0
            Value           =   -1  'True
            Width           =   1575
         End
      End
      Begin VB.PictureBox picRSType
         Appearance      =   0  'Flat
         BackColor       =   &H00C0C0C0&
         BorderStyle     =   0  'None
         ForeColor       =   &H80000008&
         Height          =   735
         Left            =   840
         ScaleHeight     =   735
         ScaleWidth      =   1335
         TabIndex        =   16
         TabStop         =   0   'False
         Top             =   0
         Width           =   1335
         Begin VB.OptionButton optPassThru
            Caption         =   "PassThrough"
            Height          =   255
            Left            =   0
            TabIndex        =   2
            Top             =   460
            Value           =   -1  'True
            Visible         =   0   'False
            Width           =   1350
         End
         Begin VB.OptionButton optTable
            Caption         =   "Table"
            Height          =   255
            Left            =   0
            TabIndex        =   3
            Top             =   460
            Width           =   870
         End
         Begin VB.OptionButton optDynaset
            Caption         =   "Dynaset"
            Height          =   255
            Left            =   0
            TabIndex        =   0
            Top             =   0
            Width           =   1335
         End
         Begin VB.OptionButton optSnapshot
            Caption         =   "Snapshot"
            Height          =   255
            Left            =   0
            TabIndex        =   1
            Top             =   220
            Width           =   1335
         End
      End
      Begin VB.CommandButton cmdBeginTrans
         Caption         =   "BeginTrans"
         Height          =   369
         Left            =   5280
         TabIndex        =   7
         Top             =   0
         Width           =   1695
      End
      Begin VB.CommandButton cmdRollback
         Caption         =   "Rollback"
         Height          =   369
         Left            =   6600
         TabIndex        =   9
         Top             =   0
         Visible         =   0   'False
         Width           =   1335
      End
      Begin VB.CommandButton cmdCommitTrans
         Caption         =   "CommitTrans"
         Height          =   369
         Left            =   5280
         TabIndex        =   8
         Top             =   0
         Visible         =   0   'False
         Width           =   1335
      End
      Begin VB.Line Line1
         X1              =   2339.507
         X2              =   2339.507
         Y1              =   10.154
         Y2              =   680.304
      End
      Begin VB.Label lblToolLabels
         AutoSize        =   -1  'True
         Caption         =   "Type:"
         Height          =   195
         Index           =   3
         Left            =   2400
         TabIndex        =   18
         Top             =   240
         Width           =   405
      End
      Begin VB.Label lblToolLabels
         AutoSize        =   -1  'True
         Caption         =   "Type:"
         Height          =   195
         Index           =   2
         Left            =   45
         TabIndex        =   17
         Top             =   240
         Width           =   405
      End
      Begin MSComDlg.CommonDialog dlgCMD1
         Left            =   8040
         Top             =   240
         _Version        =   65536
         _ExtentX        =   847
         _ExtentY        =   847
         _StockProps     =   0
      End
      Begin VB.Label lblUser
         AutoSize        =   -1  'True
         BorderStyle     =   1  'Fixed Single
         Caption         =   " User: "
         Height          =   225
         Left            =   5280
         TabIndex        =   10
         Top             =   414
         Width           =   495
      End
      Begin VB.Label lblToolLabels
         AutoSize        =   -1  'True
         Caption         =   "Recordset"
         Height          =   195
         Index           =   1
         Left            =   45
         TabIndex        =   11
         Top             =   15
         Width           =   735
      End
      Begin VB.Label lblToolLabels
         AutoSize        =   -1  'True
         Caption         =   "Form"
         Height          =   195
         Index           =   0
         Left            =   2400
         TabIndex        =   12
         Top             =   15
         Width           =   345
      End
   End
   Begin VB.Menu mnuDatabase
      Caption         =   "&File"
      Begin VB.Menu mnuDBOpen
         Caption         =   "&Open DataBase..."
         HelpContextID   =   2016062
         Begin VB.Menu mnuDBOJet
            Caption         =   "&Jet Engine MDB..."
         End
         Begin VB.Menu mnuDBODbase
            Caption         =   "&Dbase"
            Begin VB.Menu mnuDBOdBASE4
               Caption         =   "I&V..."
            End
            Begin VB.Menu mnuDBOdBASE3
               Caption         =   "&III..."
            End
         End
         Begin VB.Menu mnuDBOFoxPro
            Caption         =   "&FoxPro"
            Begin VB.Menu mnuDBOFox26
               Caption         =   "2.&6..."
            End
            Begin VB.Menu mnuDBOFox25
               Caption         =   "2.&5..."
            End
            Begin VB.Menu mnuDBOFox20
               Caption         =   "2.&0..."
            End
         End
         Begin VB.Menu mnuDBOParadox
            Caption         =   "&Paradox"
            Begin VB.Menu mnuDBOParadox4
               Caption         =   "&4.X..."
            End
            Begin VB.Menu mnuDBOParadox3
               Caption         =   "&3.X..."
            End
         End
         Begin VB.Menu mnuDBOBtrieve
            Caption         =   "&Btrieve..."
         End
         Begin VB.Menu mnuDBOExcel
            Caption         =   "&Excel..."
         End
         Begin VB.Menu mnuDBOText
            Caption         =   "&Text Files..."
         End
         Begin VB.Menu mnuDBOODBC
            Caption         =   "&ODBC..."
         End
      End
      Begin VB.Menu mnuDBClose
         Caption         =   "&Close DataBase"
         HelpContextID   =   2016079
         Visible         =   0   'False
      End
      Begin VB.Menu mnuDBWorkspace
         Caption         =   "&Workspace..."
         HelpContextID   =   2016080
      End
      Begin VB.Menu mnuDBErrors
         Caption         =   "&Errors..."
         HelpContextID   =   2016081
      End
      Begin VB.Menu mnuDBProperties
         Caption         =   "&Properties..."
         HelpContextID   =   2016082
         Visible         =   0   'False
         Begin VB.Menu mnuDBPEngine
            Caption         =   "DB&Engine..."
         End
         Begin VB.Menu mnuDBPWorkspace
            Caption         =   "&Workspace..."
         End
         Begin VB.Menu mnuDBPDatabase
            Caption         =   "&Database..."
         End
      End
      Begin VB.Menu mnuDBNew
         Caption         =   "&New..."
         HelpContextID   =   2016083
         Begin VB.Menu mnuDBNJet
            Caption         =   "&Jet Engine MDB"
            Begin VB.Menu mnuDBNJet11
               Caption         =   "Version &1.1 MDB..."
            End
            Begin VB.Menu mnuDBNJet2x
               Caption         =   "Version &2.0 MDB..."
            End
            Begin VB.Menu mnuDBNJet30
               Caption         =   "Version &3.0 MDB..."
            End
         End
         Begin VB.Menu mnuDBNDbase
            Caption         =   "&Dbase"
            Begin VB.Menu mnuDBNdBASE4
               Caption         =   "I&V..."
            End
            Begin VB.Menu mnuDBNdBASE3
               Caption         =   "&III..."
            End
         End
         Begin VB.Menu mnuDBNFoxPro
            Caption         =   "&FoxPro"
            Begin VB.Menu mnuDBNFox26
               Caption         =   "2.&6..."
            End
            Begin VB.Menu mnuDBNFox25
               Caption         =   "2.&5..."
            End
            Begin VB.Menu mnuDBNFox20
               Caption         =   "2.&0..."
            End
         End
         Begin VB.Menu mnuDBNParadox
            Caption         =   "&Paradox"
            Begin VB.Menu mnuDBNParadox4
               Caption         =   "&4.X..."
            End
            Begin VB.Menu mnuDBNParadox3
               Caption         =   "&3.X..."
            End
         End
         Begin VB.Menu mnuDBNBtrieve
            Caption         =   "&Btrieve..."
         End
         Begin VB.Menu mnuDBNODBC
            Caption         =   "&ODBC..."
         End
         Begin VB.Menu mnuDBNText
            Caption         =   "&Text Files..."
         End
      End
      Begin VB.Menu mnuBar1
         Caption         =   "-"
      End
      Begin VB.Menu mnuDBCompact
         Caption         =   "Co&mpact MDB..."
         HelpContextID   =   2016084
         Begin VB.Menu mnuDBC30MDB
            Caption         =   "&3.0 MDB..."
         End
         Begin VB.Menu mnuDBC20MDB
            Caption         =   "&2.0 MDB..."
         End
         Begin VB.Menu mnuDBC11MDB
            Caption         =   "&1.1 MDB..."
         End
      End
      Begin VB.Menu mnuDBRepair
         Caption         =   "&Repair MDB..."
         HelpContextID   =   2016085
      End
      Begin VB.Menu mnuBar2
         Caption         =   "-"
      End
      Begin VB.Menu mnuDBMRU
         Caption         =   "&1"
         Index           =   1
         Visible         =   0   'False
      End
      Begin VB.Menu mnuDBMRU
         Caption         =   "&2"
         Index           =   2
         Visible         =   0   'False
      End
      Begin VB.Menu mnuDBMRU
         Caption         =   "&3"
         Index           =   3
         Visible         =   0   'False
      End
      Begin VB.Menu mnuDBMRU
         Caption         =   "&4"
         Index           =   4
         Visible         =   0   'False
      End
      Begin VB.Menu mnuBarMRU
         Caption         =   "-"
         Visible         =   0   'False
      End
      Begin VB.Menu mnuDBMakeAddIn
         Caption         =   "Make &VisData a VB Add-In"
         HelpContextID   =   2018516
      End
      Begin VB.Menu mnuDBExit
         Caption         =   "E&xit"
      End
   End
   Begin VB.Menu mnuJet
      Caption         =   "&Jet"
      Visible         =   0   'False
      Begin VB.Menu mnuJAttachments
         Caption         =   "&Attachments.."
         HelpContextID   =   2016086
      End
      Begin VB.Menu mnuJRelations
         Caption         =   "&Relations..."
         HelpContextID   =   2016087
      End
      Begin VB.Menu mnuJGroupsUsers
         Caption         =   "&Groups/Users..."
         HelpContextID   =   2016088
      End
      Begin VB.Menu mnuBarJet
         Caption         =   "-"
      End
      Begin VB.Menu mnuJMUSettings
         Caption         =   "&Multiuser Settings..."
         HelpContextID   =   2016089
      End
      Begin VB.Menu mnuJSystemDB
         Caption         =   "&SYSTEM.MDA..."
         HelpContextID   =   2016090
      End
   End
   Begin VB.Menu mnuUtil
      Caption         =   "&Utility"
      Visible         =   0   'False
      Begin VB.Menu mnuUQuery
         Caption         =   "&Query Builder..."
         HelpContextID   =   2016115
      End
      Begin VB.Menu mnuUDataFormDesigner
         Caption         =   "Data &Form Designer..."
         HelpContextID   =   2018517
         Visible         =   0   'False
      End
      Begin VB.Menu mnuUReplace
         Caption         =   "&Global Replace..."
         HelpContextID   =   2016091
      End
      Begin VB.Menu mnuUImpExp
         Caption         =   "&Import/Export..."
         HelpContextID   =   2016092
      End
      Begin VB.Menu mnuUListCombo
         Caption         =   "&DBList/DBCombo View..."
         HelpContextID   =   2016093
      End
      Begin VB.Menu mnuBar3
         Caption         =   "-"
      End
      Begin VB.Menu mnuUCloseAll
         Caption         =   "Close All &Recordset Forms"
         HelpContextID   =   2016094
      End
      Begin VB.Menu mnuUClosePropForms
         Caption         =   "Close All &Property Forms"
         HelpContextID   =   2016094
      End
      Begin VB.Menu mnuUCloseListComboForms
         Caption         =   "Close All DBList/&DBCombo Forms"
         HelpContextID   =   2016094
      End
   End
   Begin VB.Menu mnuPref
      Caption         =   "&Preferences"
      Begin VB.Menu mnuPOpenOnStartup
         Caption         =   "&Open Last DataBase on Startup"
         HelpContextID   =   2016095
      End
      Begin VB.Menu mnuPShowPerf
         Caption         =   "&Show Performance Numbers"
         HelpContextID   =   2016096
      End
      Begin VB.Menu mnuPAllowSys
         Caption         =   "&Include System Tables"
         HelpContextID   =   2016097
      End
      Begin VB.Menu mnuBar4
         Caption         =   "-"
      End
      Begin VB.Menu mnuPQueryTimeout
         Caption         =   "&Query Timeout Value..."
         HelpContextID   =   2016098
      End
      Begin VB.Menu mnuPLoginTimeout
         Caption         =   "&Login Timeout Value..."
         HelpContextID   =   2016099
      End
   End
   Begin VB.Menu mnuWindow
      Caption         =   "&Window"
      HelpContextID   =   2016100
      Begin VB.Menu mnuWTile
         Caption         =   "&Tile"
      End
      Begin VB.Menu mnuWCascade
         Caption         =   "&Cascade"
      End
      Begin VB.Menu mnuWArrange
         Caption         =   "&Arrange Icons"
      End
      Begin VB.Menu mnuBar6
         Caption         =   "-"
      End
      Begin VB.Menu mnuWMDI
         Caption         =   "&Main MDI"
      End
      Begin VB.Menu mnuWTableList
         Caption         =   "Ta&bles"
      End
      Begin VB.Menu mnuWSQL
         Caption         =   "&SQL"
      End
   End
   Begin VB.Menu mnuHelp
      Caption         =   "&Help"
      Begin VB.Menu mnuHContents
         Caption         =   "&Contents..."
      End
      Begin VB.Menu mnuHSearch
         Caption         =   "&Search..."
      End
      Begin VB.Menu mnuBar7
         Caption         =   "-"
      End
      Begin VB.Menu mnuHAbout
         Caption         =   "&About..."
      End
   End
   Begin VB.Menu mnuPopUp
      Caption         =   "PopUp"
      Visible         =   0   'False
      Begin VB.Menu mnuPUProperties
         Caption         =   "Properties..."
      End
      Begin VB.Menu mnuPURename
         Caption         =   "Rename..."
      End
      Begin VB.Menu mnuPUDelete
         Caption         =   "Delete"
      End
      Begin VB.Menu mnuBarPopUp1
         Caption         =   "-"
      End
      Begin VB.Menu mnuPUCopyStruct
         Caption         =   "Copy Structure..."
      End
      Begin VB.Menu mnuPUZap
         Caption         =   "Remove All Records"
         Visible         =   0   'False
      End
      Begin VB.Menu mnuPUPack
         Caption         =   "Pack XBase Table..."
         Enabled         =   0   'False
         Visible         =   0   'False
      End
      Begin VB.Menu mnuPURefresh
         Caption         =   "Refresh List"
      End
   End
Attribute VB_Name = "frmMDI"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Option Compare Binary
Private Sub cmdBeginTrans_Click()
  On Error GoTo BeginErr
  If gbDBOpenFlag = False Then
    MsgBox "No Database Open", 48
    Exit Sub
  End If
  If gdbCurrentDB.Transactions = False Then
    Beep
    MsgBox "Transactions not supported by this Driver!"
    Exit Sub
  End If
  gwsMainWS.BeginTrans
  gbDBChanged = False
  gbTransPending = True
  cmdBeginTrans.Visible = False
  cmdCommitTrans.Visible = True
  cmdRollback.Visible = True
  cmdCommitTrans.SetFocus
  Exit Sub
BeginErr:
  ShowError
  Exit Sub
End Sub
Private Sub cmdCommitTrans_Click()
  On Error GoTo CommitErr
  gwsMainWS.CommitTrans
  gbDBChanged = False
  gbTransPending = False
  cmdBeginTrans.Visible = True
  cmdCommitTrans.Visible = False
  cmdRollback.Visible = False
  cmdBeginTrans.SetFocus
  Exit Sub
CommitErr:
  ShowError
  Exit Sub
End Sub
Private Sub cmdRollback_Click()
  On Error GoTo RollbackErr
  If MsgBox("All changes will be gone, Rollback anyway?", gnMSGBOX_TYPE) = gnMSGBOX_YES Then
    gwsMainWS.Rollback
    gbDBChanged = False
    gbTransPending = False
    cmdBeginTrans.Visible = True
    cmdCommitTrans.Visible = False
    cmdRollback.Visible = False
    cmdBeginTrans.SetFocus
  End If
  Exit Sub
RollbackErr:
  ShowError
  Exit Sub
End Sub
Private Sub lblUser_MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single)
  If Button <> 2 Then Exit Sub
  SetHourglass
  ShowProperties "User", gwsMainWS.Users(gwsMainWS.UserName)
End Sub
Private Sub MDIForm_Resize()
  If Me.WindowState <> vbMinimized Then
    txtStatusMsg.Width = Me.Width - 240
  End If
End Sub
#If Win32 Then
Private Sub mnuDBC30MDB_Click()
  CompactDB dbVersion30
End Sub
#End If
Private Sub mnuDBNJet11_Click()
  NewJetMDB dbVersion11
End Sub
Private Sub mnuDBNJet2x_Click()
  NewJetMDB dbVersion20
End Sub
#If Win32 Then
Private Sub mnuDBNJet30_Click()
  NewJetMDB dbVersion30
End Sub
#End If
Private Sub mnuDBOExcel_Click()
  'we can use Excel 5.0 for all Excel files because
  'the ISAM will figure out the version when
  'it opens file
  gsDataType = gsEXCEL50
  OpenLocalDB False
End Sub
Private Sub mnuHAbout_Click()
  MsgBar "Press any key to Close About Box", False
  frmAboutBox.Show vbModal
  MsgBar gsNULL_STR, False
End Sub
Private Sub mnuDBC20MDB_Click()
  CompactDB dbVersion20
End Sub
Private Sub mnuDBClose_Click()
  CloseCurrentDB
End Sub
Private Sub mnuDBC11MDB_Click()
  CompactDB dbVersion11
End Sub
Private Sub mnuDBErrors_Click()
  On Error Resume Next
  SetHourglass
  RefreshErrors
  Screen.MousePointer = vbDefault
  If Err Then ShowError
End Sub
Private Sub mnuDBExit_Click()
  Unload Me
End Sub
Private Sub mnuDBNBtrieve_Click()
   gsDataType = gsBTRIEVE
   NewLocalISAM
End Sub
Private Sub mnuDBNDbase3_Click()
   gsDataType = gsDBASEIII
   NewLocalISAM
End Sub
Private Sub mnuDBNDbase4_Click()
   gsDataType = gsDBASEIV
   NewLocalISAM
End Sub
Private Sub mnuDBNFox20_Click()
   gsDataType = gsFOXPRO20
   NewLocalISAM
End Sub
Private Sub mnuDBNFox25_Click()
   gsDataType = gsFOXPRO25
   NewLocalISAM
End Sub
Private Sub mnuDBNFox26_Click()
   gsDataType = gsFOXPRO26
   NewLocalISAM
End Sub
Private Sub mnuDBNODBC_Click()
  On Error GoTo DBNErr
  Dim sDriverName As String
  MsgBar "Enter New Database Parameters", False
  'driver must be an valid entry in ODBCINST.INI
  sDriverName = InputBox("Enter Driver Name from ODBCINST.INI File:", "Driver Name", gsDEFAULT_DRIVER)
  DBEngine.RegisterDatabase gsNULL_STR, sDriverName, False, gsNULL_STR
  SendKeys "%FOO"   'force open database dialog
  MsgBar gsNULL_STR, False
  Exit Sub
DBNErr:
  ShowError
  Exit Sub
End Sub
Private Sub mnuDBNParadox3_Click()
   gsDataType = gsPARADOX3X
   NewLocalISAM
End Sub
Private Sub mnuDBNParadox4_Click()
   gsDataType = gsPARADOX4X
   NewLocalISAM
End Sub
Private Sub mnuDBNText_Click()
   gsDataType = gsTEXTFILES
   NewLocalISAM
End Sub
Private Sub mnuDBOJet_Click()
   gsDataType = gsJETMDB
   OpenLocalDB False
End Sub
Private Sub mnuDBOBtrieve_Click()
   gsDataType = gsBTRIEVE
   OpenLocalDB False
End Sub
Private Sub mnuDBODbase3_Click()
   gsDataType = gsDBASEIII
   OpenLocalDB False
End Sub
Private Sub mnuDBODbase4_Click()
   gsDataType = gsDBASEIV
   OpenLocalDB False
End Sub
Private Sub mnuDBOFox20_Click()
   gsDataType = gsFOXPRO20
   OpenLocalDB False
End Sub
Private Sub mnuDBOFox25_Click()
   gsDataType = gsFOXPRO25
   OpenLocalDB False
End Sub
Private Sub mnuDBOFox26_Click()
   gsDataType = gsFOXPRO26
   OpenLocalDB False
End Sub
Private Sub mnuDBOODBC_Click()
   If gbDBOpenFlag = True Then
     Call mnuDBClose_Click
   End If
   If gbDBOpenFlag = True Then
     Beep
     MsgBox "You must Close First!", 48
   Else
     frmOpenDB.Show vbModal
   End If
   If gbDBOpenFlag = True Then
     ShowDBTools
     RefreshTables frmTables.lstTables, True
     MsgBar "NOTE: Use of Attached Tables is the Recommended Method", False
   End If
End Sub
Private Sub mnuDBOParadox3_Click()
   gsDataType = gsPARADOX3X
   OpenLocalDB False
End Sub
Private Sub mnuDBOParadox4_Click()
   gsDataType = gsPARADOX4X
   OpenLocalDB False
End Sub
Private Sub mnuDBOText_Click()
   gsDataType = gsTEXTFILES
   OpenLocalDB False
End Sub
Private Sub mnuDBPDatabase_Click()
  ShowProperties "Database", gdbCurrentDB
End Sub
Private Sub mnuDBPEngine_Click()
  ShowProperties "DBEngine", DBEngine
End Sub
Private Sub mnuDBPWorkspace_Click()
  ShowProperties "Workspace", gwsMainWS
End Sub
Private Sub mnuDBRepair_Click()
  On Error GoTo RepairAccErr
  Dim sNewName As String
  'get file name to repair
  With dlgCMD1
    .Filter = "Jet Engine MDBs (*.mdb)|*.mdb|All Files (*.*)|*.*"
    .DialogTitle = "Open Jet Database to Repair"
    .FilterIndex = 1
    .Flags = FileOpenConstants.cdlOFNHideReadOnly
    .ShowOpen
  End With
  If Len(dlgCMD1.FileName) > 0 Then
    sNewName = dlgCMD1.FileName
  Else
    Exit Sub
  End If
  SetHourglass
  MsgBar "Repairing " & sNewName, True
  DBEngine.RepairDatabase sNewName
  Screen.MousePointer = vbDefault
  MsgBar gsNULL_STR, False
  If MsgBox("Open Repaired Database?", gnMSGBOX_TYPE) = gnMSGBOX_YES Then
    If gbDBOpenFlag = True Then
      Call mnuDBClose_Click
    End If
    gsDataType = gsJETMDB
    gsDBName = sNewName
    OpenLocalDB True
  End If
  If gbDBOpenFlag = True Then
    ShowDBTools
    RefreshTables frmTables.lstTables, True
  End If
  Exit Sub
RepairAccErr:
  If Err <> 32755 Then
    ShowError
  End If
  Exit Sub
End Sub
Private Sub mnuHContents_Click()
  On Error Resume Next
  Dim nRet As Integer
  nRet = OSWinHelp(Me.hwnd, App.HelpFile, HelpConstants.cdlHelpContents, 0)
  If Err Then
    ShowError
  End If
End Sub
Private Sub mnuHSearch_Click()
  On Error Resume Next
  Dim nRet As Integer
  nRet = OSWinHelp(Me.hwnd, App.HelpFile, HelpConstants.cdlHelpPartialKey, 0)
  If Err Then
    ShowError
  End If
End Sub
Private Sub mnuJSystemDB_Click()
  On Error Resume Next
  Dim sTmp As String
  Dim x As Integer
  With dlgCMD1
    .Filter = "SYSTEM.MDA|SYSTEM.MDA"
    .DialogTitle = "Select SYSTEM.MDA (Jet Security File)"
    .FilterIndex = 1
    .FileName = "SYSTEM.MDA"
    .CancelError = True
    .Flags = FileOpenConstants.cdlOFNHideReadOnly + FileOpenConstants.cdlOFNFileMustExist
  End With
  On Error Resume Next
  dlgCMD1.ShowOpen
  If Err = 32755 Then         'user cancelled
    Exit Sub
  Else
    sTmp = dlgCMD1.FileName  'must be a good filename
    SaveSetting "VisData", "Engines\Jet", "SystemDB", sTmp
    SaveSetting "VisData", gsVISDATA4, "LoadSystemDB", "Yes"
  End If
End Sub
Private Sub mnuDBWorkspace_Click()
  On Error GoTo WSErr
  Dim sDBName As String
  Dim sConnect As String
  Dim sUser As String
  If gbDBOpenFlag = True Then
    'save the old settings
    sDBName = gdbCurrentDB.Name
    sConnect = gdbCurrentDB.Connect
    sUser = gwsMainWS.UserName
  End If
  frmLogin.Show vbModal
  lblUser.Caption = " User: " & gwsMainWS.UserName & " "
  'reopen the database if the user changed
  If UCase(sUser) <> UCase(gwsMainWS.UserName) And gbDBOpenFlag = True Then
    'have to close objects that will be invalid after reopening the DB
    CloseAllRecordsets
    CloseAllPropForms
    CloseAllListCombos
    Set gdbCurrentDB = gwsMainWS.OpenDatabase(sDBName, False, gnReadOnly, sConnect)
  End If
  Exit Sub
WSErr:
  ShowError
  If gbDBOpenFlag = True Then
    MsgBox "Current Database must be closed due to the error!", 48
  End If
  Call mnuDBClose_Click
  Exit Sub
End Sub
Private Sub mnuJAttachments_Click()
  On Error Resume Next
  SetHourglass
  frmAttachments.Show
  Screen.MousePointer = vbDefault
  If Err Then ShowError
End Sub
Private Sub mnuJGroupsUsers_Click()
  On Error Resume Next
  If gwsMainWS.Users.Count = 0 Then
    Beep
    MsgBox "No Users found, try 'Jet/System MDA'!", 48
    Exit Sub
  End If
  SetHourglass
  frmGroupsUsers.Show
  Screen.MousePointer = vbDefault
  If Err Then ShowError
End Sub
Private Sub mnuJMUSettings_Click()
  frmMUOptions.Show
End Sub
Private Sub mnuJRelations_Click()
  On Error Resume Next
  SetHourglass
  frmRelations.Show
  Screen.MousePointer = vbDefault
  If Err Then ShowError
End Sub
Private Sub mnuPAllowSys_Click()
  On Error Resume Next
  If gbDBOpenFlag = False Then
    MsgBox "No Database Open", 48
    Exit Sub
  End If
  mnuPAllowSys.Checked = Not mnuPAllowSys.Checked
  RefreshTables frmTables.lstTables, True
End Sub
Private Sub mnuPLoginTimeout_Click()
  On Error GoTo LTErr
  Dim sNewValue As String
  sNewValue = InputBox("Login Timeout is currently " & glLoginTimeout & " seconds." & gsNewLine & "Enter New Value:")
  If Len(sNewValue) = 0 Then Exit Sub
  'try to set the new value
  If Val(sNewValue) >= 0 Then
    glLoginTimeout = Val(sNewValue)
    DBEngine.LoginTimeout = glLoginTimeout
  End If
  Exit Sub
LTErr:
  ShowError
  Exit Sub
End Sub
Private Sub mnuPOpenOnStartup_Click()
  mnuPOpenOnStartup.Checked = Not mnuPOpenOnStartup.Checked
End Sub
Private Sub mnuPQueryTimeout_Click()
  On Error GoTo QTErr
  Dim sNewValue As String
  If gbDBOpenFlag = False Then
    MsgBox "No Database Open", 48
    Exit Sub
  End If
  sNewValue = InputBox("Query Timeout is currently " & gdbCurrentDB.QueryTimeout & " seconds." & gsNewLine & "Enter New Value:")
  If Len(sNewValue) = 0 Then Exit Sub
  'try to set the new value
  gdbCurrentDB.QueryTimeout = Val(sNewValue)
  glQueryTimeout = Val(sNewValue)
  Exit Sub
QTErr:
  ShowError
  'reset the form control after the error
  glQueryTimeout = gdbCurrentDB.QueryTimeout
  Exit Sub
End Sub
Private Sub mnuPShowPerf_Click()
  mnuPShowPerf.Checked = Not mnuPShowPerf.Checked
End Sub
Private Sub mnuUDataFormDesigner_Click()
  On Error Resume Next
  frmDFD.Show vbModal
  If Err Then ShowError
End Sub
Private Sub mnuDBMakeAddIn_Click()
  On Error Resume Next
  Dim sOSVer As String
#If Win16 Then
  sOSVer = "16"
  Dim x As Integer
#Else
  sOSVer = "32"
  Dim x As Long
#End If
  'try to register the VisData add-in stub
  x = Shell(App.Path & "\VDADD" & sOSVer & ".EXE /regserver")
  If Err Then
    MsgBox "See SAMPLES.HLP for instructions.", 48
    Exit Sub
  End If
  'try to register VisData
  x = Shell(App.Path & "\" & App.EXEName & ".EXE /regserver")
  If Err Then
    MsgBox "You must run this from an EXE!", 48
    Exit Sub
  End If
  'only add it if the registration was successful
  x = OSWritePrivateProfileString("Add-Ins" & sOSVer, "VDAddIn.VDAddInClass", "1", "VB.INI")
End Sub
Private Sub mnuUQuery_Click()
  frmQuery.WindowState = 0
End Sub
Private Sub mnuPUCopyStruct_Click()
  On Error Resume Next
  frmCopyStruct.Show vbModal
  If Err Then ShowError
End Sub
Private Sub mnuPUDelete_Click()
  On Error GoTo TblDelErr
  Dim sName As String
  If frmTables.optTables.Value = True Then
    sName = StripConnect(frmTables.lstTables.Text)
    If MsgBox("Delete '" & sName & "' Table?", gnMSGBOX_TYPE) = gnMSGBOX_YES Then
      gdbCurrentDB.TableDefs.Delete sName
      frmTables.lstTables.RemoveItem frmTables.lstTables.ListIndex
      frmTables.lstTables.ListIndex = 0
    End If
  Else
    sName = frmTables.lstQueryDefs.Text
    If MsgBox("Delete '" & sName & "' QueryDef?", gnMSGBOX_TYPE) = gnMSGBOX_YES Then
      gdbCurrentDB.QueryDefs.Delete sName
      frmTables.lstQueryDefs.RemoveItem frmTables.lstQueryDefs.ListIndex
      frmTables.lstQueryDefs.ListIndex = 0
    End If
  End If
  Exit Sub
TblDelErr:
  ShowError
  Exit Sub
End Sub
Private Sub mnuUListCombo_Click()
  On Error Resume Next
  Dim frm As New frmListCombo
  SetHourglass
  frm.Show
  If Err Then ShowError
End Sub
Private Sub mnuPUPack_Click()
  On Error GoTo PackErr
  Dim sTmp As String
  Dim sTblName As String
  Dim i As Integer
  ReDim aIDX(0) As Index
  Dim idx As Index
  sTblName = StripConnect(frmTables.lstTables.Text)
  If MsgBox("Remove All Deleted Records in " & sTblName & "?", gnMSGBOX_TYPE) = gnMSGBOX_YES Then
    SetHourglass
    MsgBar "Packing '" & sTblName & "'", True
    sTmp = gdbCurrentDB.Name & "\"
    If Dir(sTmp & "p_a_c_k.db?") <> gsNULL_STR Then
      Kill sTmp & "p_a_c_k.db?"
    End If
    'save the indexes in an array
    For i = 0 To gdbCurrentDB.TableDefs(sTblName).Indexes.Count - 1
      Set idx = gdbCurrentDB.TableDefs(sTblName).Indexes(i)
      ReDim Preserve aIDX(i + 1)
      i = 1 + 1
      With aIDX(i)
        .Name = idx.Name
        .Fields = idx.Fields
        .Primary = idx.Primary
        .Unique = idx.Unique
      End With
    Next
    'create a new table w/o the deleted records
    gdbCurrentDB.Execute "Select * into p_a_c_k from " & sTblName
    gdbCurrentDB.TableDefs.Delete sTblName
    Name sTmp & "p_a_c_k.dbf" As sTmp & sTblName & ".dbf"
    If Dir(sTmp & "p_a_c_k.dbt") <> gsNULL_STR Then
      Name sTmp & "p_a_c_k.dbt" As sTmp & sTblName & ".dbt"
    End If
    gdbCurrentDB.TableDefs.Refresh
    'add the indexes back
    For i = 0 To UBound(aIDX) - 1
      gdbCurrentDB.TableDefs(sTblName).Indexes.Append aIDX(i)
    Next
    MsgBox "'" & sTblName & "' successfully Packed!", 48
  End If
  Screen.MousePointer = vbDefault
  MsgBar gsNULL_STR, False
  Exit Sub
PackErr:
  ShowError
  Exit Sub
End Sub
Private Sub mnuPUProperties_Click()
  If frmTables.optTables.Value = True Then
    ShowProperties "TableDef", gdbCurrentDB.TableDefs(StripConnect(frmTables.lstTables.Text))
  Else
    ShowProperties "QueryDef", gdbCurrentDB.QueryDefs(frmTables.lstQueryDefs.Text)
  End If
End Sub
Private Sub mnuPURefresh_Click()
  gdbCurrentDB.TableDefs.Refresh
  RefreshTables frmTables.lstTables, True
End Sub
Private Sub mnuPURename_Click()
  On Error GoTo PURErr
  Dim sTmp As String
  Dim oTmp As Object
  'set the name, list and object for the tables or querydefs list item
  If frmTables.optTables.Value = True Then
    sTmp = StripConnect(frmTables.lstTables.Text)
    Set oTmp = gdbCurrentDB.TableDefs(sTmp)
  Else
    sTmp = frmTables.lstQueryDefs.Text
    Set oTmp = gdbCurrentDB.QueryDefs(sTmp)
  End If
GetName:
  'get the name until they enter a new name or press cancel
  sTmp = InputBox("New Name", "Rename " & sTmp, sTmp)
  If Len(sTmp) > 0 Then
    If DupeTableName(sTmp) = False Then
      'okay name so try and rename the object
      oTmp.Name = sTmp
      'must've been successful so we need to refresh the list
      RefreshTables frmTables.lstTables, True
    Else
      'must be a dup that they don't want to delete so
      'give then another chance
      GoTo GetName
    End If
  End If
  Exit Sub
PURErr:
  ShowError
  Exit Sub
End Sub
Private Sub mnuPUZap_Click()
  On Error GoTo ZapErr
  Dim sTblName As String
  sTblName = StripConnect(frmTables.lstTables.Text)
  If MsgBox("Delete All Records in '" & sTblName & "'?", gnMSGBOX_TYPE) = gnMSGBOX_YES Then
    'delete all rows with a sql statement
    If gsDataType = gsSQLDB Then
      gdbCurrentDB.Execute ("delete from " & sTblName), dbSQLPassThrough
    Else
      gdbCurrentDB.Execute ("delete from " & sTblName)
    End If
    If gdbCurrentDB.RecordsAffected > 0 Then
      MsgBox gdbCurrentDB.RecordsAffected & " rows deleted!", 48
      If gbTransPending Then gbDBChanged = True
    End If
  End If
  Exit Sub
ZapErr:
  If Err = gnEOF_ERR Then Resume Next
  ShowError
  Exit Sub
End Sub
Private Sub mnuUCloseAll_Click()
  CloseAllRecordsets
End Sub
Private Sub mnuUClosePropForms_Click()
  CloseAllPropForms
End Sub
Private Sub mnuUCloseListComboForms_Click()
  CloseAllListCombos
End Sub
Private Sub mnuUImpExp_Click()
  On Error Resume Next
  frmImpExp.Show vbModal
  If Err Then ShowError
End Sub
Private Sub mnuUReplace_Click()
  On Error GoTo ReplaceErr
  frmReplace.Show vbModal
  Exit Sub
ReplaceErr:
  ShowError
  Exit Sub
End Sub
Private Sub mnuWArrange_Click()
  Me.Arrange 3
End Sub
Private Sub mnuWCascade_Click()
  Me.Arrange 0
End Sub
Private Sub mnuWSQL_Click()
  frmSQL.WindowState = 0
End Sub
Private Sub mnuWTableList_Click()
  frmTables.WindowState = 0
  If frmTables.lstTables.ListCount = 0 And gbDBOpenFlag = True Then
    RefreshTables frmTables.lstTables, True
  End If
End Sub
Private Sub mnuWTile_Click()
  Me.Arrange 2
End Sub
Private Sub mnuWMDI_Click()
  optDataCtl.SetFocus
End Sub
Private Sub optDataCtl_Click()
  gnFormType = gnDATACTL_FORM
End Sub
Private Sub optDataGrid_Click()
  gnFormType = gnDATAGRID_FORM
End Sub
Private Sub optDynaset_Click()
  gnRecordsetType = vbRSTypeDynaset
End Sub
Private Sub optNoDataCtl_Click()
  gnFormType = gnNODATACTL_FORM
End Sub
Private Sub optPassThru_Click()
  gnRecordsetType = gnRS_PASSTHRU
End Sub
Private Sub optSnapshot_Click()
  gnRecordsetType = vbRSTypeSnapShot
End Sub
Private Sub optTable_Click()
  gnRecordsetType = vbRSTypeTable
End Sub
Private Sub MDIForm_Load()
  On Error GoTo MDILErr
  Dim x As Integer
  gsNewLine = Chr(13) & Chr(10)
  gnMULocking = True   'pessimistic locking by default
  App.HelpFile = App.Path & "\VISDATA.HLP"
  'need to disable Btrieve menu items under 32 bit
  #If Win32 Then
     mnuDBOBtrieve.Visible = False
     mnuDBNBtrieve.Visible = False
  #Else
     mnuDBNJet30.Visible = False
     mnuDBC30MDB.Visible = False
  #End If
  'see if the user previously said no to adding system.mda
  If Len(GetINIString("LoadSystemDB", gsNULL_STR, gsVISDATA4)) = 0 Then
    '1st time so prompt to add it if it is not present
    If MsgBox("Add SYSTEM.MDA (Jet Security File) to INI File?", gnMSGBOX_TYPE) = gnMSGBOX_YES Then
      mnuJSystemDB_Click
    Else
      'store info so we don't keep asking
      SaveSetting "VisData", gsVISDATA4, "LoadSystemDB", "No"
    End If
  End If
  On Error GoTo MDILErr
  'setup the DBEngine
  #If Win32 Then
    DBEngine.IniPath = "HKEY_CURRENT_USER\Software\VB and VBA Program Settings\VisData"
  #Else
    DBEngine.IniPath = "visdata.ini"
  #End If
  DBEngine.DefaultUser = "admin"
  DBEngine.DefaultPassword = gsNULL_STR
  'login to Jet
  On Error Resume Next
  Set gwsMainWS = DBEngine.CreateWorkspace("MainWS", "admin", gsNULL_STR)
  If Err = 3029 Then
    frmLogin.Show vbModal
  ElseIf Err = 3044 Then  'invalid path so system.mda is bogus
    If MsgBox("SYSTEM.MDA Not found, Add one to INI File?", gnMSGBOX_TYPE) = gnMSGBOX_YES Then
      mnuJSystemDB_Click
    Else
      'store info so we don't keep asking
      SaveSetting "VisData", gsVISDATA4, "LoadSystemDB", "No"
      SaveSetting "VisData", "Options", "SystemDB", gsNULL_STR
    End If
  ElseIf Err <> 0 Then
    ShowError
  End If
  lblUser.Caption = " User: " & gwsMainWS.UserName & " "
  On Error GoTo MDILErr
  'add the workspace to the collection to bump the count
  Workspaces.Append gwsMainWS
  LoadINISettings
  Me.Show
  'load the child forms
  frmTables.Show
  frmSQL.Show
  'attempt to open the last database if that option
  'has been set on the preferences menu
  If frmMDI.mnuPOpenOnStartup.Checked = True Then
    If gsDataType = gsSQLDB Then
      'for an ODBC database, we need to
      'sendkeys to open the ODBC dialog
      SendKeys "%FOO{Enter}"
    Else
      OpenLocalDB True
    End If
  End If
  Exit Sub
MDILErr:
  ShowError
  End
End Sub
Private Sub MDIForm_QueryUnload(Cancel As Integer, UnloadMode As Integer)
  On Error Resume Next
  ShutDownVisData
End Sub
Private Sub mnuDBMRU_Click(Index As Integer)
  On Error GoTo MRUErr
  gsDBName = Mid(mnuDBMRU(Index).Caption, 4, Len(mnuDBMRU(Index).Caption))
  gsDataType = mnuDBMRU(Index).Tag
  If UCase(Left(gsDataType, 5)) <> gsSQLDB Then
    OpenLocalDB True
  Else
    'must be an ODBC database so we need to load frmOpenDB
    'this will get the connect parts
    GetODBCConnectParts gsDataType
    'call the routine that will load the form
    mnuDBOODBC_Click
  End If
  Exit Sub
MRUErr:
  ShowError
  Exit Sub
End Sub