Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/mquery/mquery.bas

BASIC Source File | 1995-05-09 | 27.4 KB | 938 lines

'------------------------------------------------------------
' 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
'   VT (Virtual Table) Object layer in VB 3.0 Pro.
'
'   Any valid SQL statement may be sent via the Utility SQL
'   function excluding "select" statements which may be
'   executed from the Dynaset Create function. With these
'   two features, this simple app becomes a powerful data
'   definition and query tool accessing any ODBC driver
'   available at the time.
'
'   The app has the capability to perform all DDL (data
'   definition language) functions. These are accessed
'   from the "Tables" form. This form accesses the
'   "NewTable", "AddField" and "IndexAdd" forms to do
'   the actual table, field and index definition.
'   Tables and Indexes may be deleted when the corresponding
'   "Delete" button is enabled. It is not possible to
'   delete fields.
'
' Naming Conventions:
'   "f..."   = Form
'   "c..."   = Form control
'   "F..."   = Form level variable
'   "gst..." = Global String
'   "gf..."  = Global flag (true/false)
'   "gw..."  = Global 2 byte integer value
'
'------------------------------------------------------------

Option Explicit

'api declarations
Declare Function GetPrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyname As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer
Declare Function WritePrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyname As String, ByVal lpstring As String, ByVal lplFileName As String) As Integer
Declare Function GetWindowsDirectory Lib "Kernel" (ByVal lpBuffer As String, ByVal nSize As Integer) As Integer

'global object variables
Global gCurrentDB As Database
Global gfDBOpenFlag As Integer
Global gCurrentDS As Dynaset
Global gCurrentTbl As Table
Global gCurrentQueryDef As QueryDef
Global gCurrentField As Field
Global gCurrentIndex As Index
Global gTableListSS As Snapshot

'global database variables
Global gstDataType As String
Global gstDBName As String
Global gstUserName As String
Global gstPassword As String
Global gstDataBase As String
Global gstDynaString As String
Global gstTblName As String
Global gfUpdatable As Integer
Global glQueryTimeout As Long
Global glLoginTimeout As Long
Global gstTableDynaFilter As String
Global gTblname As String ' used for filter and sort in grid and dynaset
'other global vars
Global gstZoomData As String
Global gwMaxGridRows As Long
Global gWindowsDirectory As String
Global gSQLUser As String

'new field properties
Global gwFldType As Integer
Global gwFldSize As Integer
Global gsumcolwid As Integer
'global find values
Global gfFindFailed As Integer
Global gstFindExpr As String
Global gstFindOp As String
Global gstFindField As String
Global gfFindMatch As Integer
Global gfFromTableView As Integer

 ' global filter values
Global gFilterStr As String

 ' global sort values
Global gSortStr As String

  ' Global flag for stored queries
Global gStoredFlag As Integer

'global seek values
Global gstSeekOperator As String
Global gstSeekValue As String

'global flags
Global gfDBChanged As Integer
Global gfFROMSQL As Integer
Global gfTransPending As Integer
Global gfAddTableFlag As Integer

'global constants
Global Const DEFAULTDRIVER = "SQL Server"
Global Const MODAL = 1
Global Const HOURGLASS = 11
Global Const DEFAULT_MOUSE = 0
Global Const YES = 6
Global Const MSGBOX_TYPE = 4 + 48 + 256
Global Const TRUE_ST = "True"
Global Const FALSE_ST = "False"
Global Const EOF_ERR = 626
Global Const FTBLS = 0
Global Const FFLDS = 1
Global Const FINDX = 2
Global Const MAX_GRID_ROWS = 31999
Global Const MAX_MEMO_SIZE = 20000
Global Const GETCHUNK_CUTOFF = 50
Global Const MB_YESNOCANCEL = 3
Global Const MB_YESNO = 4
Global Const MB_ICONSTOP = 16
Global Const MB_ICONQUESTION = 32
Global Const MB_ICONEXCLAMATION = 48
Global Const MB_ICONINFORMATION = 64
Global Const MB_DEFBUTTON2 = 256
Global Const IDYES = 6
Global Const IDNO = 7
' Define other.




'field type constants
Global Const FT_TRUEFALSE = 1
Global Const FT_BYTE = 2
Global Const FT_INTEGER = 3
Global Const FT_LONG = 4
Global Const FT_CURRENCY = 5
Global Const FT_SINGLE = 6
Global Const FT_DOUBLE = 7
Global Const FT_DATETIME = 8
Global Const FT_STRING = 10
Global Const FT_BINARY = 11
Global Const FT_MEMO = 12

'table type constants
Global Const DB_TABLE = 1
Global Const DB_ATTACHEDTABLE = 6
Global Const DB_ATTACHEDODBC = 4
Global Const DB_QUERYDEF = 5
Global Const DB_SYSTEMOBJECT = &H80000002

'dynaset option parameter constants
Global Const VBDA_DENYWRITE = &H1
Global Const VBDA_DENYREAD = &H2
Global Const VBDA_READONLY = &H4
Global Const VBDA_APPENDONLY = &H8
Global Const VBDA_INCONSISTENT = &H10
Global Const VBDA_CONSISTENT = &H20
Global Const VBDA_SQLPASSTHROUGH = &H40

'db create/compact constants
Global Const DB_CREATE_GENERAL = ";langid=0x0809;cp=1252;country=0"
Global Const DB_VERSION10 = 1

' Microsoft Access QueryDef types
Global Const DB_QACTION = &HF0
Global Const DB_QCROSSTAB = &H10
Global Const DB_QDELETE = &H20
Global Const DB_QUPDATE = &H30
Global Const DB_QAPPEND = &H40
Global Const DB_QMAKETABLE = &H50

' Index Attributes
Global Const DB_UNIQUE = 1
Global Const DB_PRIMARY = 2
Global Const DB_PROHIBITNULL = 4
Global Const DB_IGNORENULL = 8
Global Const DB_DESCENDING = 1  'For each field in Index

Function ActionQueryType (qn As String) As String
  Dim i As Integer

  gTableListSS.MoveFirst
  While gTableListSS.EOF = False And gTableListSS!Name <> qn
    gTableListSS.MoveNext
  Wend
  If gTableListSS!Name = qn Then
    Select Case gTableListSS!Attributes
      Case DB_QCROSSTAB
        ActionQueryType = "Cross Tab"
      Case DB_QDELETE
        ActionQueryType = "Delete"
      Case DB_QUPDATE
        ActionQueryType = "Update"
      Case DB_QAPPEND
        ActionQueryType = "Append"
      Case DB_QMAKETABLE
        ActionQueryType = "Make Table"
    End Select
  Else
    ActionQueryType = ""
  End If

End Function

Sub ExecSql ()
   Dim RetSQL As Long
   If Not gStoredFlag Then ' flag goes here
   If fQuery!cCriteria = "" Then ' no sql statment
   gfFROMSQL = False
   Exit Sub
   End If
   Else
       gfFROMSQL = False
        ResetMouse fQuery
        MsgBar "", False
        'gStoredFlag = False
        If fQuery!Option1(0) = False Then
         Dim dsform1 As New fDynaset
         dsform1.Show
        Else
         Dim dsform2 As New fGridFrm
         dsform2.Show
       End If

   Exit Sub
   End If
   MsgBar "Executing SQL Statement", True
   'SetHourGlass Me
   If UCase(Mid(fQuery!cCriteria, 1, 6)) = "SELECT" And InStr(UCase(fQuery!cCriteria), " INTO ") = 0 Then
     On Error GoTo SQLDSErr
MakeDynaset:
     gfFROMSQL = True
     'create a new dynaset form
     gstDynaString = ""
    On Error GoTo SQLDSErr
       If fQuery!Option1(0) = False Then
         Dim dsform3 As New fDynaset
         dsform3.Show
       Else
         Dim dsform4 As New fGridFrm
         dsform4.Show
       End If
     On Error GoTo SQLErr

   End If

   GoTo SQLEnd

SQLErr:
   If Err = 3065 Then   'row returning so try to create dynaset
     Resume MakeDynaset
   End If
   ShowError
   Resume SQLEnd

SQLDSErr:
   Resume SQLEnd

SQLEnd:
   ResetMouse fQuery
   MsgBar "", False

End Sub

Function GetFieldType (ft As String) As Integer
  'return field length
  If ft = "String" Then
    GetFieldType = FT_STRING
  Else
    Select Case ft
      Case "Counter"
        GetFieldType = FT_LONG
      Case "True/False"
        GetFieldType = FT_TRUEFALSE
      Case "Byte"
        GetFieldType = FT_BYTE
      Case "Integer"
        GetFieldType = FT_INTEGER
      Case "Long"
        GetFieldType = FT_LONG
      Case "Currency"
        GetFieldType = FT_CURRENCY
      Case "Single"
        GetFieldType = FT_SINGLE
      Case "Double"
        GetFieldType = FT_DOUBLE
      Case "Date/Time"
        GetFieldType = FT_DATETIME
      Case "Binary"
        GetFieldType = FT_BINARY
      Case "Memo"
        GetFieldType = FT_MEMO
    End Select
  End If

End Function

Function GetFieldWidth (t As Integer)
  'determines the form control width
  'based on the field type
  Select Case t
    Case FT_TRUEFALSE
      GetFieldWidth = 850
    Case FT_BYTE
      GetFieldWidth = 650
    Case FT_INTEGER
      GetFieldWidth = 900
    Case FT_LONG
      GetFieldWidth = 1100
    Case FT_CURRENCY
      GetFieldWidth = 1800
    Case FT_SINGLE
      GetFieldWidth = 1800
    Case FT_DOUBLE
      GetFieldWidth = 2200
    Case FT_DATETIME
      GetFieldWidth = 2000
    Case FT_STRING
      GetFieldWidth = 3250
    Case FT_BINARY
      GetFieldWidth = 3250
    Case FT_MEMO
      GetFieldWidth = 3250
    Case Else
      GetFieldWidth = 3250
  End Select

End Function

Function GetNumbRecs (fds As Dynaset) As Long
  Dim ds As Dynaset

  On Error GoTo GNRErr

  Set ds = fds.Clone()
  If Not ds.EOF Then ds.MoveLast
  GetNumbRecs = ds.RecordCount
  ds.Close
  If fds.Updatable = True Then
    gfUpdatable = True
  End If

  GoTo GNREnd

GNRErr:
  'just return because row count is non critical
  GetNumbRecs = -1
  Resume GNREnd

GNREnd:

End Function

Function GetNumbRecsSS (fds As Snapshot) As Long
  Dim ds As Snapshot

  On Error GoTo GNRSSErr

  Set ds = fds.Clone()
  If Not ds.EOF Then
  ds.MoveLast
  End If
  GetNumbRecsSS = ds.RecordCount
  ds.Close
  If fds.Updatable = True Then
    gfUpdatable = True
  End If

  GoTo GNRSSEnd

GNRSSErr:
  'just return because row count is non critical
  GetNumbRecsSS = -1
  Resume GNRSSEnd

GNRSSEnd:

End Function

Function GetNumbRecsTbl (tbl As Table) As Long
  Dim tbl2 As Table

  On Error GoTo GNRTErr

  Set tbl2 = tbl.Clone()
  If Not tbl2.EOF Then tbl2.MoveLast
  GetNumbRecsTbl = tbl2.RecordCount
  tbl2.Close
  gfUpdatable = True

  GoTo GNRTEnd

GNRTErr:
  'just return because row count is non critical
  GetNumbRecsTbl = -1
  Resume GNRTEnd

GNRTEnd:

End Function

'----------------------------------------------------------------------------
'to use this function in any app,
'1. create a form with a grid
'2. create a dynaset
'3. call this function from the form with
'   grd    = your grid control name
'   dynst$ = your dynaset open string (table name or SQL select statement)
'   numb&  = the max number of rows to load (grid is limited to 2000)
'   start& = starting row (needed to display the record number in the
'            left column when loading blocks of records as the
'            DynaGrid form in this app does with the "More" button)
'----------------------------------------------------------------------------
Function LoadGrid (grd As Control, fds As Snapshot, dynst$, numb&, start&) As Integer
   Dim ft As Integer               'field type
   Dim i As Integer, j As Integer  'for loop indexes
   Dim fn As String                'field name
   Dim rc As Integer               'record count
   Dim gs As String                'grid string
   gsumcolwid = 0' initialize
   On Error GoTo LGErr

   MsgBar "Loading Grid for Table View", True
   'setup the grid
   grd.Rows = 2       'reduce the grid
   grd.FixedRows = 0  'allow next step
   grd.Rows = 1       'clears the grid completely
   grd.Cols = fds.Fields.Count + 1

   If start& = 0 Then        'only do it on first call
     On Error Resume Next
     'set the column widths
     For i = 0 To fds.Fields.Count - 1
       ft = fds(i).Type
       If ft = FT_STRING Then
         If fds(i).Size > Len(fds(i).Name) Then
           If fds(i).Size <= 10 Then
             grd.ColWidth(i + 1) = fds(i).Size * fQuery.TextWidth("A")
           Else
             grd.ColWidth(i + 1) = 10 * fQuery.TextWidth("A")
           End If
         Else
           If Len(fds(i).Name) <= 10 Then
             grd.ColWidth(i + 1) = Len(fds(i).Name) * fQuery.TextWidth("A")
           Else
             grd.ColWidth(i + 1) = 10 * fQuery.TextWidth("A")
           End If
         End If
       ElseIf ft = FT_MEMO Then
         grd.ColWidth(i + 1) = 1200
       Else
         grd.ColWidth(i + 1) = GetFieldWidth(ft)
       End If
       gsumcolwid = gsumcolwid + grd.ColWidth(i + 1)
     Next

     On Error GoTo LGErr
     'load the field names
     grd.Row = 0
     For i = 0 To fds.Fields.Count - 1
       grd.Col = i + 1
       grd.Text = UCase(fds(i).Name)
     Next
   End If

   rc = 1

   'fill method 1
   'add the rows with the additem method
   While fds.EOF = False And rc <= numb
     gs = CStr(rc + start) + Chr$(9)
     For i = 0 To fds.Fields.Count - 1
       If fds(i).Type = FT_MEMO Then
         If fds(i).FieldSize() < 255 Then
           gs = gs + StripNonAscii(vFieldVal(fds(i))) + Chr$(9)
         Else
           'can only get the 1st 255 chars
           gs = gs + StripNonAscii(vFieldVal(fds(i).GetChunk(0, 255))) + Chr$(9)
         End If
       ElseIf fds(i).Type = FT_STRING Then
         gs = gs + StripNonAscii(vFieldVal(fds(i))) + Chr$(9)
       Else
         gs = gs + vFieldVal(fds(i)) + Chr$(9)
       End If
     Next
     gs = Mid(gs, 1, Len(gs) - 1)
     grd.AddItem gs
     fds.MoveNext
     rc = rc + 1
   Wend

   grd.FixedRows = 1   'freeze the field names
   grd.FixedCols = 1   'freeze the row numbers
   grd.Row = 1         'set current position
   grd.Col = 1

   LoadGrid = rc       'return number added
   GoTo LGEnd

LGErr:
   ShowError
   LoadGrid = False    'return 0
   Resume LGEnd

LGEnd:
   MsgBar "", False

End Function

Sub MsgBar (Msg As String, pw As Integer)
  If Msg = "" Then
    fQuery.Panel3D1.Caption = "Ready"
  Else
    If pw = True Then
      fQuery.Panel3D1.Caption = Msg + ", please wait..."
    Else
      fQuery.Panel3D1.Caption = Msg
    End If
  End If
  fQuery.Panel3D1.Refresh
End Sub

Sub Outlines (formname As Form)
    Dim drkgray As Long, fullwhite As Long
    Dim i As Integer
    Dim ctop As Integer, cleft As Integer, cright As Integer, cbottom As Integer

    ' Outline a form's controls for 3D look unless control's TAG
    ' property is set to "skip".

    Dim cname As Control
    drkgray = RGB(128, 128, 128)
    fullwhite = RGB(255, 255, 255)

    For i = 0 To (formname.Controls.Count - 1)
        Set cname = formname.Controls(i)
        If TypeOf cname Is Menu Then
            'Debug.Print "menu item"
        ElseIf (UCase(cname.Tag) = "OL") Then
                ctop = cname.Top - screen.TwipsPerPixelY
                cleft = cname.Left - screen.TwipsPerPixelX
                cright = cname.Left + cname.Width
                cbottom = cname.Top + cname.Height
                formname.Line (cleft, ctop)-(cright, ctop), drkgray
                formname.Line (cleft, ctop)-(cleft, cbottom), drkgray
                formname.Line (cleft, cbottom)-(cright, cbottom), fullwhite
                formname.Line (cright, ctop)-(cright, cbottom), fullwhite
        End If
    Next i
End Sub

Sub PicOutlines (pic As Control, ctl As Control)
    Dim drkgray As Long, fullwhite As Long
    Dim ctop As Integer, cleft As Integer, cright As Integer, cbottom As Integer

    ' Outline a form's controls for 3D look unless control's TAG
    ' property is set to "skip".

    Dim cname As Control
    drkgray = RGB(128, 128, 128)
    fullwhite = RGB(255, 255, 255)

    ctop = ctl.Top - screen.TwipsPerPixelY
    cleft = ctl.Left - screen.TwipsPerPixelX
    cright = ctl.Left + ctl.Width
    cbottom = ctl.Top + ctl.Height
    pic.Line (cleft, ctop)-(cright, ctop), drkgray
    pic.Line (cleft, ctop)-(cleft, cbottom), drkgray
    pic.Line (cleft, cbottom)-(cright, cbottom), fullwhite
    pic.Line (cright, ctop)-(cright, cbottom), fullwhite

End Sub

Sub RefreshTables (tbl_list As Control, IncludeQueries As Integer)
   Dim i As Integer, j As Integer, h As Integer
   Dim st As String
   Dim OkayToAdd As Integer

   On Error GoTo TRefErr
   IncludeQueries = False
   gstDataType = "MS Access"
   Set gTableListSS = gCurrentDB.ListTables()
   tbl_list.Clear

   If IncludeQueries And gstDataType = "MS Access" Then
     ' the ListTables method is used to display querydefs that might
     ' be present in an Access database, see below for optional code
     While gTableListSS.EOF = False
       st = gTableListSS!Name
         If (gTableListSS!Attributes And DB_SYSTEMOBJECT) = 0 Then
           tbl_list.AddItem st
         End If
       gTableListSS.MoveNext
     Wend
   Else
     ' this method uses the tabledefs collection but will not display
     ' querydefs in an Access database
     tbl_list.Clear
     For i = 0 To gCurrentDB.TableDefs.Count - 1
       st = gCurrentDB.TableDefs(i).Name
       If (gCurrentDB.TableDefs(i).Attributes And DB_SYSTEMOBJECT) = 0 Then
            If UCase(Left(st, 4)) = "DBO." Then
                st = Mid(st, 5, Len(st))
            End If
         tbl_list.AddItem st
       End If
     Next
   End If

   GoTo TRefEnd

TRefErr:
   ShowError
   gfDBOpenFlag = False
   Resume TRefEnd

TRefEnd:

End Sub

Sub resetdefault ()
Dim deselect As Integer
For deselect = 0 To fQuery!cTableList.ListCount - 1
        If fQuery!cTableList.Selected(deselect) Then
            fQuery!cTableList.Selected(deselect) = False
        End If
    Next deselect
  deselect = 0
  fQuery!cShowFields.Clear
  fQuery.cJoinFields.Clear
  If Not fQuery!cColOrder.ListIndex Then
  fQuery!cColOrder.ListIndex = 0
  fQuery!cOrderByField.ListIndex = 0
  End If
  fQuery!cField.Clear
  fQuery!cValue.Clear
  fQuery!cCriteria = ""
  fQuery!CriteriaLabel.Caption = "SQL Statement"
  fQuery!RunSaveQryButton.Caption = "&Load Query"
  fQuery!RunSaveQryButton.Enabled = True
  fQuery!ExecSqlButton.Enabled = True
  gFilterStr = ""
  gSortStr = ""
  gStoredFlag = False
  gfFROMSQL = False
  fQuery.Tag = ""
  gstDynaString = ""
  MsgBar "", False
End Sub

Sub ResetMouse (f As Form)
  fQuery.MousePointer = DEFAULT_MOUSE
  f.MousePointer = DEFAULT_MOUSE
End Sub

Function SetFldProperties (ft As String) As String
  'return field length
  If ft = "String" Then
    gwFldType = FT_STRING
  Else
    Select Case ft
      Case "Counter"
        SetFldProperties = "4"
        gwFldType = FT_LONG
        gwFldSize = 4
      Case "True/False"
        SetFldProperties = "1"
        gwFldType = FT_TRUEFALSE
        gwFldSize = 1
      Case "Byte"
        SetFldProperties = "1"
        gwFldType = FT_BYTE
        gwFldSize = 1
      Case "Integer"
        SetFldProperties = "2"
        gwFldType = FT_INTEGER
        gwFldSize = 2
      Case "Long"
        SetFldProperties = "4"
        gwFldType = FT_LONG
        gwFldSize = 4
      Case "Currency"
        SetFldProperties = "8"
        gwFldType = FT_CURRENCY
        gwFldSize = 8
      Case "Single"
        SetFldProperties = "4"
        gwFldType = FT_SINGLE
        gwFldSize = 4
      Case "Double"
        SetFldProperties = "8"
        gwFldType = FT_DOUBLE
        gwFldSize = 8
      Case "Date/Time"
        SetFldProperties = "8"
        gwFldType = FT_DATETIME
        gwFldSize = 8
      Case "Binary"
        SetFldProperties = "0"
        gwFldType = FT_BINARY
        gwFldSize = 0
      Case "Memo"
        SetFldProperties = "0"
        gwFldType = FT_MEMO
        gwFldSize = 0
    End Select
  End If
End Function

Sub SetHourGlass (f As Form)
  DoEvents  'cause forms to repaint before going on
  fQuery.MousePointer = HOURGLASS
  f.MousePointer = HOURGLASS
End Sub

Sub ShowError ()
  Dim s As String
  Dim crlf As String

  crlf = Chr(13) + Chr(10)
  s = "The following Error occurred:" + crlf + crlf
  'add the error string
  s = s + Error$ + crlf
  'add the error number
  s = s + "Number: " + CStr(Err)
  'beep and show the error
  Beep
  MsgBox (s)

End Sub

Sub ShowHelp (PBtn As Control, px As Single, py As Single)
' Subroutine to show popup help for a control
' To use:
'    add a panel control called PnlHelp to the form
'    Set control's tag property to help message desired
'    Copy this subroutine to the form code and uncomment code below
'    In mousemove event of control add
'       ShowHelp control-name, x, y
'    In click event or other events of control that cause action add
'       ShowHelp control-name, 0, 0     ' Hides help

    Dim maxx As Single, maxy As Single
    Dim nPnlTop As Single, nPnlLeft As Single
    ' Determine max x & y coordinates with 80 twip border
    ' boundry of 80 twips allowed to be able to catch cursor as exiting control
    maxx = PBtn.Width - 80
    maxy = PBtn.Height - 80
    ' if exiting control area turn off help panel
    If px < 80 Or py < 80 Or px > maxx Or py > maxy Then
        fQuery!PnlHelp.Visible = False
        fQuery!PnlHelp.Caption = ""
        Exit Sub
    End If

    ' Determine location for help panel
    ' Assume below and to right
    nPnlTop = PBtn.Top + PBtn.Height + 40
    nPnlLeft = PBtn.Left + 100
    ' Put panel above control if not enough room below
    If nPnlTop + fQuery!PnlHelp.Height > fQuery!PnlHelp.Height - 1024 Then
        nPnlTop = PBtn.Top - fQuery!PnlHelp.Height - 40
    End If
    ' Put panel to left if not enough room to right
    If nPnlLeft + fQuery!PnlHelp.Width > fQuery!PnlHelp.Width - 500 Then
        nPnlLeft = PBtn.Left + PBtn.Width - 40
    End If

    ' if same settings exit to prevent flickering effect
    If fQuery!PnlHelp.Caption = PBtn.Tag And fQuery!PnlHelp.Top = nPnlTop And fQuery!PnlHelp.Left = nPnlLeft Then
        Exit Sub
    End If

    ' get help msg from control's tag and position help panel
    fQuery!PnlHelp.Caption = PBtn.Tag
    fQuery!PnlHelp.Top = nPnlTop
    fQuery!PnlHelp.Left = nPnlLeft
    fQuery!PnlHelp.Visible = True

End Sub

    Function StringfromPrivINI (Sectionname As String, Keyname As String, Default As String, Filename As String) As String
'Function reads an item from an app's INI file.
'   -SectionName is the Application name
'   -KeyName is the Key to read from the ini file
'   -Default is the value to be supplied if the ini file doesn't exist or if the key
'       hasn't been created/defined in the INI file.
'   -ReturnedString is the string read from the INI file
'   -ReturnedStringLen is the max allowable length of ReturnedString
'   -FileName is the INI file name.
'
'ALL OF THESE PARAMETERS MUST BE INITIALIZED for this API call to work.
    Dim Resultstr As String
    Dim ReturnedStr As String
    Dim StringfromPrivateINI As String
    Dim MaxStringLen As Integer
    Dim Result  As Integer

    MaxStringLen = 400
    ReturnedStr = Space(MaxStringLen)

    Result = GetPrivateProfileString(Sectionname, Keyname, Default, ReturnedStr, MaxStringLen, Filename$)
    Resultstr = LTrim(RTrim$(ReturnedStr)) ' TRIM OUT BLANKS
    Resultstr = Left(Resultstr, Len(Resultstr) - 1) ' REMOVE CHR$(0) FROM END
    StringfromPrivINI = Resultstr

End Function

Function StringtoPrivINI (Sectionname As String, Keyname As String, lpDefault As String, Filenamein As String)
StringtoPrivINI = WritePrivateProfileString(Sectionname, Keyname, lpDefault, Filenamein)
End Function

Function StripFileName (fname As String) As String
  On Error Resume Next
  Dim i As Integer

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

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

End Function

Function StripNonAscii (vs As Variant) As String
  Dim i As Integer
  Dim ts As String

  For i = 1 To Len(vs)
    If Asc(Mid(vs, i, 1)) < 32 Or Asc(Mid(vs, i, 1)) > 126 Then
      ts = ts + " "
    Else
      ts = ts + Mid(vs, i, 1)
    End If
  Next

  StripNonAscii = ts

End Function

Function stTrueFalse (tf As Variant) As String
  If tf = True Then
    stTrueFalse = "True"
  Else
    stTrueFalse = "False"
  End If
End Function

Function TableType (tbl As String) As Integer
  Dim i As Integer

  gTableListSS.MoveFirst
  While gTableListSS.EOF = False And gTableListSS!Name <> tbl
    gTableListSS.MoveNext
  Wend
  If gTableListSS!Name = tbl Then
    TableType = gTableListSS!TableType
  Else
    TableType = 0
  End If

End Function

Function vFieldVal (fval As Variant) As Variant
  If IsNull(fval) Then
    vFieldVal = ""
  Else
    vFieldVal = CStr(fval)
  End If
End Function

Function WinDir$ ()
'Author:            Barry Seymour, Vanguard Business Solutions
'Date:              29Aug91
'Globals used:      None
'Functions Called:  GetgWindowsDirectory, defined in GLOBAL.BAS as follows:
'--------------------------------------------------------------------------------------------------------------
'Declare Function GetgWindowsDirectory Lib "Kernel" (ByVal lpBuffer As String, ByVal nSize As Integer) As Integer
'---------------------------------------------------------------------------------------------------------------

'Explanation:   This Function returns a string containing the
'               name of the Windows directory.  The GetgWindowsDirectory
'               function call is defined in GLOBAL.BAS (see above)
'               and uses a Windows API call to the Kernel.

' IMPORTANT NOTE:   The string to contain the returned data MUST be fully
' initialized prior to placing data in it, else an Unrecoverable
' Application Error (UAE) will result.  This Function initializes the
' string with empty spaces so the result can be trimmed.
' EVEN SO, the result string has a null char at the end of it which
' must be stripped away manually - RTrim$ or LTrim$ don't strip out
' null chars.
'
' ANOTHER IMPORTANT NOTE:  If your windows directory is in the ROOT, a
' backslash is at the end of the string ("C:\").  If not, there is no
' backslash at the end of the string ("c:\WIN").

'Error trapping is also in this code, giving a STERN WARNING to the user.
'If this procedure fails, your system is mightily confused.
'----------------------------------------------------------------------------
    Dim lf As String
    Dim WindowsPathName As String
    Dim Msg  As String
    Dim PathStringLength, Success As Integer


    lf = Chr(13) + Chr(10)  'linefeed for message formatting

    PathStringLength = 255 'The length is arbitrary, but MUST be defined.

    WindowsPathName = String(PathStringLength, " ")
    'Initialize the full string to SPACES.  The full length of the
    'string MUST be present before making the function call, else UAE!

    Success = GetWindowsDirectory(WindowsPathName, PathStringLength)
    If Success Then
        WinDir$ = Left$(RTrim$(WindowsPathName), Len(RTrim$(WindowsPathName)) - 1)
        '                   |--Trim trailing blanks   |-Trim null char at end of string.
    Else
        WinDir = "c:\WIN"
        Msg = "SYSTEM ERROR: Unable to determine Windows Directory." + lf
        If Err <> 0 Then
            Msg = Msg + "Error " + Str$(Err) + ":" + lf
            Msg = Msg + Error$(Err) + "." + lf
        Else
            Msg = Msg + lf + "Error Number Unknown." + lf
        End If
        Msg = Msg + "Assuming Windows Directory to be c:\WIN." + lf + lf
        Msg = Msg + "It is STRONGLY RECOMMENDED that you save your work " + lf
        Msg = Msg + "and SHUT DOWN this application."
        Beep: Beep: Beep: MsgBox Msg, 16, "System Error"
    End If
End Function