Master 95 #1/MASTER95_1.iso/microsof/vbasic4/vb4-6.cab/visdata.bas

BASIC Source File | 1995-07-26 | 62.0 KB | 2,011 lines

Attribute VB_Name = "modVisData"
'------------------------------------------------------------
' VISDATA.BAS
' support functions for the Visual Data sample application
'
' General Information: This app is intended to demonstrate
'   and exercise all of the functionality available in the
'   DAO (Data Access Objects) in VB 4.0.
'
'------------------------------------------------------------

Option Explicit

'api declarations
#If Win16 Then
    Declare Function OSGetPrivateProfileString% Lib "KERNEL" Alias "GetPrivateProfileString" (ByVal AppName$, ByVal KeyName$, ByVal keydefault$, ByVal ReturnString$, ByVal NumBytes As Integer, ByVal FileName$)
    Declare Function OSWritePrivateProfileString% Lib "KERNEL" Alias "WritePrivateProfileString" (ByVal AppName$, ByVal KeyName$, ByVal keydefault$, ByVal FileName$)
    Declare Function OSWinHelp% Lib "User" Alias "WinHelp" (ByVal hwnd%, ByVal HelpFile$, ByVal wCommand%, dwData As Any)
    Declare Function OSTimeGetTime& Lib "MMSYSTEM.DLL" Alias "TimeGetTime" ()
    Declare Function SQLAllocEnv% Lib "ODBC.DLL" (env As Long)
    Declare Function SQLDataSources% Lib "ODBC.DLL" (ByVal henv&, ByVal fdir%, ByVal szDSN$, ByVal cbDSNMAx%, pcbDSN%, ByVal szDesc$, ByVal cbDescMax%, pcbDesc%)
#Else
    Declare Function OSGetPrivateProfileString% Lib "Kernel32" Alias "GetPrivateProfileStringA" (ByVal AppName$, ByVal KeyName$, ByVal keydefault$, ByVal ReturnString$, ByVal NumBytes As Integer, ByVal FileName$)
    Declare Function OSWritePrivateProfileString% Lib "Kernel32" Alias "WritePrivateProfileStringA" (ByVal AppName$, ByVal KeyName$, ByVal keydefault$, ByVal FileName$)
    Declare Function OSWinHelp% Lib "USER32" Alias "WinHelpA" (ByVal hwnd&, ByVal HelpFile$, ByVal wCommand%, dwData As Any)
    Declare Function OSTimeGetTime& Lib "WINMM.DLL" Alias "timeGetTime" ()
    Declare Function SQLAllocEnv% Lib "ODBC32.DLL" (env&)
    Declare Function SQLDataSources% Lib "ODBC32.DLL" (ByVal henv&, ByVal fdir%, ByVal szDSN$, ByVal cbDSNMAx%, pcbDSN%, ByVal szDesc$, ByVal cbDescMax%, pcbDesc%)
#End If

'global object variables
Global gwsMainWS As Workspace       'main workspace object
Global gdbCurrentDB As Database     'main database object
Global gbDBOpenFlag As Integer      'flag to know if a db is open
Global gPropObject As Object        'object to show properties on
Global gDataCtlObj As Object        'global data control object
Global gtdfTableDef As TableDef     'global tabledef used by frmTblStruct
Global gnFormType As Integer        'form type chosen on main form
                                    '0 = data control
                                    '1 = no data control
                                    '2 = grid control
Global gnRecordsetType As Integer   'recordset type chosen on main form
                                    '0 = table
                                    '1 = dynaset
                                    '2 = snapshot

'global database variables
Global gsDataType As String         'data backend = connect string
                                    'for everything accept Access
Global gsDBName As String           'current database name
Global gsODBCDatasource As String   'global odbc values
Global gsODBCDatabase As String     '       "
Global gsODBCUserName As String     '       "
Global gsODBCPassword As String     '       "
Global gsDynaString As String       'global sql statament
Global gsTblName As String          '
Global glQueryTimeout As Long       '
Global glLoginTimeout As Long       '
Global gsTableDynaFilter As String  '
Global gnReadOnly As Integer        'database readonly flag

'other global vars
Global gobjIDEAppInst As Object     'add-in variable
Global gsZoomData As String         'pass info to the zoom form
Global gsNewLine As String          'CRLF holder

'multi user variables
Global gnMURetryCnt As Integer
Global gnMUDelay As Integer
Global gnMULocking As Integer       'flag for pessimistic or optimistic locking

'global find values used to pass info between
'the dynaset form and find dialog
Global gbFindFailed As Integer
Global gsFindExpr As String
Global gsFindOp As String
Global gsFindField As String
Global gnFindType As Integer
Global gbFromTableView As Integer

'global seek values used to pass info between
'the table form and find dialog
Global gsSeekOperator As String
Global gsSeekValue As String

'global flags
Global gbDBChanged As Integer       '
Global gbTransPending As Integer    'used for transaction management
Global gbFromSQL As Integer         'source of sql statement was SQL form
Global gbAddTableFlag As Integer    'new or design designator
Global gbSettingDataCtl As Integer  'used to reset data control props

'data backend types used as the connect string
Global Const gsJETMDB = "Jet Engine MDB"
Global Const gsDBASEIII = "Dbase III;"
Global Const gsDBASEIV = "Dbase IV;"
Global Const gsFOXPRO20 = "FoxPro 2.0;"
Global Const gsFOXPRO25 = "FoxPro 2.5;"
Global Const gsFOXPRO26 = "FoxPro 2.6;"
Global Const gsPARADOX3X = "Paradox 3.X;"
Global Const gsPARADOX4X = "Paradox 4.X;"
Global Const gsBTRIEVE = "Btrieve;"
Global Const gsEXCEL30 = "Excel 3.0;"
Global Const gsEXCEL40 = "Excel 4.0;"
Global Const gsEXCEL50 = "Excel 5.0;"
Global Const gsTEXTFILES = "Text;"
Global Const gsSQLDB = "ODBC;"

'global constants
Global Const gsVISDATA4 = "VISDATA4"          'general ini file section
Global Const gsVISDATAINI = "VISDATA.INI"     '
Global Const gsDEFAULT_DRIVER = "SQL Server"  'used for registerdatabase
Global Const gnMSGBOX_YES = 6                 'return from msgbox
Global Const gnMSGBOX_TYPE = 4 + 48 + 256     'yes/no buttons with no as default
Global Const gnEOF_ERR = 626                  '
Global Const gnFTBLS = 0                      '
Global Const gnFFLDS = 1                      '
Global Const gnFINDX = 2                      '
Global Const gnMAX_GRID_ROWS = 31999          '
Global Const gnMAX_MEMO_SIZE = 20000          '
Global Const gnGETCHUNK_CUTOFF = 50           '
Global Const gsNULL_STR = ""                  '
Global Const gnDATACTL_FORM = 0               '
Global Const gnNODATACTL_FORM = 1             '
Global Const gnDATAGRID_FORM = 2              '
Global Const gnRS_PASSTHRU = 8                '
Global Const gnCTLARRAYHEIGHT = 340&          '
Global Const gnSCREEN = 0                     'used to center forms on screen
Global Const gnMDIFORM = 1                    'used to center forms on frmMDI


'------------------------------------------------------------
'this function returns the type of querydef
'for the item selected in the querydefs
'list on the frmTables form
'------------------------------------------------------------
Function ActionQueryType() As String
  Dim qdf As QueryDef

  Set qdf = gdbCurrentDB.QueryDefs(frmTables.lstQueryDefs.Text)

  'check to see if it is an action query
  If (qdf.Type And dbQAction) = 0 Then
    ActionQueryType = gsNULL_STR
    Exit Function
  End If

  'must be an action query type
  Select Case qdf.Type
    Case dbQCrosstab
      ActionQueryType = "Cross Tab"
    Case dbQDelete
      ActionQueryType = "Delete"
    Case dbQUpdate
      ActionQueryType = "Update"
    Case dbQAppend
      ActionQueryType = "Append"
    Case dbQMakeTable
      ActionQueryType = "Make Table"
    Case dbQDDL
      ActionQueryType = "DDL"
    Case dbQSQLPassThrough
      ActionQueryType = "SQLPassThrough"
    Case dbQSetOperation
      ActionQueryType = "Set Operation"
    Case dbQSPTBulk
      ActionQueryType = "SPT Bulk"
    Case Else
      ActionQueryType = gsNULL_STR
  End Select

End Function

'------------------------------------------------------------
'this functions adds [] to object names that might need
'them because they have spaces in them
'------------------------------------------------------------
Function AddBrackets(rObjName As String) As String
  'add brackets to object names w/ spaces in them
  If InStr(rObjName, " ") > 0 And Mid(rObjName, 1, 1) <> "[" Then
    AddBrackets = "[" & rObjName & "]"
  Else
    AddBrackets = rObjName
  End If
End Function

Sub CenterMe(rfrm As Object, rwScreenMDI As Integer)
  On Error Resume Next

  If rwScreenMDI = gnSCREEN Then
    'center it on the screen
    rfrm.Top = (Screen.Height - rfrm.Height) \ 2
    rfrm.Left = (Screen.Width - rfrm.Width) \ 2
  Else
    'center it on the MDI form
    If rfrm.MDIChild = True Then
      rfrm.Top = ((frmMDI.Height - rfrm.Height) \ 2) - 800
      rfrm.Left = (frmMDI.Width - rfrm.Width) \ 2
    Else
      rfrm.Top = frmMDI.Top + (frmMDI.Height - rfrm.Height) \ 2
      rfrm.Left = frmMDI.Left + (frmMDI.Width - rfrm.Width) \ 2
    End If
  End If

End Sub

'------------------------------------------------------------
'this function checks to see if a transaction is pending
'and displays a message is one is
'------------------------------------------------------------
Function CheckTransPending(msg As String) As Integer

  If gbTransPending = True Then
    MsgBox msg & gsNewLine & "Execute Commit or Rollback First.", 48
    CheckTransPending = True
  Else
    CheckTransPending = False
  End If

End Function

'------------------------------------------------------------
'clear out the data fields on the table and dynasnap forms
'------------------------------------------------------------
Sub ClearDataFields(frm As Form, nCnt As Integer)
  Dim i As Integer

  'clear out the fields on the main form
  For i = 0 To nCnt - 1
    frm.txtFieldData(i).Text = gsNULL_STR
  Next
End Sub

'------------------------------------------------------------
'this sub closes all frmDynaSnap, frmTableObj and frmDataGrid
'forms by looking for forms with a Tag set to "Recordset"
'------------------------------------------------------------
Sub CloseAllRecordsets()
  Dim i As Integer

  MsgBar "Closing Recordsets", True
  While i < Forms.Count
    If Forms(i).Tag = "Recordset" Then
      Unload Forms(i)
    Else
      i = i + 1
    End If
  Wend
  MsgBar gsNULL_STR, False

End Sub

'------------------------------------------------------------
'this sub closes all frmListCombo forms by looking for
'forms with a Tag set to "ListCombo"
'------------------------------------------------------------
Sub CloseAllListCombos()
  Dim i As Integer

  MsgBar "Closing List/Combo Forms", True
  While i < Forms.Count
    If Forms(i).Tag = "ListCombo" Then
      Unload Forms(i)
    Else
      i = i + 1
    End If
  Wend
  MsgBar gsNULL_STR, False

End Sub

'------------------------------------------------------------
'this function copies data from one table to another
'from the frmCopyStruct form
'It demonstrates the use of transactions to speed up this
'type of operation
'------------------------------------------------------------
Function CopyData(rFromDB As Database, rToDB As Database, rFromName As String, rToName As String) As Integer
  On Error GoTo CopyErr

  Dim recRecordset1 As Recordset, recRecordset2 As Recordset
  Dim i As Integer
  Dim nRC As Integer
  Dim fld As Field

  'open both recordsets
  Set recRecordset1 = rFromDB.OpenRecordset(rFromName)
  Set recRecordset2 = rToDB.OpenRecordset(rToName)
  gwsMainWS.BeginTrans
  While recRecordset1.EOF = False
    recRecordset2.AddNew
    'this loop copies the data from each field to
    'the new table
'    For Each fld In recRecordset1.Fields
    For i = 0 To recRecordset1.Fields.Count - 1
      Set fld = recRecordset1.Fields(i)
      recRecordset2(fld.Name).Value = fld.Value
    Next
    recRecordset2.Update
    recRecordset1.MoveNext
    nRC = nRC + 1
    'this test will commit transactions every 1000 records
    If nRC = 1000 Then
      gwsMainWS.CommitTrans
      gwsMainWS.BeginTrans
      nRC = 0
    End If
  Wend
  gwsMainWS.CommitTrans

  CopyData = True
  Exit Function

CopyErr:
  gwsMainWS.Rollback
  ShowError
  CopyData = False
  Exit Function

End Function

'------------------------------------------------------------
'this function copies the structure of one table to
'a new table in the same or different database
'------------------------------------------------------------
Function CopyStruct(vFromDB As Database, vToDB As Database, vFromName As String, vToName As String, bCreateIndex As Integer) As Integer
  On Error GoTo CSErr

  Dim i As Integer
  Dim tblTableDefObj As TableDef
  Dim fldFieldObj As Field
  Dim indIndexObj As Index
  Dim tdf As TableDef
  Dim fld As Field
  Dim idx As Index

  'search to see if table exists
NameSearch:
'  For Each tdf In vToDB.Tabledefs
  For i = 0 To vToDB.TableDefs.Count - 1
    Set tdf = vToDB.TableDefs(i)
    If UCase(tdf.Name) = UCase(vToName) Then
      If MsgBox(vToName & " already exists, delete it?", 4) = gnMSGBOX_YES Then
         vToDB.TableDefs.Delete tdf.Name
      Else
         vToName = InputBox("Enter New Table Name:")
         If Len(vToName) = 0 Then
           Exit Function
         Else
           GoTo NameSearch
         End If
      End If
      Exit For
    End If
  Next

  Set tblTableDefObj = gdbCurrentDB.CreateTableDef()

  'strip off owner if needed
  tblTableDefObj.Name = StripOwner(vToName)

  'create the fields
'  For Each fld In vFromDB.Tabledefs(vFromName).Fields
  For i = 0 To vFromDB.TableDefs(vFromName).Fields.Count - 1
    Set fld = vFromDB.TableDefs(vFromName).Fields(i)
    Set fldFieldObj = vFromDB.TableDefs(vFromName).CreateField(fld.Name, fld.Type, fld.Size)
    tblTableDefObj.Fields.Append fldFieldObj
  Next

  'create the indexes
  If bCreateIndex <> False Then
'    For Each idx In vFromDB.Tabledefs(vFromName).Indexes
    For i = 0 To vFromDB.TableDefs(vFromName).Indexes.Count - 1
      Set idx = vFromDB.TableDefs(vFromName).Indexes(i)
      Set indIndexObj = vFromDB.TableDefs(vFromName).CreateIndex(idx.Name)
      With indIndexObj
        indIndexObj.Fields = idx.Fields
        indIndexObj.Unique = idx.Unique
        If gsDataType <> gsSQLDB Then
          indIndexObj.Primary = idx.Primary
        End If
      End With
      tblTableDefObj.Indexes.Append indIndexObj
    Next
  End If

  'append the new table
  vToDB.TableDefs.Append tblTableDefObj

  CopyStruct = True
  Exit Function

CSErr:
  ShowError
  CopyStruct = False
  Exit Function

End Function

'------------------------------------------------------------
'sub used to create a sample table and fill it
'with NumbRecs number of rows
'can only be called from the debug window
'for example:
'CreateSampleTable "mytbl",100
'------------------------------------------------------------
Sub CreateSampleTable(TblName As String, NumbRecs As Long)
  Dim rec As Recordset
  Dim ii As Long
  Dim nCnt As Integer
  Dim tdf As TableDef
  Dim fld As Field
  Dim idx As Index

  'create the data holding table
  Set tdf = gdbCurrentDB.CreateTableDef(TblName)

  Set fld = tdf.CreateField("name", dbText, 25)
  tdf.Fields.Append fld

  Set fld = tdf.CreateField("address", dbText, 25)
  tdf.Fields.Append fld

  Set fld = tdf.CreateField("record", dbText, 10)
  tdf.Fields.Append fld

  Set fld = tdf.CreateField("id", dbLong)
  tdf.Fields.Append fld

  'add the indexes
  Set idx = tdf.CreateIndex(TblName & "1")
  idx.Fields = "name"
  idx.Unique = False
  tdf.Indexes.Append idx

  Set idx = tdf.CreateIndex(TblName & "2")
  idx.Fields = "id"
  idx.Unique = True
  tdf.Indexes.Append idx

  gdbCurrentDB.TableDefs.Append tdf

  'add records to the table in reverse order
  'so indexes have some work to do
  Set rec = gdbCurrentDB.OpenRecordset(TblName)
  nCnt = 0
  gwsMainWS.BeginTrans
  For ii = NumbRecs To 1 Step -1
    rec.AddNew
    rec(0) = "name" & ii
    rec(1) = "addr" & ii
    rec(2) = "rec" & ii
    rec(3) = ii
    rec.Update
    nCnt = nCnt + 1
    If nCnt = 1000 Then
      gwsMainWS.CommitTrans
      gwsMainWS.BeginTrans
      nCnt = 0
    End If
  Next
  gwsMainWS.CommitTrans

End Sub

'------------------------------------------------------------
'this function fills a list or combo box with the
'tables (and querydefs) from the Tables form
'ItemData is set to 0 for a tabledef and 1 for a querydef
'------------------------------------------------------------
Sub GetTableList(rctl As Control, rbIncludeQDFs As Integer, rbIncludeSys As Integer, rbStripConnect As Integer)
  On Error GoTo FTLErr

  Dim i As Integer
  Dim sTmp As String

  'add the tabledefs
  For i = 0 To frmTables.lstTables.ListCount - 1
    sTmp = frmTables.lstTables.List(i)
    If rbIncludeSys = True Then
      If rbStripConnect = True Then
        rctl.AddItem StripConnect(sTmp)
      Else
        rctl.AddItem sTmp
      End If
      rctl.ItemData(rctl.NewIndex) = 0
    Else
      If (gdbCurrentDB.TableDefs(StripConnect(sTmp)).Attributes And dbSystemObject) = 0 Then
        If rbStripConnect = True Then
          rctl.AddItem StripConnect(sTmp)
        Else
          rctl.AddItem sTmp
        End If
        rctl.ItemData(rctl.NewIndex) = 0
      End If
    End If
  Next

  'add the querydefs
  If rbIncludeQDFs = True Then
    For i = 0 To frmTables.lstQueryDefs.ListCount - 1
      rctl.AddItem frmTables.lstQueryDefs.List(i)
      rctl.ItemData(rctl.NewIndex) = 1
    Next
  End If

  Exit Sub

FTLErr:
  ShowError
  Exit Sub

End Sub

'------------------------------------------------------------
'this function returns the numeric field type
'for the passed in string
'------------------------------------------------------------
Function GetFieldType(rFldType As String) As Integer
  'return field length
  If rFldType = "Text" Then
    GetFieldType = dbText
  Else
    Select Case rFldType
      Case "Counter"
        GetFieldType = dbLong
      Case "Boolean"
        GetFieldType = dbBoolean
      Case "Byte"
        GetFieldType = dbByte
      Case "Integer"
        GetFieldType = dbInteger
      Case "Long"
        GetFieldType = dbLong
      Case "Currency"
        GetFieldType = dbCurrency
      Case "Single"
        GetFieldType = dbSingle
      Case "Double"
        GetFieldType = dbDouble
      Case "Date/Time"
        GetFieldType = dbDate
      Case "Binary"
        GetFieldType = dbLongBinary
      Case "Memo"
        GetFieldType = dbMemo
    End Select
  End If

End Function

'------------------------------------------------------------
'this function returns an appropriate field width for the
'field type passed in to be used for the control width on
'frmDynaSnap and frmTableObj forms
'------------------------------------------------------------
Function GetFieldWidth(rType As Integer)
  Select Case rType
    Case dbBoolean
      GetFieldWidth = 850
    Case dbByte
      GetFieldWidth = 650
    Case dbInteger
      GetFieldWidth = 900
    Case dbLong
      GetFieldWidth = 1100
    Case dbCurrency
      GetFieldWidth = 1800
    Case dbSingle
      GetFieldWidth = 1800
    Case dbDouble
      GetFieldWidth = 2200
    Case dbDate
      GetFieldWidth = 2000
    Case dbText
      GetFieldWidth = 3250
    Case dbLongBinary
      GetFieldWidth = 3250
    Case dbMemo
      GetFieldWidth = 3250
    Case Else
      GetFieldWidth = 3250
  End Select

End Function

'------------------------------------------------------------
'this function returns the INI file setting for the
'passed in item and section
'------------------------------------------------------------
Function GetINIString(ByVal vsItem As String, ByVal vsDefault As String, ByVal vsSection As String) As String
  GetINIString = GetSetting("VisData", vsSection, vsItem, vsDefault)
End Function

'------------------------------------------------------------
'this function returns the number of records in a
'recordset of any type
'------------------------------------------------------------
Function GetNumbRecs(rrsRecSet As Recordset) As Long
  Dim rsClone As Recordset

  On Error GoTo GNRErr

  MsgBar "Calculating Number of Rows in Recordset", True

  If rrsRecSet.Type = dbOpenTable Then
    GetNumbRecs = rrsRecSet.RecordCount
  Else
    Set rsClone = rrsRecSet.Clone()
    If Not rsClone.EOF Then rsClone.MoveLast
    GetNumbRecs = rsClone.RecordCount
    rsClone.Close
  End If

  Exit Function

GNRErr:
  'just return because row count is non critical
  GetNumbRecs = -1
  Exit Function

End Function


'------------------------------------------------------------
'this sub hides the menus and toolbar that only apply
'when a database is open
'------------------------------------------------------------
Sub HideDBTools()
  frmMDI.mnuDBProperties.Visible = False
  frmMDI.mnuDBClose.Visible = False
  frmMDI.mnuJet.Visible = False
  frmMDI.mnuUtil.Visible = False
End Sub

'------------------------------------------------------------
'this sub displays the passed in message in the status
'bar on the bottom of the MDI form
'------------------------------------------------------------
Sub MsgBar(rsMsg As String, rPauseFlag As Integer)
  If Len(rsMsg) = 0 Then
    frmMDI.txtStatusMsg.Text = "Ready"
  Else
    If rPauseFlag = True Then
      frmMDI.txtStatusMsg.Text = rsMsg & ", please wait..."
    Else
      frmMDI.txtStatusMsg.Text = rsMsg
    End If
  End If
  frmMDI.txtStatusMsg.Refresh
End Sub

'------------------------------------------------------------
'this sub refreshs any table list passed in as an object
'------------------------------------------------------------
Sub RefreshTables(rListObject As Object, rIncludeQueries As Integer)
  On Error GoTo TRefErr

  Dim tdf As TableDef
  Dim qdf As QueryDef
  Dim sTmp As String

  Dim i As Integer

  MsgBar "Refreshing Table List", True
  SetHourglass

  rListObject.Clear
  If frmMDI.mnuPAllowSys.Checked = True Then
    'list all tables
    For Each tdf In gdbCurrentDB.TableDefs
      If (tdf.Attributes And dbAttachedTable) = dbAttachedTable Then
        If Left(tdf.Connect, 1) = ";" Then
          'must be a jet attached table
          rListObject.AddItem tdf.Name & " -> Jet"
        Else
          'must be an ISAM attached table
          rListObject.AddItem tdf.Name & " -> " & Left(tdf.Connect, InStr(tdf.Connect, ";") - 1)
        End If
      ElseIf (tdf.Attributes And dbAttachedODBC) = dbAttachedODBC Then
        rListObject.AddItem tdf.Name & " -> ODBC"
      Else
        rListObject.AddItem tdf.Name
      End If
    Next
  Else
    'don't list system tables
    For Each tdf In gdbCurrentDB.TableDefs
      If (tdf.Attributes And dbSystemObject) = 0 Then
        If (tdf.Attributes And dbAttachedTable) = dbAttachedTable Then
          If Left(tdf.Connect, 1) = ";" Then
            'must be a jet attached table
            rListObject.AddItem tdf.Name & " -> Jet"
          Else
            'must be an ISAM attached table
            rListObject.AddItem tdf.Name & " -> " & Left(tdf.Connect, InStr(tdf.Connect, ";") - 1)
          End If
        ElseIf (tdf.Attributes And dbAttachedODBC) = dbAttachedODBC Then
          rListObject.AddItem tdf.Name & " -> ODBC"
        Else
          rListObject.AddItem tdf.Name
        End If
      End If
    Next
  End If
  'select the 1st item if there is any
  If rListObject.ListCount > 0 Then
    rListObject.ListIndex = 0
  End If

  If rIncludeQueries Then
    If gdbCurrentDB.QueryDefs.Count > 0 Then
      ListItemNames gdbCurrentDB.QueryDefs, frmTables.lstQueryDefs, True
    End If
    'select the 1st item if there is any
    If frmTables.lstQueryDefs.ListCount > 0 Then
      frmTables.lstQueryDefs.ListIndex = 0
    End If
  End If

  Screen.MousePointer = vbDefault
  MsgBar gsNULL_STR, False
  Exit Sub

TRefErr:
  ShowError
  Exit Sub

End Sub

'------------------------------------------------------------
'this function returns the size of the field type
'passed in for use on the frmAddField form
'------------------------------------------------------------
Function SetFldProperties(rnType As Integer) As Integer
  'return field length
  Select Case rnType
    Case dbBoolean
      SetFldProperties = 1
    Case dbByte
      SetFldProperties = 1
    Case dbInteger
      SetFldProperties = 2
    Case dbLong
      SetFldProperties = 4
    Case dbCurrency
      SetFldProperties = 8
    Case dbSingle
      SetFldProperties = 4
    Case dbDouble
      SetFldProperties = 8
    Case dbDate
      SetFldProperties = 8
    Case dbText
      SetFldProperties = 50
    Case dbLongBinary
      SetFldProperties = 0
    Case dbMemo
      SetFldProperties = 0
  End Select
End Function

'------------------------------------------------------------
'this sub sets the HourGlass icon for the mouse
'------------------------------------------------------------
Sub SetHourglass()
  DoEvents  'cause forms to repaint before going on
  Screen.MousePointer = vbHourglass
End Sub

'------------------------------------------------------------
'this sub shows the menus and toolbar that only apply
'when a database is open
'------------------------------------------------------------
Sub ShowDBTools()
  frmMDI.mnuDBProperties.Visible = True
  frmMDI.mnuDBClose.Visible = True
  frmMDI.mnuUtil.Visible = True

  'set general items that apply/don't apply to MDBs
  If gsDataType = gsJETMDB Then
    frmMDI.mnuJet.Visible = True
    frmSQL.cmdSaveQueryDef.Visible = True
    frmTables.optTables.Visible = True
    frmTables.optQueryDefs.Visible = True
    frmTables.Caption = "Tables/Queries"
    frmMDI.mnuPURename.Visible = True
  Else
    frmMDI.mnuJet.Visible = False
    frmSQL.cmdSaveQueryDef.Visible = False
    frmTables.optTables.Visible = False
    frmTables.optQueryDefs.Visible = False
    frmTables.optTables.Value = True
    frmTables.Caption = "Tables"
    frmMDI.mnuPURename.Visible = False
  End If

  'set ODBC specific items
  If gsDataType = gsSQLDB Then
    frmMDI.optPassThru.Visible = True
    frmMDI.optTable.Visible = False
    If frmMDI.optTable.Value = True Then
      frmMDI.optDynaset.Value = True
    End If
  Else
    frmMDI.optPassThru.Visible = False
    frmMDI.optTable.Visible = True
    If frmMDI.optPassThru.Value = True Then
      frmMDI.optDynaset.Value = True
    End If
  End If

  'activate the Pack menu item for xbase dbs
  If gsDataType = gsDBASEIII Or gsDataType = gsDBASEIV Or gsDataType = gsFOXPRO20 Or gsDataType = gsFOXPRO25 Or gsDataType = gsFOXPRO26 Then
    frmMDI.mnuPUPack.Visible = True
  Else
    frmMDI.mnuPUPack.Visible = False
  End If

End Sub

'------------------------------------------------------------
'this sub displays the error message with it's Err code
'and prompts to show the Errors collection if it
'is a data access type error
'------------------------------------------------------------
Sub ShowError()
  Dim sTmp As String

  Screen.MousePointer = vbDefault
  MsgBar gsNULL_STR, False

  sTmp = "The following Error occurred:" & gsNewLine & gsNewLine
  'add the error string
  sTmp = sTmp & Error & gsNewLine
  'add the error number
  sTmp = sTmp & "Number: " & Err

  Beep
  'check to see if the error is from the db errors collection
  If DBEngine.Errors.Count > 0 Then
    If DBEngine.Errors(0).Number = Err Then
      'add the prompt to display the errors collection
      sTmp = sTmp & gsNewLine & gsNewLine & "Display the Data Access Errors Collection?"
      'beep and show the error
      If MsgBox(sTmp, gnMSGBOX_TYPE) = gnMSGBOX_YES Then
        RefreshErrors
      End If
    Else
      MsgBox sTmp
    End If
  Else
    MsgBox sTmp
  End If

End Sub

'------------------------------------------------------------
'this function strips the attached table connect string off
'------------------------------------------------------------
Function StripConnect(rsTblName As String) As String
  If InStr(rsTblName, "->") > 0 Then
    StripConnect = Left(rsTblName, InStr(rsTblName, "->") - 2)
  Else
    StripConnect = rsTblName
  End If

End Function

'------------------------------------------------------------
'this function strips the [] off of data objects
'------------------------------------------------------------
Function StripBrackets(rsObjName As String) As String
  'add brackets to object names w/ spaces in them
  If Mid(rsObjName, 1, 1) = "[" Then
    StripBrackets = Mid(rsObjName, 2, Len(rsObjName) - 2)
  Else
    StripBrackets = rsObjName
  End If

End Function

'------------------------------------------------------------
'this function strips the file name from a path\file string
'------------------------------------------------------------
Function StripFileName(rsFileName As String) As String
  On Error Resume Next
  Dim i As Integer

  For i = Len(rsFileName) To 1 Step -1
    If Mid(rsFileName, i, 1) = "\" Then
      Exit For
    End If
  Next

  StripFileName = Mid(rsFileName, 1, i - 1)

End Function

'------------------------------------------------------------
'this function strips the non ACSII chars off memo field
'data before displaying it (not sure this is always needed)
'------------------------------------------------------------
Function StripNonAscii(rvntVal As Variant) As String
  Dim i As Integer
  Dim sTmp As String

  For i = 1 To Len(rvntVal)
    If Asc(Mid(rvntVal, i, 1)) < 32 Or Asc(Mid(rvntVal, i, 1)) > 126 Then
      sTmp = sTmp & " "
    Else
      sTmp = sTmp & Mid(rvntVal, i, 1)
    End If
  Next

  StripNonAscii = sTmp

End Function

'------------------------------------------------------------
'strips the owner off of ODBC table names
'------------------------------------------------------------
Function StripOwner(rsTblName As String) As String

  If InStr(rsTblName, ".") > 0 Then
    rsTblName = Mid(rsTblName, InStr(rsTblName, ".") + 1, Len(rsTblName))
  End If
  StripOwner = rsTblName

End Function

'------------------------------------------------------------
'returns the true or false string
'------------------------------------------------------------
Function stTrueFalse(rvntTF As Variant) As String
  If rvntTF = True Then
    stTrueFalse = "True"
  Else
    stTrueFalse = "False"
  End If
End Function

'------------------------------------------------------------
'returns "" if a field is Null
'------------------------------------------------------------
Function vFieldVal(rvntFieldVal As Variant) As Variant
  If IsNull(rvntFieldVal) Then
    vFieldVal = gsNULL_STR
  Else
    vFieldVal = CStr(rvntFieldVal)
  End If
End Function

'------------------------------------------------------------
'loads all saved INI settings for VisData
'------------------------------------------------------------
Sub LoadINISettings()
  On Error Resume Next

  Dim sTmp As String
  Dim x As Integer

  glQueryTimeout = Val(GetINIString("QueryTimeout", "5", gsVISDATA4))
  glLoginTimeout = Val(GetINIString("LoginTimeout", "20", gsVISDATA4))

  sTmp = GetINIString("ViewMode", CStr(gnNODATACTL_FORM), gsVISDATA4)
  Select Case Val(sTmp)
    Case gnNODATACTL_FORM
      frmMDI.optNoDataCtl.Value = True
    Case gnDATACTL_FORM
     frmMDI.optDataCtl.Value = True
    Case gnDATAGRID_FORM
      frmMDI.optDataGrid.Value = True
  End Select
  sTmp = GetINIString("RecordsetType", CStr(vbRSTypeDynaset), gsVISDATA4)
  Select Case Val(sTmp)
    Case vbRSTypeDynaset
      frmMDI.optDynaset.Value = True
    Case vbRSTypeSnapShot
      frmMDI.optSnapshot.Value = True
    Case vbRSTypeTable
      frmMDI.optTable.Value = True
    Case gnRS_PASSTHRU
      frmMDI.optPassThru.Value = True
  End Select

  frmMDI.mnuPOpenOnStartup.Checked = Val(GetINIString("OpenOnStartup", "0", gsVISDATA4))
  frmMDI.mnuPShowPerf.Checked = Val(GetINIString("ShowPerf", "0", gsVISDATA4))
  frmMDI.mnuPAllowSys.Checked = Val(GetINIString("AllowSys", "0", gsVISDATA4))

  'get the most recently used databases
  For x = 1 To 4
    sTmp = GetINIString("MRUDatabase" & x, "", gsVISDATA4)
    If Len(sTmp) > 0 Then
      frmMDI.mnuBarMRU.Visible = True
      frmMDI.mnuDBMRU(x).Caption = "&" & x & " " & sTmp
      frmMDI.mnuDBMRU(x).Visible = True
      sTmp = GetINIString("MRUConnect" & x, "", gsVISDATA4)
      frmMDI.mnuDBMRU(x).Tag = sTmp
    End If
  Next

  'get the last used database out of the INI file
  gsDataType = GetINIString("DataType", gsNULL_STR, gsVISDATA4)
  gsDBName = GetINIString("DatabaseName", gsNULL_STR, gsVISDATA4)
  gsODBCDatasource = GetINIString("ODBCDatasource", gsNULL_STR, gsVISDATA4)
  gsODBCDatabase = GetINIString("ODBCDatabase", gsNULL_STR, gsVISDATA4)
  gsODBCUserName = GetINIString("ODBCUserName", gsNULL_STR, gsVISDATA4)
  gsODBCPassword = GetINIString("ODBCPassword", gsNULL_STR, gsVISDATA4)

  x = Val(GetINIString("WindowState", "2", gsVISDATA4))
  If x <> 1 Then
    frmMDI.WindowState = x
  Else
    frmMDI.WindowState = 0
  End If
  If frmMDI.WindowState = 0 Then
    frmMDI.Left = Val(GetINIString("WindowLeft", "0", gsVISDATA4))
    frmMDI.Top = Val(GetINIString("WindowTop", "0", gsVISDATA4))
    frmMDI.Width = Val(GetINIString("WindowWidth", "9135", gsVISDATA4))
    frmMDI.Height = Val(GetINIString("WindowHeight", "6900", gsVISDATA4))
  End If

End Sub

'------------------------------------------------------------
'saves current VisData values in VISDATA.INI
'------------------------------------------------------------
Sub SaveINISettings()
  On Error Resume Next

  Dim i As Integer

  SaveSetting "VisData", gsVISDATA4, "DataType", gsDataType
  SaveSetting "VisData", gsVISDATA4, "DatabaseName", gsDBName
  SaveSetting "VisData", gsVISDATA4, "ODBCDatasource", gsODBCDatasource
  SaveSetting "VisData", gsVISDATA4, "ODBCDatabase", gsODBCDatabase
  SaveSetting "VisData", gsVISDATA4, "ODBCUserName", gsODBCUserName
  SaveSetting "VisData", gsVISDATA4, "ODBCPassword", gsODBCPassword
  SaveSetting "VisData", gsVISDATA4, "QueryTimeout", glQueryTimeout
  SaveSetting "VisData", gsVISDATA4, "LoginTimeout", glLoginTimeout
  DBEngine.LoginTimeout = glLoginTimeout
  SaveSetting "VisData", gsVISDATA4, "ViewMode", gnFormType
  SaveSetting "VisData", gsVISDATA4, "RecordsetType", gnRecordsetType

  SaveSetting "VisData", gsVISDATA4, "OpenOnStartup", IIf(frmMDI.mnuPOpenOnStartup.Checked, "-1", "0")
  SaveSetting "VisData", gsVISDATA4, "ShowPerf", IIf(frmMDI.mnuPShowPerf.Checked, "-1", "0")
  SaveSetting "VisData", gsVISDATA4, "AllowSys", IIf(frmMDI.mnuPAllowSys.Checked, "-1", "0")

  For i = 1 To 4
    If frmMDI.mnuDBMRU(i).Visible Then
      SaveSetting "VisData", gsVISDATA4, "MRUDatabase" & i, Mid(frmMDI.mnuDBMRU(i).Caption, 4, Len(frmMDI.mnuDBMRU(i).Caption))
      SaveSetting "VisData", gsVISDATA4, "MRUConnect" & i, frmMDI.mnuDBMRU(i).Tag
    Else
      SaveSetting "VisData", gsVISDATA4, "MRUDatabase" & i, ""
      SaveSetting "VisData", gsVISDATA4, "MRUConnect" & i, ""
    End If
  Next

  SaveSetting "VisData", gsVISDATA4, "WindowState", frmMDI.WindowState
  If frmMDI.WindowState = vbNormal Then
    SaveSetting "VisData", gsVISDATA4, "WindowTop", frmMDI.Top
    SaveSetting "VisData", gsVISDATA4, "WindowLeft", frmMDI.Left
    SaveSetting "VisData", gsVISDATA4, "WindowWidth", frmMDI.Width
    SaveSetting "VisData", gsVISDATA4, "WindowHeight", frmMDI.Height
  End If

  'only save the sql text if there are no carriage returns in it
  'because they are not preserved in the INI file
  If InStr(frmSQL.txtSQLStatement.Text, Chr(13)) = 0 Then
    SaveSetting "VisData", gsVISDATA4, "SQLStatement", frmSQL.txtSQLStatement.Text
  End If
  If frmSQL.WindowState = vbNormal Then
    SaveSetting "VisData", gsVISDATA4, "SQLWindowTop", frmSQL.Top
    SaveSetting "VisData", gsVISDATA4, "SQLWindowLeft", frmSQL.Left
    SaveSetting "VisData", gsVISDATA4, "SQLWindowWidth", frmSQL.Width
    SaveSetting "VisData", gsVISDATA4, "SQLWindowHeight", frmSQL.Height
  End If
  If frmTables.WindowState = vbNormal Then
    SaveSetting "VisData", gsVISDATA4, "TBLWindowTop", frmTables.Top
    SaveSetting "VisData", gsVISDATA4, "TBLWindowLeft", frmTables.Left
    SaveSetting "VisData", gsVISDATA4, "TBLWindowWidth", frmTables.Width
    SaveSetting "VisData", gsVISDATA4, "TBLWindowHeight", frmTables.Height
  End If
End Sub

'------------------------------------------------------------
'this sub will open the appropriate data type form and
'display the appropriate msg in the status bar based on
'user selected options on the main MDI form
'------------------------------------------------------------
Sub OpenTable(rName As String)
  Dim sTmp As String
  Dim nAttach As Integer

  If gsDataType = gsJETMDB Then   'look for attached tables if it's an MDB
    If (gdbCurrentDB.TableDefs(rName).Attributes And dbAttachedTable) = dbAttachedTable Then
      nAttach = 1
    ElseIf (gdbCurrentDB.TableDefs(rName).Attributes And dbAttachedODBC) = dbAttachedODBC Then
      nAttach = 2
    End If
    If nAttach > 0 And frmMDI.optTable.Value = True Then
      Beep
      If MsgBox("Can't do OpenTable on an Attached Table, Use Dynaset?", gnMSGBOX_TYPE) = gnMSGBOX_YES Then
        frmMDI.optDynaset.Value = True         'reset to recordset
      Else
        Exit Sub
      End If
    End If
  End If

  sTmp = "Opening "

  If frmMDI.optTable.Value = True Then
    sTmp = sTmp & "Full Table "
  ElseIf frmMDI.optDynaset.Value = True Then
    sTmp = sTmp & "Single Table Dynaset "
  ElseIf frmMDI.optSnapshot.Value = True Then
    sTmp = sTmp & "Single Table Snapshot "
  ElseIf frmMDI.optPassThru.Value = True Then
    sTmp = sTmp & "PassThru Snapshot "
  End If

  If nAttach = 1 Then
    sTmp = sTmp & " on Attached Table"
  ElseIf nAttach = 2 Then
    sTmp = sTmp & " on Attached ODBC Table"
  End If

  MsgBar sTmp, True

  If frmMDI.optNoDataCtl.Value = True Then
    If frmMDI.optTable.Value = True Then
      Dim frmTBL As New frmTableObj
      frmTBL.Show
    Else
      Dim frmDS As New frmDynaSnap
      frmDS.Show
    End If
  ElseIf frmMDI.optDataCtl.Value = True Then
    Dim frmDC As New frmDataControl
    frmDC.Show
  ElseIf frmMDI.optDataGrid.Value = True Then
    Dim frmDG As New frmDataGrid
    frmDG.Show
  End If

End Sub

'------------------------------------------------------------
'opens a QueryDef with the user selected form type
'------------------------------------------------------------
Sub OpenQuery(rName As String)
  Dim qd As QueryDef
  Dim sQueryType As String

  sQueryType = ActionQueryType()
  Set qd = gdbCurrentDB.QueryDefs(frmTables.lstQueryDefs.Text)
  If qd.ReturnsRecords = True And frmMDI.optTable.Value = True Then
    Beep
    If MsgBox("Can't do OpenTable on a QueryDef, Use Dynaset?", gnMSGBOX_TYPE) = gnMSGBOX_YES Then
      frmMDI.optDynaset.Value = True         'reset to recordset
    Else
      Exit Sub
    End If
  End If

  gsDynaString = qd.SQL

  If qd.ReturnsRecords = True Then
    If qd.Type = dbQSQLPassThrough Or frmMDI.optSnapshot.Value = True Then
      MsgBar "Opening Query Snapshot", True
    Else
      MsgBar "Opening Query Dynaset", True
    End If
    If frmMDI.optNoDataCtl = True Then
      Dim frmDS As New frmDynaSnap
      frmDS.Show
    ElseIf frmMDI.optDataCtl.Value = True Then
      Dim frmDC As New frmDataControl
      frmDC.Show
    ElseIf frmMDI.optDataGrid.Value = True Then
      Dim frmDG As New frmDataGrid
      frmDG.Show
    End If
  Else
    Screen.MousePointer = vbDefault
    If MsgBox("Run " & sQueryType & " Query?", gnMSGBOX_TYPE) = gnMSGBOX_YES Then
      SetHourglass
      MsgBar "Executing " & sQueryType & " Query", True
      qd.Execute
    End If
  End If
End Sub

'------------------------------------------------------------
'this sub displays properties for the passed in object
'------------------------------------------------------------
Sub ShowProperties(rName As String, rObj As Object)
  On Error GoTo SPErr

  Dim frm As New frmPropertySheet

  SetHourglass
  Set gPropObject = rObj
  frm.Caption = rName & " Properties"
  frm.Show

  Exit Sub

SPErr:
  ShowError
  Exit Sub

End Sub

'------------------------------------------------------------
'this function sets the list to the correct item
'after the right mouse button was clicked
'------------------------------------------------------------
Function SetPropItem(rLst As Object, rY As Single) As Integer
  On Error GoTo SPIErr

  Dim i As Integer

  If rLst.ListCount = 0 Then
    SetPropItem = False
    Exit Function
  End If

  'get the item height
  i = rLst.Parent.TextHeight(rLst.List(0))
  'get the item from the Y coordinate
  i = rY \ i
  'check for it off the bottom
  If i + rLst.TopIndex > rLst.ListCount - 1 Then
    SetPropItem = False
    Exit Function
  End If
  'set the index
  rLst.ListIndex = i + rLst.TopIndex

  SetPropItem = True
  Exit Function

SPIErr:
  SetPropItem = False
  Exit Function

End Function

'------------------------------------------------------------
'this sub closes all object property forms
'------------------------------------------------------------
Sub CloseAllPropForms()
  Dim i As Integer

  MsgBar "Closing Property Forms", True
  While i < Forms.Count
    If Forms(i).Tag = "Properties" Then
      Unload Forms(i)
    Else
      i = i + 1
    End If
  Wend
  MsgBar gsNULL_STR, False
End Sub

'------------------------------------------------------------
'this sub display all field data in the current row
'on the table and dynasnap forms
'------------------------------------------------------------
Sub DisplayCurrentRecord(frm As Object, rec As Recordset, lCnt As Long, bNew As Integer)
  Dim i As Integer
  Dim sCurrStat As String
  Dim lCurrRec As Long
  Dim bNoInd As Integer

  On Error GoTo DCRErr

  SetHourglass

  sCurrStat = "Row "

  'check to see if a table w/ 0 indexes is in use
  If rec.Type = dbOpenTable Then
    If gdbCurrentDB(rec.Name).Indexes.Count = 0 Then
      bNoInd = True
    End If
  End If

  'check for an empty recordset
  If rec.RecordCount > 0 Then
    lCurrRec = (lCnt * (rec.PercentPosition * 0.01)) + 1
  End If

  'check BOF/EOF flag so we know if we
  'are sitting on a valid record
  If bNew = True Then
    If bNoInd = True Then
      sCurrStat = lCnt & " Rows"
    Else
      sCurrStat = sCurrStat & lCurrRec & " of " & lCnt
    End If
  Else
    If rec.BOF = True Then
      sCurrStat = sCurrStat & "(BOF) of " & lCnt
      ClearDataFields frm, rec.Fields.Count
    ElseIf rec.EOF = True Then
      sCurrStat = sCurrStat & "(EOF) of " & lCnt
      ClearDataFields frm, rec.Fields.Count
    Else
      If bNoInd = True Then
        sCurrStat = lCnt & " Rows"
      Else
        sCurrStat = sCurrStat & lCurrRec & " of " & lCnt
      End If
      'place the data in the form fields
      For i = 0 To rec.Fields.Count - 1
        If rec(i).Type = dbMemo Then
          If rec(i).FieldSize() < gnGETCHUNK_CUTOFF Then
            frm.txtFieldData(i).Text = StripNonAscii(vFieldVal(rec(i)))
          Else
            frm.txtFieldData(i).Text = StripNonAscii(vFieldVal(rec(i).GetChunk(0, gnGETCHUNK_CUTOFF)))
          End If
        ElseIf rec(i).Type = dbText Then
          frm.txtFieldData(i).Text = StripNonAscii(vFieldVal(rec(i)))
        Else
          frm.txtFieldData(i).Text = vFieldVal(rec(i))
        End If
      Next
    End If
  End If
  If rec.Updatable = False Then sCurrStat = sCurrStat & "  [Not Updatable]"
  frm.lblStatus.Caption = sCurrStat
  Screen.MousePointer = vbDefault
  Exit Sub

DCRErr:
  ShowError
  Resume Next    'so we can try and display as much data as possible
  Exit Sub

End Sub

'------------------------------------------------------------
'this function checks to see if the passed in name exists
'in either the Tabledefs or Querydefs collection
'it found, it prompts to delete it and returns false
'if the user selects to delete it or true if not
'if not found, it returns false
'------------------------------------------------------------
Function DupeTableName(rName As String) As Integer
  On Error GoTo DTNErr

  Dim tdf As TableDef
  Dim qdf As QueryDef
  Dim i As Integer

  For Each tdf In gdbCurrentDB.TableDefs
    If UCase(tdf.Name) = UCase(rName) Then
      If MsgBox("Table '" & rName & "' exists, Delete it?", gnMSGBOX_TYPE) = gnMSGBOX_YES Then
        gdbCurrentDB.TableDefs.Delete rName
        DupeTableName = False
      Else
        DupeTableName = True
      End If
      Exit Function
    End If
  Next

  If gsDataType = gsJETMDB Then
    For Each qdf In gdbCurrentDB.QueryDefs
      If UCase(qdf.Name) = UCase(rName) Then
        If MsgBox("QueryDef '" & rName & "' exists, Delete it?", gnMSGBOX_TYPE) = gnMSGBOX_YES Then
          gdbCurrentDB.QueryDefs.Delete rName
          DupeTableName = False
        Else
          DupeTableName = True
        End If
        Exit Function
      End If
    Next
  End If

  DupeTableName = False
  Exit Function

DTNErr:
  ShowError
  DupeTableName = False
  Exit Function

End Function

'------------------------------------------------------------
'this sub unloads all forms except for the
'SQL, Tables and MDI form
'------------------------------------------------------------
Sub UnloadAllForms()
  On Error Resume Next

  Dim i As Integer

  'close all forms except for the Tables and SQL forms
  For i = Forms.Count - 1 To 3 Step -1
    Unload Forms(i)
  Next
End Sub

'------------------------------------------------------------
'this sub walks the parameters collection in a parameterized
'query and prompts the user for a value for each parameter
'------------------------------------------------------------
Sub SetParams(rqdf As QueryDef)
  On Error GoTo SPErr

  Dim prm As Parameter
  Dim sTmp As String
  Dim i As Integer

  For Each prm In rqdf.Parameters
    'get the value from the user
    sTmp = InputBox("Enter Value for Parameter '" & prm.Name & "':")
    'store the value
    prm.Value = CVar(sTmp)
  Next

  Exit Sub

SPErr:
  ShowError
  Exit Sub
End Sub

'------------------------------------------------------------
'this sub refreshs the Error form with the latest Errors
'------------------------------------------------------------
Sub RefreshErrors()
  On Error GoTo RErr

  Dim errObj As Error
  Dim i As Integer

  If DBEngine.Errors.Count = 0 Then
    MsgBox "There are no current data access errors!", 48
    Unload frmErrors
    Exit Sub
  End If

  frmErrors.Show
  frmErrors.grdErrors.Rows = DBEngine.Errors.Count + 1
  For i = 0 To DBEngine.Errors.Count - 1
    Set errObj = DBEngine.Errors(i)
    frmErrors.grdErrors.Row = i + 1
    frmErrors.grdErrors.Col = 0
    frmErrors.grdErrors.Text = errObj.Number
    frmErrors.grdErrors.Col = 1
    frmErrors.grdErrors.Text = errObj.Source
    frmErrors.grdErrors.Col = 2
    frmErrors.grdErrors.Text = errObj.Description
  Next
  frmErrors.SetFocus

  Exit Sub

RErr:
  MsgBox "Can't show Errors at this time!", 48
  Unload frmErrors
  Exit Sub
End Sub

'------------------------------------------------------------
'this sub adds the just opened database to the most recently
'used list in the File menu
'------------------------------------------------------------
Sub AddMRU()
  On Error GoTo AMErr

  Dim i As Integer, j As Integer

  '1st look to see if it alread exists and swap it if it does
  For i = 1 To 4
    If UCase(Mid(frmMDI.mnuDBMRU(i).Caption, 4, Len(frmMDI.mnuDBMRU(i).Caption))) = UCase(gsDBName) Then
      For j = i To 2 Step -1
        frmMDI.mnuDBMRU(j).Caption = "&" & j & " " & Mid(frmMDI.mnuDBMRU(j - 1).Caption, 4, Len(frmMDI.mnuDBMRU(j - 1).Caption))
        frmMDI.mnuDBMRU(j).Tag = frmMDI.mnuDBMRU(j - 1).Tag
      Next
      GoTo Finish
    End If
  Next

  'wasn't there so move everything down one
  For i = 3 To 1 Step -1
    frmMDI.mnuDBMRU(i + 1).Caption = "&" & i + 1 & " " & Mid(frmMDI.mnuDBMRU(i).Caption, 4, Len(frmMDI.mnuDBMRU(i).Caption))
    frmMDI.mnuDBMRU(i + 1).Tag = frmMDI.mnuDBMRU(i).Tag
  Next

Finish:
  frmMDI.mnuDBMRU(1).Caption = "&1 " & gsDBName
  If Len(gdbCurrentDB.Connect) = 0 Then
    'handle the Access case where there is no connect string
    frmMDI.mnuDBMRU(1).Tag = gsJETMDB
  Else
    frmMDI.mnuDBMRU(1).Tag = gdbCurrentDB.Connect
  End If
  frmMDI.mnuBarMRU.Visible = True
  For i = 1 To 4
    If Len(Mid(frmMDI.mnuDBMRU(i).Caption, 4, Len(frmMDI.mnuDBMRU(i).Caption))) > 0 Then
      frmMDI.mnuDBMRU(i).Visible = True
    End If
  Next

  Exit Sub

AMErr:
  ShowError
  Exit Sub

End Sub

'------------------------------------------------------------
'this sub breaks out the parts of a ODBC connect string
'and assigns them to the global ODBC variables
'------------------------------------------------------------
Sub GetODBCConnectParts(rsConnect As String)
  On Error Resume Next

  Dim i As Integer
  Dim sTmp As String

  'process the connect string just in case the
  'values came from the ODBC dialogs
  If InStr(rsConnect, "=") Then
    i = 1
    While i <= Len(rsConnect) + 1
      If Mid(rsConnect, i, 1) = ";" Or i = Len(rsConnect) + 1 Then
        If Len(sTmp) > 0 And InStr(sTmp, "=") > 0 Then
          Select Case Mid(sTmp, 1, InStr(1, sTmp, "=") - 1)
            Case "DSN"
              gsODBCDatasource = Mid(sTmp, InStr(1, sTmp, "=") + 1, Len(sTmp))
            Case "DATABASE"
              gsODBCDatabase = Mid(sTmp, InStr(1, sTmp, "=") + 1, Len(sTmp))
            Case "DBQ"
              gsODBCDatabase = Mid(sTmp, InStr(1, sTmp, "=") + 1, Len(sTmp))
            Case "UID"
              gsODBCUserName = Mid(sTmp, InStr(1, sTmp, "=") + 1, Len(sTmp))
            Case "PWD"
              gsODBCPassword = Mid(sTmp, InStr(1, sTmp, "=") + 1, Len(sTmp))
             Case Else
              'nothing
          End Select
        End If
        sTmp = gsNULL_STR
      Else
        sTmp = sTmp + Mid(rsConnect, i, 1)
      End If
      i = i + 1
    Wend
  End If
End Sub

'------------------------------------------------------------
'this is a generic sub that adds the name of each item
'in a collection to the passed in control
'------------------------------------------------------------
Sub ListItemNames(rcCollection As Object, rnCtl As Control, bClearList As Integer)
  On Error GoTo LINErr

  Dim objTmp As Object
  Dim i As Integer

  If bClearList = True Then
    rnCtl.Clear
  End If

  For Each objTmp In rcCollection
    rnCtl.AddItem objTmp.Name
  Next

  Exit Sub

LINErr:
  ShowError
  Exit Sub
End Sub

'------------------------------------------------------------
'these functions may be needed to replace the internal string
'functions with the "B" version for 16 bit to handle
'DBCS strings and use the standard string function for 32 bit
'where Unicode handles the DBCS strings
'------------------------------------------------------------
'Function Mid(sString, lStart, Optional lLength) As String
'#If Win16 Then
'    Mid = VBA.MidB(sString, lStart, lLength)
'#Else
'    Mid = VBA.Mid(sString, lStart, lLength)
'#End If
'End Function

'Function Len(sString) As Variant
'#If Win16 Then
'    Len = VBA.LenB(sString)
'#Else
'    Len = VBA.Len(sString)
'#End If
'End Function

'Function Left(sString, Optional lLength) As String
'#If Win16 Then
'    Left = VBA.LeftB(sString, lLength)
'#Else
'    Left = VBA.Left(sString, lLength)
'#End If
'End Function


'------------------------------------------------------------
'this sub closes the current DB and performs any cleanup
'and resetting of controls, menus, etc.
'------------------------------------------------------------
Sub CloseCurrentDB()
  On Error GoTo DBCloseErr

  If gbDBChanged Then
    If MsgBox("Data has been changed, Commit it?", gnMSGBOX_TYPE) = gnMSGBOX_YES Then
      gwsMainWS.CommitTrans
      gbDBChanged = False
    Else
      If MsgBox("RollBack All changes?", gnMSGBOX_TYPE) = gnMSGBOX_YES Then
        gwsMainWS.Rollback
        gbDBChanged = False
      Else
        Beep
        MsgBox "Can't Close with Transactions Pending!", 48
        Exit Sub
      End If
    End If
  End If

  UnloadAllForms
  frmMDI.Caption = "VisData"

  frmTables.lstTables.Clear
  frmTables.lstQueryDefs.Clear
  frmTables.optTables.Visible = False
  frmTables.optQueryDefs.Visible = False
  frmTables.optTables.Value = True

  HideDBTools

  gbDBOpenFlag = False
  gbTransPending = False
  gsDBName = gsNULL_STR
  gnReadOnly = False

  gdbCurrentDB.Close
  Set gdbCurrentDB = Nothing

  Exit Sub

DBCloseErr:
  ShowError
  Exit Sub
End Sub

'------------------------------------------------------------
'------------------------------------------------------------
Sub OpenLocalDB(doit As Integer)
  On Error GoTo OpenError

  Dim sConnect As String
  Dim sDatabaseName As String

  sDatabaseName = gsDBName

  If gbDBOpenFlag = True Then
    CloseCurrentDB
  End If

  If gbDBOpenFlag = True Then
    Beep
    MsgBox "You must Close First!", 48
    Exit Sub
  Else
    If doit = False Then
      Select Case gsDataType
        Case gsJETMDB
          frmMDI.dlgCMD1.Filter = "Jet Engine MDBs (*.mdb)|*.mdb|All Files (*.*)|*.*"
          frmMDI.dlgCMD1.DialogTitle = "Open Jet Database"
        Case gsDBASEIII
          frmMDI.dlgCMD1.Filter = "Dbase III DBs (*.dbf)|*.dbf"
          frmMDI.dlgCMD1.DialogTitle = "Open Dbase III Database"
        Case gsDBASEIV
          frmMDI.dlgCMD1.Filter = "Dbase IV DBs (*.dbf)|*.dbf"
          frmMDI.dlgCMD1.DialogTitle = "Open Dbase IV Database"
        Case gsFOXPRO20
          frmMDI.dlgCMD1.Filter = "FoxPro DBs (*.dbf)|*.dbf"
          frmMDI.dlgCMD1.DialogTitle = "Open FoxPro 2.0 Database"
        Case gsFOXPRO25
          frmMDI.dlgCMD1.Filter = "FoxPro DBs (*.dbf)|*.dbf"
          frmMDI.dlgCMD1.DialogTitle = "Open FoxPro 2.5 Database"
        Case gsFOXPRO26
          frmMDI.dlgCMD1.Filter = "FoxPro DBs (*.dbf)|*.dbf"
          frmMDI.dlgCMD1.DialogTitle = "Open FoxPro 2.6 Database"
        Case gsPARADOX3X
          frmMDI.dlgCMD1.Filter = "Paradox DBs (*.db)|*.db"
          frmMDI.dlgCMD1.DialogTitle = "Open Paradox 3.X Database"
        Case gsPARADOX4X
          frmMDI.dlgCMD1.Filter = "Paradox DBs (*.db)|*.db"
          frmMDI.dlgCMD1.DialogTitle = "Open Paradox 4.X Database"
        Case gsEXCEL50
          frmMDI.dlgCMD1.Filter = "Excel Files (*.xls)|*.xls"
          frmMDI.dlgCMD1.DialogTitle = "Open Excel File"
        Case gsBTRIEVE
          frmMDI.dlgCMD1.Filter = "Btrieve DBs (FILE.DDF)|FILE.DDF"
          frmMDI.dlgCMD1.DialogTitle = "Open Btrieve Database"
        Case gsTEXTFILES
          frmMDI.dlgCMD1.Filter = "Text Files (*.txt)|*.txt|All Files (*.*)|*.*"
          frmMDI.dlgCMD1.DialogTitle = "Open Text Database"
      End Select

      frmMDI.dlgCMD1.FilterIndex = 1
      frmMDI.dlgCMD1.FileName = gsDBName  '""
      frmMDI.dlgCMD1.CancelError = True
      frmMDI.dlgCMD1.Flags = FileOpenConstants.cdlOFNFileMustExist
      frmMDI.dlgCMD1.ShowOpen

      If Len(frmMDI.dlgCMD1.FileName) > 0 Then
        gsDBName = frmMDI.dlgCMD1.FileName
      Else
        Exit Sub
      End If
    Else
      gsDBName = sDatabaseName
    End If
  End If

  MsgBar "Opening Database", True
  SetHourglass

  'set the connect string
  If gsDataType = gsJETMDB Then
    sConnect = gsNULL_STR
  Else
    sConnect = gsDataType
  End If

  'set the database name for non Jet and Btrieve dbs that
  'came from the Common Dialog
  If gsDataType <> gsJETMDB And gsDataType <> gsBTRIEVE And _
     gsDataType <> gsEXCEL50 And doit = False Then
    'need to strip off filename for these dbs
    sDatabaseName = StripFileName(gsDBName)
    gsDBName = sDatabaseName
  Else
    sDatabaseName = gsDBName
  End If

OneMoreTry:
  If (frmMDI.dlgCMD1.Flags And FileOpenConstants.cdlOFNReadOnly) = FileOpenConstants.cdlOFNReadOnly Then
    gnReadOnly = True
  Else
    gnReadOnly = False
  End If
  Set gdbCurrentDB = gwsMainWS.OpenDatabase(sDatabaseName, False, gnReadOnly, sConnect)
  If gbDBOpenFlag = True Then
    CloseAllRecordsets
    CloseAllPropForms
    CloseAllListCombos
  End If
  gbTransPending = False

  frmMDI.Caption = "VisData:" & sDatabaseName
  gdbCurrentDB.QueryTimeout = glQueryTimeout

  'success
  gbDBOpenFlag = True
  ShowDBTools
  RefreshTables frmTables.lstTables, True

  AddMRU
  If gsDataType <> gsJETMDB Then
    MsgBar "NOTE: Use of Attached Tables is the Recommended Method", False
  End If
  Screen.MousePointer = vbDefault

  Exit Sub

AttemptRepair:
  SetHourglass
  MsgBar "Repairing " & gsDBName, True
  DBEngine.RepairDatabase gsDBName
  Screen.MousePointer = vbDefault
  GoTo OneMoreTry

OpenError:
  Screen.MousePointer = vbDefault
  If Err = 3049 Then
    If MsgBox(Error & gsNewLine & gsNewLine & "Attempt to Repair it?", 4 + 48) = gnMSGBOX_YES Then
      Resume AttemptRepair
    End If
  End If
  gbDBOpenFlag = False
  gsDBName = gsNULL_STR
  gsDataType = gsNULL_STR
  gsODBCDatabase = gsNULL_STR
  gsODBCUserName = gsNULL_STR
  gsODBCPassword = gsNULL_STR
  If Err <> 32755 And Err <> 3049 Then   'check for common dialog cancelled
    ShowError
  End If
  Exit Sub

End Sub

'------------------------------------------------------------
'this sub is used to create a new directory for one
'of the local ISAM data types
'------------------------------------------------------------
Sub NewLocalISAM()
   On Error GoTo NewISAMErr

   Dim sNewName As String
   Dim d As Database

   sNewName = InputBox("Enter Name for New ISAM Database:")
   If Len(sNewName) = 0 Then Exit Sub

   If Mid(sNewName, Len(sNewName), 1) <> "\" Then sNewName = sNewName & "\"

   MkDir Mid(sNewName, 1, Len(sNewName) - 1)

   gsDBName = sNewName
   OpenLocalDB True

   If gbDBOpenFlag = True Then
     ShowDBTools
     RefreshTables frmTables.lstTables, True
   End If

  Exit Sub

NewISAMErr:
  If Err = 75 Then Resume Next  'catch the case where dir exists
  ShowError
  Exit Sub

End Sub

'------------------------------------------------------------
'this sub is called from the compact menu options
'on the main MDI form
'------------------------------------------------------------
Sub CompactDB(rnCompactVersion As Integer)
  On Error GoTo CompactAccErr

  Dim sOldName As String
  Dim sNewName As String
  Dim sNewName2 As String
  Dim nEncrypt As Integer

  'get file name to compact
  frmMDI.dlgCMD1.Filter = "Jet Engine MDBs (*.mdb)|*.mdb"
  frmMDI.dlgCMD1.DialogTitle = "Select Jet Database to Compact"
  frmMDI.dlgCMD1.FilterIndex = 1
  frmMDI.dlgCMD1.Flags = FileOpenConstants.cdlOFNHideReadOnly
  frmMDI.dlgCMD1.ShowOpen
  If Len(frmMDI.dlgCMD1.FileName) > 0 Then
    sOldName = frmMDI.dlgCMD1.FileName
  Else
    Exit Sub
  End If

  'get file name to compact to
  frmMDI.dlgCMD1.DialogTitle = "Select Jet Database to Compact to"
  frmMDI.dlgCMD1.FilterIndex = 1
  frmMDI.dlgCMD1.FileName = gsNULL_STR
  frmMDI.dlgCMD1.CancelError = True
  frmMDI.dlgCMD1.Flags = FileOpenConstants.cdlOFNOverwritePrompt + FileOpenConstants.cdlOFNHideReadOnly
  frmMDI.dlgCMD1.ShowSave
  If Len(frmMDI.dlgCMD1.FileName) > 0 Then
    sNewName = frmMDI.dlgCMD1.FileName
    If Dir(sNewName) <> gsNULL_STR And sOldName <> sNewName Then
      Kill sNewName
    End If
  Else
    Exit Sub
  End If

  If MsgBox("Encrypt Compacted Database?", gnMSGBOX_TYPE) = vbYes Then
    nEncrypt = dbEncrypt
  Else
    nEncrypt = dbDecrypt
  End If

  SetHourglass
  MsgBar "Compacting " & sOldName & " to " & sNewName, True
  'if they want to overwrite the same file, we need to create a new MDB
  'and rename after the compact is successful
  If sOldName = sNewName Then
    sNewName2 = sNewName 'save the new name
    sNewName = Left(sNewName, Len(sNewName) - 1) & "N"
  End If

  DBEngine.CompactDatabase sOldName, sNewName, dbLangGeneral, rnCompactVersion + nEncrypt

  'check for an overwrite of the original mdb
  If VBA.Right(sNewName, 1) = "N" Then
    Kill sNewName2             'nuke the old one
    Name sNewName As sNewName2 'rename the new one to the original name
    sNewName = sNewName2       'reset to the correct name
  End If

  MsgBar gsNULL_STR, False
  Screen.MousePointer = vbDefault

  If MsgBox("Open Newly Compacted Database?", gnMSGBOX_TYPE) = vbYes Then
    If gbDBOpenFlag = True Then
      CloseCurrentDB
    End If
    gsDataType = gsJETMDB
    gsDBName = sNewName
    OpenLocalDB True
  End If

  If gbDBOpenFlag = True Then
    ShowDBTools
    RefreshTables frmTables.lstTables, True
  End If

  Exit Sub

CompactAccErr:
  If Err <> 32755 Then         'user cancelled
    ShowError
  End If
  Exit Sub

End Sub

'------------------------------------------------------------
'this sub does some cleanup and shuts down VisData
'------------------------------------------------------------
Sub ShutDownVisData()
  On Error Resume Next

  Dim nRet As Integer

  'save all the current INI file settings
  SaveINISettings

  If gbDBChanged Then
    If MsgBox("Data has been changed, Commit it?", gnMSGBOX_TYPE) = gnMSGBOX_YES Then
      gwsMainWS.CommitTrans
    End If
  End If

  UnloadAllForms
  gdbCurrentDB.Close
  'close the help file
  nRet = OSWinHelp(frmMDI.hwnd, App.HelpFile, HelpConstants.cdlHelpQuit, 0)

  End

End Sub
Sub NewJetMDB(rnVersion As Integer)
  On Error GoTo NewAccErr

  Dim sNewName As String
  Dim db As Database

  'get file name to compact to
  frmMDI.dlgCMD1.DialogTitle = "Select Jet Database to Create"
  frmMDI.dlgCMD1.FilterIndex = 1
  frmMDI.dlgCMD1.Filter = "Jet Engine MDBs (*.mdb)|*.mdb"
  frmMDI.dlgCMD1.FileName = gsNULL_STR
  frmMDI.dlgCMD1.CancelError = True
  frmMDI.dlgCMD1.Flags = FileOpenConstants.cdlOFNOverwritePrompt + FileOpenConstants.cdlOFNHideReadOnly
  frmMDI.dlgCMD1.ShowSave
  If Len(frmMDI.dlgCMD1.FileName) > 0 Then
    sNewName = frmMDI.dlgCMD1.FileName
    If InStr(sNewName, ".") = 0 Then
      'add an extension if the user didn't supply one
      sNewName = sNewName & ".MDB"
    End If
    If Dir(sNewName) <> gsNULL_STR Then
      Kill sNewName
    End If
  Else
    Exit Sub
  End If
  If Len(sNewName) = 0 Then Exit Sub

  Set db = CreateDatabase(sNewName, dbLangGeneral, rnVersion)
  db.Close

  gsDataType = gsJETMDB
  gsDBName = sNewName
  OpenLocalDB True
  Exit Sub

NewAccErr:
  If Err <> 32755 Then         'user cancelled
    ShowError
  End If
  Exit Sub

End Sub