On Hand/On_Hand_From_Softbank_1994_Release_2_Disc_2_1994.iso/00202/s/disk4/vdmdi.fr_/vdmdi.bin

Text File | 1993-04-28 | 37KB | 1,428 lines

VERSION 2.00
Begin MDIForm VDMDI
   Caption         =   "Visual Data"
   ClientHeight    =   6210
   ClientLeft      =   1110
   ClientTop       =   1725
   ClientWidth     =   9015
   Height          =   6900
   Icon            =   VDMDI.FRX:0000
   Left            =   1050
   LinkTopic       =   "MDIForm1"
   Top             =   1095
   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 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 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
End
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

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", "PDX110.DLL", "VISDATA.INI")
  x = OSWritePrivateProfileString("Installable ISAMS", "dBASE III", "XBS110.DLL", "VISDATA.INI")
  x = OSWritePrivateProfileString("Installable ISAMS", "dBASE IV", "XBS110.DLL", "VISDATA.INI")
  x = OSWritePrivateProfileString("Installable ISAMS", "FoxPro 2.0", "XBS110.DLL", "VISDATA.INI")
  x = OSWritePrivateProfileString("Installable ISAMS", "FoxPro 2.5", "XBS110.DLL", "VISDATA.INI")
  x = OSWritePrivateProfileString("Installable ISAMS", "Btrieve", "BTRV110.DLL", "VISDATA.INI")
  x = OSWritePrivateProfileString("dBase ISAM", "Deleted", "On", "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
  st = GetINIString("DisplaySQL", "No")
  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 = "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

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", "DisplaySQL", st, "VISDATA.INI")
  If PrefDisplaySQL.Checked = True Then
    st = "Yes"
  Else
    st = "No"
  End If
  x = OSWritePrivateProfileString("VISDATA", "AllowSys", 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 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 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 "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 "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