Internet Publisher's Toolbox 1.0/Image.iso/toolbox/httpdsrv/vbs31src/vdmdi.frm

Visual Basic Form | 1994-12-29 | 37.7 KB | 1,242 lines

VERSION 2.00
Begin MDIForm VDMDI
   Caption         =   "Visual Data"
   ClientHeight    =   6210
   ClientLeft      =   240
   ClientTop       =   1710
   ClientWidth     =   9015
   Height          =   6900
   Icon            =   VDMDI.FRX:0000
   Left            =   180
   LinkTopic       =   "MDIForm1"
   Top             =   1080
   Width           =   9135
   Begin PictureBox Picture1
      Align           =   2  'Align Bottom
      BackColor       =   &H00C0C0C0&
      Height          =   240
      Left            =   0
      ScaleHeight     =   210
      ScaleWidth      =   8985
      TabIndex        =   6
      Top             =   5970
      Width           =   9015
      Begin CommonDialog CMD1
         Left            =   8085
         Top             =   0
      End
      Begin Label cMsg
         BackColor       =   &H00C0C0C0&
         Caption         =   "Ready"
         Height          =   200
         Left            =   120
         TabIndex        =   7
         Top             =   0
         Width           =   9372
      End
   End
   Begin PictureBox ToolBar
      Align           =   1  'Align Top
      BackColor       =   &H00C0C0C0&
      Height          =   360
      Left            =   0
      ScaleHeight     =   335.077
      ScaleMode       =   0  'User
      ScaleWidth      =   9002.344
      TabIndex        =   0
      TabStop         =   0   'False
      Top             =   0
      Visible         =   0   'False
      Width           =   9015
      Begin OptionButton cDataCtl
         BackColor       =   &H00C0C0C0&
         Caption         =   "Data Control"
         Height          =   255
         Left            =   2160
         TabIndex        =   8
         Top             =   30
         Value           =   -1  'True
         Width           =   1545
      End
      Begin CommandButton BeginButton
         Caption         =   "BeginTransaction"
         Height          =   336
         Left            =   6930
         TabIndex        =   5
         Top             =   0
         Width           =   1812
      End
      Begin CommandButton RollBackButton
         Caption         =   "Rollback"
         Height          =   336
         Left            =   7920
         TabIndex        =   4
         Top             =   0
         Visible         =   0   'False
         Width           =   971
      End
      Begin CommandButton CommitButton
         Caption         =   "Commit"
         Height          =   336
         Left            =   6840
         TabIndex        =   3
         Top             =   0
         Visible         =   0   'False
         Width           =   971
      End
      Begin OptionButton cTableView
         BackColor       =   &H00C0C0C0&
         Caption         =   "Grid"
         Height          =   255
         Left            =   5640
         TabIndex        =   2
         Top             =   30
         Width           =   810
      End
      Begin OptionButton cSingleRecord
         BackColor       =   &H00C0C0C0&
         Caption         =   "No Data Control"
         Height          =   255
         Left            =   3720
         TabIndex        =   1
         Top             =   30
         Width           =   1800
      End
      Begin Label DynFormType
         BackColor       =   &H00C0C0C0&
         Caption         =   "RecordSet Form Type:"
         Height          =   225
         Left            =   45
         TabIndex        =   9
         Top             =   45
         Width           =   2010
      End
   End
   Begin Menu DBMenu
      Caption         =   "&File"
      Begin Menu DBOpen
         Caption         =   "&Open DataBase..."
         Begin Menu DBOpen_Access
            Caption         =   "&MS Access..."
         End
         Begin Menu DBOpen_dBASE3
            Caption         =   "&dBASE III..."
         End
         Begin Menu DBOpen_dBASE4
            Caption         =   "dB&ASE IV..."
         End
         Begin Menu DBOpen_FoxPro
            Caption         =   "&FoxPro 2.0..."
         End
         Begin Menu DBOpen_Fox25
            Caption         =   "Fo&xPro 2.5..."
         End
         Begin Menu DBOpen_Paradox
            Caption         =   "&Paradox 3.X..."
         End
         Begin Menu Open_paradox4x
            Caption         =   "Pa&radox 4.X..."
         End
         Begin Menu DBOpen_Btrieve
            Caption         =   "&Btrieve..."
         End
         Begin Menu DBOpen_ODBC
            Caption         =   "&ODBC..."
         End
      End
      Begin Menu DBClose
         Caption         =   "&Close DataBase"
         Shortcut        =   ^C
         Visible         =   0   'False
      End
      Begin Menu DBProperties
         Caption         =   "&Properties..."
         Visible         =   0   'False
      End
      Begin Menu DBNew
         Caption         =   "&New..."
         Begin Menu DBNew_Access
            Caption         =   "&MS Access..."
         End
         Begin Menu DBNew_dBASE3
            Caption         =   "&dBASE III..."
         End
         Begin Menu DBNew_dBASE4
            Caption         =   "dB&ASE IV..."
         End
         Begin Menu DBNew_FoxPro
            Caption         =   "&FoxPro 2.0..."
         End
         Begin Menu DBNew_Fox25
            Caption         =   "Fo&xPro 2.5..."
         End
         Begin Menu DBNew_Paradox
            Caption         =   "&Paradox 3.X..."
         End
         Begin Menu New_paradox4x
            Caption         =   "Pa&radox 4.X..."
         End
         Begin Menu DBNew_Btrieve
            Caption         =   "&Btrieve..."
         End
         Begin Menu DBNew_ODBC
            Caption         =   "&ODBC..."
         End
      End
      Begin Menu menubar1
         Caption         =   "-"
      End
      Begin Menu DBAbout
         Caption         =   "&About"
      End
      Begin Menu Exit
         Caption         =   "E&xit"
         Shortcut        =   ^X
      End
   End
   Begin Menu TblMenu
      Caption         =   "&Table"
      Visible         =   0   'False
      Begin Menu TblRefresh
         Caption         =   "&Refresh Table List"
         Shortcut        =   ^R
      End
      Begin Menu TblCopyStruct
         Caption         =   "&Copy..."
      End
      Begin Menu TblDelete
         Caption         =   "&Delete Table"
         Shortcut        =   +{DEL}
      End
      Begin Menu TblProperties
         Caption         =   "&Properties..."
      End
      Begin Menu TblAttach
         Caption         =   "&Attach..."
         Visible         =   0   'False
      End
      Begin Menu TblZap
         Caption         =   "Remove &All Records"
      End
   End
   Begin Menu QueryBuilder
      Caption         =   "Query!"
      Visible         =   0   'False
   End
   Begin Menu UtilMenu
      Caption         =   "&Utility"
      Visible         =   0   'False
      Begin Menu UtilCloseAll
         Caption         =   "&Close All RecordSet Forms"
      End
      Begin Menu UtilReplace
         Caption         =   "&Global Replace..."
      End
      Begin Menu UtilExport
         Caption         =   "&Export to Tab Delimited File..."
      End
      Begin Menu menubar3
         Caption         =   "-"
      End
      Begin Menu UtilCompactDB
         Caption         =   "C&ompact Database"
      End
      Begin Menu UtilRepairDB
         Caption         =   "&Repair Database"
      End
   End
   Begin Menu PrefMenu
      Caption         =   "&Preferences"
      Begin Menu PrefOpenOnStartup
         Caption         =   "&Open Last DataBase on Startup"
      End
      Begin Menu menubar4
         Caption         =   "-"
      End
      Begin Menu PrefQueryTimeout
         Caption         =   "&Query Timeout Value..."
      End
      Begin Menu PrefLoginTimeout
         Caption         =   "&Login Timeout Value..."
      End
      Begin Menu PrefMaxRows
         Caption         =   "&Max Grid View Rows..."
      End
      Begin Menu menubar5
         Caption         =   "-"
      End
      Begin Menu PrefShowPerf
         Caption         =   "&Show Performance Numbers"
      End
      Begin Menu PrefAllowSys
         Caption         =   "&Include System Tables"
      End
      Begin Menu PrefDisplaySQL
         Caption         =   "&Display QueryDef SQL Text"
      End
   End
   Begin Menu WinMenu
      Caption         =   "&Window"
      Begin Menu WinTile
         Caption         =   "&Tile"
      End
      Begin Menu WinCascade
         Caption         =   "&Cascade"
      End
      Begin Menu WinArrange
         Caption         =   "&Arrange Icons"
      End
      Begin Menu menubar2
         Caption         =   "-"
      End
      Begin Menu WinTables
         Caption         =   "Ta&bles"
         Shortcut        =   ^T
      End
      Begin Menu WinSQL
         Caption         =   "&SQL"
         Shortcut        =   ^S
      End
   End
' Fix Query Unload for INI bug (rbd -- see QueryUnload())
' Updated per MS PSS Article Q115976 for Jet 2.0 (rbd 12/8/94)
' Fixed missing Paradox 4.X profile entry (rbd 12/29/94)
Option Explicit
Option Compare Binary
Sub BeginButton_Click ()
  On Error GoTo BeginErr
  If gCurrentDB.Transactions = False Then
    Beep
    MsgBox "Transactions not supported by this Driver!"
    Exit Sub
  End If
  gCurrentDB.BeginTrans
  gfDBChanged = False
  gfTransPending = True
  BeginButton.Visible = False
  CommitButton.Visible = True
  RollBackButton.Visible = True
  CommitButton.SetFocus
  GoTo BeginTransEnd
BeginErr:
  ShowError
  Resume BeginTransEnd
BeginTransEnd:
End Sub
Sub CommitButton_Click ()
  On Error GoTo CommitErr
  gCurrentDB.CommitTrans
  gfDBChanged = False
  gfTransPending = False
  BeginButton.Visible = True
  CommitButton.Visible = False
  RollBackButton.Visible = False
  BeginButton.SetFocus
  GoTo DBCommitTransEnd
CommitErr:
  ShowError
  Resume DBCommitTransEnd
DBCommitTransEnd:
End Sub
Sub DBAbout_Click ()
  MsgBar "Press any key to Close About Box", False
  AboutBox.Show MODAL
  MsgBar "", False
End Sub
Sub DBClose_Click ()
  On Error GoTo DBCloseErr
  If gfDBChanged Then
    If MsgBox("Data has been changed, Commit it?", MSGBOX_TYPE) = YES Then
      gCurrentDB.CommitTrans
      gfDBChanged = False
    Else
      If MsgBox("RollBack All changes?", MSGBOX_TYPE) = YES Then
        gCurrentDB.Rollback
        gfDBChanged = False
      Else
        Beep
        MsgBox "Can't Close with Transactions Pending!", 48
        Exit Sub
      End If
    End If
  End If
  gTableListSS.Close
  CloseAllDynasets
  gCurrentDB.Close
  fTables.Caption = "<none>"
  fTables.cTableList.Clear
  fTables.TableListLabel = "Tables:"
  DBProperties.Visible = False
  DBClose.Visible = False
  TblAttach.Visible = False
  TblMenu.Visible = False
  UtilMenu.Visible = False
  ToolBar.Visible = False
  QueryBuilder.Visible = False
  gfDBOpenFlag = False
  gfTransPending = False
  gstDBName = ""
  Unload fQuery
  GoTo DBCloseEnd
DBCloseErr:
  ShowError
  Resume DBCloseEnd
DBCloseEnd:
End Sub
Sub DBNew_Access_Click ()
   Dim nn As String
   Dim d As Database
   Dim v10 As Integer
   On Error GoTo NewAccErr
   nn = InputBox("Enter Name for New MS Access Database:")
   If nn = "" Then Exit Sub
   If MsgBox("Make New Database Access 1.0 Compatible?", MSGBOX_TYPE) = YES Then
     Set d = CreateDatabase(nn, DB_CREATE_GENERAL, DB_VERSION10)
   Else
     Set d = CreateDatabase(nn, DB_CREATE_GENERAL, 0)
   End If
   d.Close
   gstDataType = "MS Access"
   gstDBName = nn
   OpenLocalDB True
   If gfDBOpenFlag = True Then
     DBProperties.Visible = True
     DBClose.Visible = True
     TblMenu.Visible = True
     UtilMenu.Visible = True
     RefreshTables fTables.cTableList, True
     fSQL.CreateQueryDefbtn.Visible = True
     TblAttach.Visible = True
   End If
  GoTo NewAccEnd
NewAccErr:
  ShowError
  Resume NewAccEnd
NewAccEnd:
End Sub
Sub DBNew_Btrieve_Click ()
   gstDataType = "Btrieve"
   NewLocalISAM
End Sub
Sub DBNew_dBASE3_Click ()
   gstDataType = "dBASE III"
   NewLocalISAM
End Sub
Sub DBNew_dBASE4_Click ()
   gstDataType = "dBASE IV"
   NewLocalISAM
End Sub
Sub DBNew_FoxPro_Click ()
   gstDataType = "FoxPro 2.0"
   NewLocalISAM
End Sub
Sub DBNew_ODBC_Click ()
  Dim driver As String
  On Error GoTo DBNErr
  MsgBar "Enter New Database Parameters", False
  'driver must be an valid entry in ODBCINST.INI
  driver = InputBox("Enter Driver Name from ODBCINST.INI File:", "Driver Name", DEFAULTDRIVER)
  RegisterDatabase "", driver, False, ""
  SendKeys "%FOO"   'force open database dialog
  GoTo DBNEnd
DBNErr:
  ShowError
  Resume DBNEnd
DBNEnd:
  MsgBar "", False
End Sub
Sub DBNew_Paradox_Click ()
   gstDataType = "Paradox 3.X"
   NewLocalISAM
End Sub
Sub DBOpen_Access_Click ()
   gstDataType = "MS Access"
   OpenLocalDB False
End Sub
Sub DBOpen_Btrieve_Click ()
   gstDataType = "Btrieve"
   OpenLocalDB False
End Sub
Sub DBOpen_dBASE3_Click ()
   gstDataType = "dBASE III"
   OpenLocalDB False
End Sub
Sub DBOpen_dBASE4_Click ()
   gstDataType = "dBASE IV"
   OpenLocalDB False
End Sub
Sub DBOpen_Fox25_Click ()
   gstDataType = "FoxPro 2.5"
   OpenLocalDB False
End Sub
Sub DBOpen_FoxPro_Click ()
   gstDataType = "FoxPro 2.0"
   OpenLocalDB False
End Sub
Sub DBOpen_ODBC_Click ()
   If gfDBOpenFlag = True Then
     Call DBClose_Click
   End If
   If gfDBOpenFlag = True Then
     Beep
     MsgBox "You must Close First!", 48
   Else
     fOpenDB.Show MODAL
   End If
   If gfDBOpenFlag = True Then
     DBProperties.Visible = True
     DBClose.Visible = True
     TblMenu.Visible = True
     UtilMenu.Visible = True
     RefreshTables fTables.cTableList, True
     fSQL.CreateQueryDefbtn.Visible = False
     TblAttach.Visible = False
   End If
End Sub
Sub DBOpen_Paradox_Click ()
   gstDataType = "Paradox 3.X"
   OpenLocalDB False
End Sub
Sub DBProperties_Click ()
   Dim f As New fDataBox
   Dim s As String, t As String, erm As String
   Dim i As Integer
   On Error GoTo PropErr
   f.Caption = gCurrentDB.Name + " Properties"
   f.Tag = "DB"
   erm = "Name"
   f.cData.AddItem "Database Name = " + gCurrentDB.Name
   erm = "Connect"
   f.cData.AddItem "Connect String = " + gCurrentDB.Connect
   erm = "Collating Order"
   f.cData.AddItem "Collating Order = " + gCurrentDB.CollatingOrder
   erm = "Updatable"
   f.cData.AddItem "Updatable = " + stTrueFalse((gCurrentDB.Updatable))
   erm = "Transactions"
   f.cData.AddItem "Transactions = " + stTrueFalse((gCurrentDB.Transactions))
   erm = "QueryTimeout"
   f.cData.AddItem "Query Timeout = " & gCurrentDB.QueryTimeout & " seconds"
   f.Show MODAL
  GoTo DBPropEnd
PropErr:
  f.cData.AddItem erm + ":" + Error$
  Resume Next
DBPropEnd:
End Sub
Sub Exit_Click ()
  Unload Me
End Sub
' Updated per MS PSS Article Q115976 for Jet 2.0 (rbd 12/8/94)
' Fixed missing Paradox 4.X profile entry (rbd 12/29/94)
Sub MDIForm_Load ()
  Dim st As String
  Dim x As Integer
  Dim tmp As String
  tmp = String$(255, 32)
  'write ISAM entries in INI file just in case
  x = OSWritePrivateProfileString("Installable ISAMS", "Paradox 3.X", "PDX200.DLL", "VISDATA.INI")
  x = OSWritePrivateProfileString("Installable ISAMS", "Paradox 4.X", "PDX200.DLL", "VISDATA.INI")
  x = OSWritePrivateProfileString("Installable ISAMS", "dBASE III", "XBS200.DLL", "VISDATA.INI")
  x = OSWritePrivateProfileString("Installable ISAMS", "dBASE IV", "XBS200.DLL", "VISDATA.INI")
  x = OSWritePrivateProfileString("Installable ISAMS", "FoxPro 2.0", "XBS200.DLL", "VISDATA.INI")
  x = OSWritePrivateProfileString("Installable ISAMS", "FoxPro 2.5", "XBS200.DLL", "VISDATA.INI")
  x = OSWritePrivateProfileString("Installable ISAMS", "Btrieve", "BTRV200.DLL", "VISDATA.INI")
  x = OSWritePrivateProfileString("dBase ISAM", "Deleted", "On", "VISDATA.INI")
  x = OSWritePrivateProfileString("Paradox ISAM", "ParadoxUserName", "User", "VISDATA.INI")
  x = OSWritePrivateProfileString("Paradox ISAM", "ParadoxNetPath", "c:\vb\prdx", "VISDATA.INI")
  ' Note: 4.x works with 3.x and 4.x net styles
  x = OSWritePrivateProfileString("Paradox ISAM", "ParadoxNetStyle", "4.x", "VISDATA.INI")
  x = OSWritePrivateProfileString("Paradox ISAM", "CollatingSequence", "Ascii", "VISDATA.INI")
  x = OSGetWindowsDirectory(tmp, 255)
  st = Mid$(tmp, 1, x)
  SetDataAccessOption 1, st + "\visdata.ini"
  SetDefaultWorkspace "admin", ""
  gwMaxGridRows = Val(GetINIString("MaxRows", "250"))
  glQueryTimeout = Val(GetINIString("QueryTimeout", "5"))
  glLoginTimeout = Val(GetINIString("LoginTimeout", "20"))
  st = GetINIString("ViewMode", "Single")
  If UCase(st) = "SINGLE" Then
    cSingleRecord = True
  ElseIf UCase(st) = "DATACTL" Then
    cDataCtl = True
  Else
    cTableView = True
  End If
  st = GetINIString("OpenOnStartup", "No")
  If UCase(st) = "YES" Then
    PrefOpenOnStartup.Checked = True
  Else
    PrefOpenOnStartup.Checked = False
  End If
  st = GetINIString("ShowPerf", "No")
  If UCase(st) = "YES" Then
    PrefShowPerf.Checked = True
  Else
    PrefShowPerf.Checked = False
  End If
  st = GetINIString("AllowSys", "No")
  If UCase(st) = "YES" Then
    PrefAllowSys.Checked = True
  Else
    PrefAllowSys.Checked = False
  End If
  ' Default to showing SQL (now that it can be clicked-to)
  st = GetINIString("DisplaySQL", "Yes")
  If UCase(st) = "YES" Then
    PrefDisplaySQL.Checked = True
  Else
    PrefDisplaySQL.Checked = False
  End If
  'get the last used database out of the INI file
  gstDataType = GetINIString("DataType", "")
  gstDBName = GetINIString("Server", "")
  gstDatabase = GetINIString("DataBase", "")
  gstUserName = GetINIString("UserName", "")
  gstPassword = GetINIString("Password", "")
  If PrefOpenOnStartup.Checked = True Then
    If gstDataType = "MS Access" Then
      SendKeys "%FOM"
    ElseIf gstDataType = "dBASE III" Then
      SendKeys "%FOD"
    ElseIf gstDataType = "dBASE IV" Then
      SendKeys "%FOA"
    ElseIf gstDataType = "FoxPro 2.0" Then
      SendKeys "%FOF"
    ElseIf gstDataType = "FoxPro 2.5" Then
      SendKeys "%FOX"
    ElseIf gstDataType = "Paradox 3.X" Then
      SendKeys "%FOP"
    ElseIf gstDataType = "Paradox 4.X" Then     ' New addition
      SendKeys "%FOR"                           ' 'r' in word Paradox
    ElseIf gstDataType = "Btrieve" Then
      SendKeys "%FOB"
    ElseIf gstDataType = "ODBC" Then
      SendKeys "%FOO"
    End If
  End If
  x = Val(GetINIString("WindowState", "2"))
  If x <> 1 Then
    WindowState = x
  Else
    WindowState = 0
  End If
  If x = 0 Then
    x = Val(GetINIString("WindowLeft", "0"))
    Left = x
    x = Val(GetINIString("WindowTop", "0"))
    Top = x
    x = Val(GetINIString("WindowWidth", "9135"))
    Width = x
    x = Val(GetINIString("WindowHeight", "6900"))
    Height = x
  End If
  Me.Show
  fSQL.Show
End Sub
' rbd - Fix INI for "see SQL Queries" vs "see System Tables"
Sub MDIForm_QueryUnload (Cancel As Integer, UnloadMode As Integer)
  Dim x As Integer
  Dim st As String
  On Error Resume Next
  x = OSWritePrivateProfileString("VISDATA", "DataType", gstDataType, "VISDATA.INI")
  x = OSWritePrivateProfileString("VISDATA", "Server", gstDBName, "VISDATA.INI")
  x = OSWritePrivateProfileString("VISDATA", "DataBase", gstDatabase, "VISDATA.INI")
  x = OSWritePrivateProfileString("VISDATA", "UserName", gstUserName, "VISDATA.INI")
  x = OSWritePrivateProfileString("VISDATA", "Password", gstPassword, "VISDATA.INI")
  If PrefOpenOnStartup.Checked = True Then
    st = "Yes"
  Else
    st = "No"
  End If
  x = OSWritePrivateProfileString("VISDATA", "OpenOnStartup", st, "VISDATA.INI")
  If PrefShowPerf.Checked = True Then
    st = "Yes"
  Else
    st = "No"
  End If
  x = OSWritePrivateProfileString("VISDATA", "ShowPerf", st, "VISDATA.INI")
  If PrefAllowSys.Checked = True Then
    st = "Yes"
  Else
    st = "No"
  End If
  x = OSWritePrivateProfileString("VISDATA", "AllowSys", st, "VISDATA.INI")
  If PrefDisplaySQL.Checked = True Then
    st = "Yes"
  Else
    st = "No"
  End If
  x = OSWritePrivateProfileString("VISDATA", "DisplaySQL", st, "VISDATA.INI")
  x = OSWritePrivateProfileString("VISDATA", "WindowState", CStr(WindowState), "VISDATA.INI")
  If WindowState <> 2 Then
    x = OSWritePrivateProfileString("VISDATA", "WindowTop", CStr(Top), "VISDATA.INI")
    x = OSWritePrivateProfileString("VISDATA", "WindowLeft", CStr(Left), "VISDATA.INI")
    x = OSWritePrivateProfileString("VISDATA", "WindowWidth", CStr(Width), "VISDATA.INI")
    x = OSWritePrivateProfileString("VISDATA", "WindowHeight", CStr(Height), "VISDATA.INI")
  End If
  x = OSWritePrivateProfileString("VISDATA", "MaxRows", CStr(gwMaxGridRows), "VISDATA.INI")
  x = OSWritePrivateProfileString("VISDATA", "QueryTimeout", CStr(glQueryTimeout), "VISDATA.INI")
  x = OSWritePrivateProfileString("VISDATA", "LoginTimeout", CStr(glLoginTimeout), "VISDATA.INI")
  If VDMDI.cSingleRecord = True Then
    st = "Single"
  ElseIf VDMDI.cDataCtl = True Then
    st = "DataCtl"
  Else
    st = "Table"
  End If
  x = OSWritePrivateProfileString("VISDATA", "ViewMode", st, "VISDATA.INI")
  x = OSWritePrivateProfileString("VISDATA", "SQLStatement", fSQL.cSQLStatement, "VISDATA.INI")
  If fSQL.WindowState <> 1 Then
    x = OSWritePrivateProfileString("VISDATA", "SQLWindowTop", CStr(fSQL.Top), "VISDATA.INI")
    x = OSWritePrivateProfileString("VISDATA", "SQLWindowLeft", CStr(fSQL.Left), "VISDATA.INI")
    x = OSWritePrivateProfileString("VISDATA", "SQLWindowWidth", CStr(fSQL.Width), "VISDATA.INI")
    x = OSWritePrivateProfileString("VISDATA", "SQLWindowHeight", CStr(fSQL.Height), "VISDATA.INI")
  End If
  If gfDBChanged Then
    If MsgBox("Data has been changed, Commit it?", MSGBOX_TYPE) = YES Then
      gCurrentDB.CommitTrans
    End If
  End If
  CloseAllDynasets
  If gfDBOpenFlag Then gCurrentDB.Close
  End
End Sub
Sub New_paradox4x_Click ()
    gstDataType = "Paradox 4.X"
    NewLocalISAM
End Sub
Sub NewLocalISAM ()
   Dim nn As String
   Dim d As Database
   On Error GoTo NewISAMErr
   nn = InputBox("Enter Name for New ISAM Database:")
   If nn = "" Then Exit Sub
   If Mid(nn, Len(nn), 1) <> "\" Then nn = nn + "\"
   MkDir Mid(nn, 1, Len(nn) - 1)
   gstDBName = nn
   OpenLocalDB True
   If gfDBOpenFlag = True Then
     DBProperties.Visible = True
     DBClose.Visible = True
     TblMenu.Visible = True
     UtilMenu.Visible = True
     RefreshTables fTables.cTableList, True
     fSQL.CreateQueryDefbtn.Visible = True
     TblAttach.Visible = True
   End If
  GoTo NewISAMEnd
NewISAMErr:
  If Err = 75 Then Resume Next  'catch the case where dir exists
  ShowError
  Resume NewISAMEnd
NewISAMEnd:
End Sub
Sub Open_paradox4x_Click ()
    gstDataType = "Paradox 4.X"
    OpenLocalDB False
End Sub
' Updated per MS PSS Article Q115976 for Jet 2.0 (rbd 12/8/94)
Sub OpenLocalDB (doit As Integer)
   Dim Connect As String, DataBaseName As String
   On Error GoTo OpenError
   If gfDBOpenFlag = True Then
     Call DBClose_Click
   End If
   If gfDBOpenFlag = True Then
     Beep
     MsgBox "You must Close First!", 48
     Exit Sub
   Else
     Select Case gstDataType
       Case "MS Access"
         CMD1.Filter = "Access DBs (*.mdb)|*.mdb|All Files (*.*)|*.*"
         CMD1.DialogTitle = "Open MS Access Database"
       Case "dBASE III"
         CMD1.Filter = "dBASE III DBs (*.dbf)|*.dbf"
         CMD1.DialogTitle = "Open dBASE III Database"
       Case "dBASE IV"
         CMD1.Filter = "dBASE IV DBs (*.dbf)|*.dbf"
         CMD1.DialogTitle = "Open dBASE IV Database"
       Case "FoxPro 2.0"
         CMD1.Filter = "FoxPro DBs (*.dbf)|*.dbf"
         CMD1.DialogTitle = "Open FoxPro 2.0 Database"
       Case "FoxPro 2.5"
         CMD1.Filter = "FoxPro DBs (*.dbf)|*.dbf"
         CMD1.DialogTitle = "Open FoxPro 2.5 Database"
       Case "Paradox 3.X"
         CMD1.Filter = "Paradox DBs (*.db)|*.db"
         CMD1.DialogTitle = "Open Paradox 3.X Database"
       Case "Paradox 4.X"                               ' New addition
         CMD1.Filter = "Paradox DBs (*.db)|*.db"
         CMD1.DialogTitle = "Open Paradox 4.X Database"
       Case "Btrieve"
         CMD1.Filter = "Btrieve DBs (FILE.DDF)|FILE.DDF"
         CMD1.DialogTitle = "Open Btrieve Database"
     End Select
     CMD1.FilterIndex = 1
     CMD1.Filename = gstDBName  '""
     CMD1.CancelError = True
     If doit = False Then
       CMD1.Action = 1
       If CMD1.Filename <> "" Then
         gstDBName = CMD1.Filename
       Else
         Exit Sub
       End If
     End If
   End If
   MsgBar "Opening DataBase", True
   SetHourglass Me
   Select Case gstDataType
     Case "dBASE III"
       Connect = "dBASE III"
       DataBaseName = StripFileName(gstDBName)
     Case "dBASE IV"
       Connect = "dBASE IV"
       DataBaseName = StripFileName(gstDBName)
     Case "FoxPro 2.0"
       Connect = "FoxPro 2.0"
       DataBaseName = StripFileName(gstDBName)
     Case "FoxPro 2.5"
       Connect = "FoxPro 2.5"
       DataBaseName = StripFileName(gstDBName)
     Case "Paradox 3.X"
       Connect = "Paradox 3.X"
       DataBaseName = StripFileName(gstDBName)
     Case "Paradox 4.X"                             ' New addition
       Connect = "Paradox 4.X"
       DataBaseName = StripFileName(gstDBName)
     Case "Btrieve"
       Connect = "Btrieve;"
       DataBaseName = gstDBName
     Case Else
       Connect = ""
       DataBaseName = gstDBName
   End Select
   Set gCurrentDB = OpenDatabase(DataBaseName, False, False, Connect)
   If gfDBOpenFlag = True Then
     CloseAllDynasets
   End If
   gfTransPending = False
   VDMDI.ToolBar.Visible = True
   VDMDI.QueryBuilder.Visible = True
   fTables.Caption = gstDBName
   gCurrentDB.QueryTimeout = glQueryTimeout
   'success
   gfDBOpenFlag = True
   DBProperties.Visible = True
   DBClose.Visible = True
   TblMenu.Visible = True
   UtilMenu.Visible = True
   RefreshTables fTables.cTableList, True
   If gstDataType = "MS Access" Then
     fSQL.CreateQueryDefbtn.Visible = True
     TblAttach.Visible = True
     fTables.TableListLabel = "Tables/Queries:"
   Else
     TblAttach.Visible = False
     fSQL.CreateQueryDefbtn.Visible = False
   End If
   ResetMouse Me
   GoTo OpenEnd
OpenError:
   ResetMouse Me
   gfDBOpenFlag = False
   gstDBName = ""
   gstDataType = ""
   If Err <> 32755 Then     'check for common dialog cancelled
     ShowError
   End If
   Resume OpenEnd
OpenEnd:
End Sub
Sub PrefAllowSys_Click ()
  If PrefAllowSys.Checked = True Then
    PrefAllowSys.Checked = False
  Else
    PrefAllowSys.Checked = True
  End If
  RefreshTables fTables.cTableList, True
End Sub
Sub PrefDisplaySQL_Click ()
  If PrefDisplaySQL.Checked = True Then
    PrefDisplaySQL.Checked = False
  Else
    PrefDisplaySQL.Checked = True
  End If
End Sub
Sub PrefLoginTimeout_Click ()
  On Error GoTo LTErr
  Dim nval As String
  nval = InputBox("Login Timeout is currently " & glLoginTimeout & " seconds." + Chr(13) + Chr(10) + "Enter New Value:")
  If nval = "" Then Exit Sub
  'try to set the new value
  If Val(nval) >= 0 Then
    glLoginTimeout = Val(nval)
  End If
  GoTo LTEnd
LTErr:
  ShowError
  Resume LTEnd
LTEnd:
End Sub
Sub PrefMaxRows_Click ()
  Dim st As String
  Dim CR As String
  MsgBar "Enter Maximum Rows to Show in Grid", False
  st = InputBox("Enter New Value:", "Max Grid View Rows", CStr(gwMaxGridRows))
  If st <> "" Then
    If Val(st) > MAX_GRID_ROWS Then
      MsgBox "Maximum Rows is " + CStr(MAX_GRID_ROWS), 48
      gwMaxGridRows = MAX_GRID_ROWS
    ElseIf Val(st) = 0 Then
      MsgBox "Minimum Rows is 1.", 48
      gwMaxGridRows = 1
    Else
      gwMaxGridRows = Val(st)
    End If
  End If
  MsgBar "", False
End Sub
Sub PrefOpenOnStartup_Click ()
  'toggle the menu item
  If PrefOpenOnStartup.Checked = True Then
    PrefOpenOnStartup.Checked = False
  Else
    PrefOpenOnStartup.Checked = True
  End If
End Sub
Sub PrefQueryTimeout_Click ()
  On Error GoTo QTErr
  Dim nval As String
  nval = InputBox("Query Timeout is currently " & gCurrentDB.QueryTimeout & " seconds." + Chr(13) + Chr(10) + "Enter New Value:")
  If nval = "" Then Exit Sub
  'try to set the new value
  gCurrentDB.QueryTimeout = Val(nval)
  glQueryTimeout = Val(nval)
  GoTo QTEnd
QTErr:
  ShowError
  'reset the form control after the error
  glQueryTimeout = gCurrentDB.QueryTimeout
  Resume QTEnd
QTEnd:
End Sub
Sub PrefShowPerf_Click ()
  If PrefShowPerf.Checked = True Then
    PrefShowPerf.Checked = False
  Else
    PrefShowPerf.Checked = True
  End If
End Sub
Sub QueryBuilder_Click ()
  fQuery.WindowState = 0
End Sub
Sub RollBackButton_Click ()
  On Error GoTo RollbackErr
  If MsgBox("All changes will be gone, Rollback anyway?", MSGBOX_TYPE) = YES Then
    gCurrentDB.Rollback
    gfDBChanged = False
    gfTransPending = False
    BeginButton.Visible = True
    CommitButton.Visible = False
    RollBackButton.Visible = False
    BeginButton.SetFocus
  End If
  GoTo DBRollbackEnd
RollbackErr:
  ShowError
  Resume DBRollbackEnd
DBRollbackEnd:
End Sub
Sub TblAttach_Click ()
  fAttach.Show MODAL
End Sub
Sub TblCopyStruct_Click ()
  fCpyStru.Show MODAL
End Sub
Sub TblDelete_Click ()
  On Error GoTo TblDelErr
  If fTables.cTableList = "" Then
    MsgBox "No Table Selected", 48
    Exit Sub
  End If
  If MsgBox("Delete """ + fTables.cTableList + """ table?", MSGBOX_TYPE) = YES Then
    If TableType((fTables.cTableList)) = DB_QUERYDEF Then
      gCurrentDB.DeleteQueryDef (fTables.cTableList)
    Else
      gCurrentDB.TableDefs.Delete gCurrentDB.TableDefs(fTables.cTableList)
    End If
    fTables.cTableList.RemoveItem fTables.cTableList.ListIndex
  End If
  GoTo TblDelEnd
TblDelErr:
  ShowError
  Resume TblDelEnd
TblDelEnd:
End Sub
Sub TblProperties_Click ()
   Dim f As New fDataBox
   Dim erm As String
   Dim tt As Integer
   Dim qt As String
   Dim qd As querydef
   If fTables.cTableList = "" Then
     MsgBox "No Table Selected", 48
     Exit Sub
   End If
   On Error GoTo TblPropErr
   f.Caption = fTables.cTableList + " Properties"
   tt = TableType((fTables.cTableList))
   If tt = DB_QUERYDEF Then
     f.cData.AddItem "Table Type = QueryDef"
   ElseIf tt = DB_ATTACHEDTABLE Then
     f.cData.AddItem "Table Type = Attached Table"
   ElseIf tt = DB_ATTACHEDODBC Then
     f.cData.AddItem "Table Type = Attached ODBC Table"
   Else
     f.cData.AddItem "Table Type = Table"
   End If
   If tt = DB_QUERYDEF Then
     f.Tag = "QD"
     Set gCurrentQueryDef = gCurrentDB.OpenQueryDef(fTables.cTableList)
     erm = "Name"
     f.cData.AddItem "QueryDef Name = " + gCurrentQueryDef.Name
     erm = "SQL"
     f.cData.AddItem "SQL = " + gCurrentQueryDef.SQL
     qt = ActionQueryType((fTables.cTableList))
     If qt <> "" Then
       f.cData.AddItem "Action Query Type = " + qt
     End If
     f.Show MODAL
     gCurrentQueryDef.Close
   Else
     f.Tag = "TBD"
     erm = "Name"
     f.cData.AddItem "Table Name = " + gCurrentDB.TableDefs(fTables.cTableList).Name
     erm = "Date Created"
     f.cData.AddItem "Date Created = " & gCurrentDB.TableDefs(fTables.cTableList).DateCreated
     erm = "Last Updated"
     f.cData.AddItem "Last Updated = " & gCurrentDB.TableDefs(fTables.cTableList).LastUpdated
     erm = "Updatable"
     f.cData.AddItem "Updatable = " + stTrueFalse((gCurrentDB.TableDefs(fTables.cTableList).Updatable))
     erm = "Connect"
     f.cData.AddItem "Connect String = " + gCurrentDB.TableDefs(fTables.cTableList).Connect
     erm = "Source Table Name"
     f.cData.AddItem "Source Table Name = " + gCurrentDB.TableDefs(fTables.cTableList).SourceTableName
     erm = "Attributes"
     f.cData.AddItem "Attributes = &H" & Hex(gCurrentDB.TableDefs(fTables.cTableList).Attributes)
     f.Show MODAL
   End If
  GoTo TblPropEnd
TblPropErr:
  f.cData.AddItem erm + ":" + Error$
  Resume Next
TblPropEnd:
End Sub
Sub TblRefresh_Click ()
  gCurrentDB.TableDefs.Refresh
  RefreshTables fTables.cTableList, True
End Sub
Sub TblZap_Click ()
  Dim RetSQL As Long
  If fTables.cTableList = "" Then
    MsgBox "No Table Selected", 48
    Exit Sub
  End If
  On Error GoTo ZapErr
  If MsgBox("Delete All Records in " + fTables.cTableList + "?", MSGBOX_TYPE) = YES Then
    'delete all rows with a sql statement
    If gstDataType = "ODBC" Then
      RetSQL = gCurrentDB.ExecuteSQL("delete from " + fTables.cTableList)
      If RetSQL > 0 Then
        MsgBox CStr(RetSQL) + " rows deleted!", 48
        If gfTransPending Then gfDBChanged = True
      End If
    Else
      gCurrentDB.Execute ("delete from " + fTables.cTableList)
    End If
  End If
  GoTo ZapEnd
ZapErr:
  If Err = EOF_ERR Then Resume Next
  ShowError
  Resume ZapEnd
ZapEnd:
End Sub
Sub UtilCloseAll_Click ()
  CloseAllDynasets
End Sub
Sub UtilCompactDB_Click ()
   Dim oldname As String, newname As String
   On Error GoTo CompactAccErr
   'get file name to compact
   CMD1.Filter = "Access DBs (*.mdb)|*.mdb|All Files (*.*)|*.*"
   CMD1.DialogTitle = "Open MS Access Database to Compact"
   CMD1.FilterIndex = 1
   CMD1.Action = 1
   If CMD1.Filename <> "" Then
     oldname = CMD1.Filename
   Else
     Exit Sub
   End If
   'get file name to compact to
   CMD1.DialogTitle = "Select MS Access Database to Compact to"
   CMD1.FilterIndex = 1
   CMD1.Action = 2
   If CMD1.Filename <> "" Then
     newname = CMD1.Filename
   Else
     Exit Sub
   End If
   SetHourglass Me
   MsgBar "Compacting " + oldname + " to " + newname, True
   CompactDatabase oldname, newname, DB_CREATE_GENERAL, DB_VERSION10
   MsgBar "", False
   ResetMouse Me
   If MsgBox("Open Newly Compacted Database?", MSGBOX_TYPE) = YES Then
     If gfDBOpenFlag = True Then
       Call DBClose_Click
     End If
     gstDataType = "MS Access"
     gstDBName = newname
     OpenLocalDB True
   End If
   If gfDBOpenFlag = True Then
     DBProperties.Visible = True
     DBClose.Visible = True
     TblMenu.Visible = True
     UtilMenu.Visible = True
     RefreshTables fTables.cTableList, True
     fSQL.CreateQueryDefbtn.Visible = True
     TblAttach.Visible = True
   End If
  GoTo CompactAccEnd
CompactAccErr:
  MsgBar "", False
  ResetMouse Me
  ShowError
  Resume CompactAccEnd
CompactAccEnd:
End Sub
Sub UtilExport_Click ()
  Dim ds As Dynaset
  Dim l As Long
  Dim i As Integer
  Dim fn As String
  Dim st As String
  On Error GoTo ExportErr
  If fTables.cTableList = "" And UCase(Mid(fSQL.cSQLStatement, 1, 6)) <> "SELECT" Then
    MsgBox "No Table Selected", 48
    Exit Sub
  End If
  fn = InputBox("Enter Path\FileName to Export to:", "Export File", "VISDATA.TXT")
  If fn = "" Then Exit Sub
  SetHourglass Me
  MsgBar "Exporting Data to " + fn, True
  If UCase(Mid(fSQL.cSQLStatement, 1, 6)) = "SELECT" Then
    Set ds = gCurrentDB.CreateDynaset(fSQL.cSQLStatement)
  Else
    Set ds = gCurrentDB.CreateDynaset(fTables.cTableList)
  End If
  Open fn For Output As #1
  'output the field names
  st = Chr$(9)
  For i = 0 To ds.Fields.Count - 1
    st = st + ds(i).Name + Chr$(9)
  Next
  Print #1, st
  'output the field contents
  l = 1
  While ds.EOF = False
    st = CStr(l) + Chr$(9)
    For i = 0 To ds.Fields.Count - 1
      st = st + vFieldVal((ds(i))) + Chr$(9)
    Next
    Print #1, st
    ds.MoveNext
    l = l + 1
  Wend
  GoTo ExportEnd
ExportErr:
  ShowError
  Resume ExportEnd
ExportEnd:
  Close #1
  ResetMouse Me
  MsgBar "", False
End Sub
Sub UtilRepairDB_Click ()
   On Error GoTo RepairAccErr
   Dim nn As String
   'get file name to repair
   CMD1.Filter = "Access DBs (*.mdb)|*.mdb|All Files (*.*)|*.*"
   CMD1.DialogTitle = "Open MS Access Database to Repair"
   CMD1.FilterIndex = 1
   CMD1.Action = 1
   If CMD1.Filename <> "" Then
     nn = CMD1.Filename
   Else
     Exit Sub
   End If
   SetHourglass Me
   MsgBar "Repairing " + nn, True
   RepairDatabase nn
   ResetMouse Me
   MsgBar "", False
   If MsgBox("Open Repaired Database?", MSGBOX_TYPE) = YES Then
     If gfDBOpenFlag = True Then
       Call DBClose_Click
     End If
     gstDataType = "MS Access"
     gstDBName = nn
     OpenLocalDB True
   End If
   If gfDBOpenFlag = True Then
     DBProperties.Visible = True
     DBClose.Visible = True
     TblMenu.Visible = True
     UtilMenu.Visible = True
     RefreshTables fTables.cTableList, True
     fSQL.CreateQueryDefbtn.Visible = True
     TblAttach.Visible = True
   End If
  GoTo RepairAccEnd
RepairAccErr:
  ResetMouse Me
  MsgBar "", False
  ShowError
  Resume RepairAccEnd
RepairAccEnd:
End Sub
Sub UtilReplace_Click ()
  Dim i As Integer
  Dim sb As String
  On Error GoTo ReplaceErr
  RefreshTables fReplace.cTableList, False
  fReplace.Show MODAL
  GoTo ReplaceEnd
ReplaceErr:
  ShowError
  Resume ReplaceEnd
ReplaceEnd:
End Sub
Sub WinArrange_Click ()
  Me.Arrange 3
End Sub
Sub WinCascade_Click ()
  Me.Arrange 0
End Sub
Sub WinSQL_Click ()
  fSQL.WindowState = 0
End Sub
Sub WinTables_Click ()
  fTables.WindowState = 0
  If fTables.cTableList.ListCount = 0 And gfDBOpenFlag = True Then
    RefreshTables fTables.cTableList, True
  End If
End Sub
Sub WinTile_Click ()
  Me.Arrange 2
End Sub