home *** CD-ROM | disk | FTP | other *** search
/ On Hand / On_Hand_From_Softbank_1994_Release_2_Disc_2_1994.iso / 00202 / s / disk4 / visdata.ba_ / visdata.bin
Text File  |  1993-04-28  |  24KB  |  907 lines
  1. '------------------------------------------------------------
  2. ' VISDATA.BAS
  3. ' support functions for the Visual Data sample application
  4. '
  5. ' General Information: This app is intended to demonstrate
  6. '   and exercise all of the functionality available in the
  7. '   VT (Virtual Table) Object layer in VB 3.0 Pro.
  8. '
  9. '   Any valid SQL statement may be sent via the Utility SQL
  10. '   function excluding "select" statements which may be
  11. '   executed from the Dynaset Create function. With these
  12. '   two features, this simple app becomes a powerful data
  13. '   definition and query tool accessing any ODBC driver
  14. '   available at the time.
  15. '
  16. '   The app has the capability to perform all DDL (data
  17. '   definition language) functions. These are accessed
  18. '   from the "Tables" form. This form accesses the
  19. '   "NewTable", "AddField" and "IndexAdd" forms to do
  20. '   the actual table, field and index definition.
  21. '   Tables and Indexes may be deleted when the corresponding
  22. '   "Delete" button is enabled. It is not possible to
  23. '   delete fields.
  24. '
  25. ' Naming Conventions:
  26. '   "f..."   = Form
  27. '   "c..."   = Form control
  28. '   "F..."   = Form level variable
  29. '   "gst..." = Global String
  30. '   "gf..."  = Global flag (true/false)
  31. '   "gw..."  = Global 2 byte integer value
  32. '
  33. '------------------------------------------------------------
  34.  
  35. Option Explicit
  36.  
  37. 'api declarations
  38. Declare Function OSGetPrivateProfileString% Lib "Kernel" Alias "GetPrivateProfileString" (ByVal AppName$, ByVal KeyName$, ByVal keydefault$, ByVal ReturnString$, ByVal NumBytes As Integer, ByVal FileName$)
  39. Declare Function OSWritePrivateProfileString% Lib "Kernel" Alias "WritePrivateProfileString" (ByVal AppName$, ByVal KeyName$, ByVal keydefault$, ByVal FileName$)
  40. Declare Function OSGetWindowsDirectory% Lib "Kernel" Alias "GetWindowsDirectory" (ByVal a$, ByVal b%)
  41.  
  42. 'global object variables
  43. Global gCurrentDB As Database
  44. Global gfDBOpenFlag As Integer
  45. Global gCurrentDS As Dynaset
  46. Global gCurrentTbl As Table
  47. Global gCurrentQueryDef As querydef
  48. Global gCurrentField As Field
  49. Global gCurrentIndex As Index
  50. Global gTableListSS As Snapshot
  51.  
  52. 'global database variables
  53. Global gstDataType As String
  54. Global gstDBName As String
  55. Global gstUserName As String
  56. Global gstPassword As String
  57. Global gstDataBase As String
  58. Global gstDynaString As String
  59. Global gstTblName As String
  60. Global gfUpdatable As Integer
  61. Global glQueryTimeout As Long
  62. Global glLoginTimeout As Long
  63. Global gstTableDynaFilter As String
  64.  
  65. 'other global vars
  66. Global gstZoomData As String
  67. Global gwMaxGridRows As Long
  68.  
  69. 'new field properties
  70. Global gwFldType As Integer
  71. Global gwFldSize As Integer
  72.  
  73. 'global find values
  74. Global gfFindFailed As Integer
  75. Global gstFindExpr As String
  76. Global gstFindOp As String
  77. Global gstFindField As String
  78. Global gfFindMatch As Integer
  79. Global gfFromTableView As Integer
  80.  
  81. 'global seek values
  82. Global gstSeekOperator As String
  83. Global gstSeekValue As String
  84.  
  85. 'global flags
  86. Global gfDBChanged As Integer
  87. Global gfFromSQL As Integer
  88. Global gfTransPending As Integer
  89. Global gfAddTableFlag As Integer
  90.  
  91. 'global constants
  92. Global Const DEFAULTDRIVER = "SQL Server"
  93. Global Const MODAL = 1
  94. Global Const HOURGLASS = 11
  95. Global Const DEFAULT_MOUSE = 0
  96. Global Const YES = 6
  97. Global Const MSGBOX_TYPE = 4 + 48 + 256
  98. Global Const TRUE_ST = "True"
  99. Global Const FALSE_ST = "False"
  100. Global Const EOF_ERR = 626
  101. Global Const FTBLS = 0
  102. Global Const FFLDS = 1
  103. Global Const FINDX = 2
  104. Global Const MAX_GRID_ROWS = 31999
  105. Global Const MAX_MEMO_SIZE = 20000
  106. Global Const GETCHUNK_CUTOFF = 50
  107.  
  108. 'field type constants
  109. Global Const FT_TRUEFALSE = 1
  110. Global Const FT_BYTE = 2
  111. Global Const FT_INTEGER = 3
  112. Global Const FT_LONG = 4
  113. Global Const FT_CURRENCY = 5
  114. Global Const FT_SINGLE = 6
  115. Global Const FT_DOUBLE = 7
  116. Global Const FT_DATETIME = 8
  117. Global Const FT_STRING = 10
  118. Global Const FT_BINARY = 11
  119. Global Const FT_MEMO = 12
  120.  
  121. 'table type constants
  122. Global Const DB_TABLE = 1
  123. Global Const DB_ATTACHEDTABLE = 6
  124. Global Const DB_ATTACHEDODBC = 4
  125. Global Const DB_QUERYDEF = 5
  126. Global Const DB_SYSTEMOBJECT = &H80000002
  127.  
  128. 'dynaset option parameter constants
  129. Global Const VBDA_DENYWRITE = &H1
  130. Global Const VBDA_DENYREAD = &H2
  131. Global Const VBDA_READONLY = &H4
  132. Global Const VBDA_APPENDONLY = &H8
  133. Global Const VBDA_INCONSISTENT = &H10
  134. Global Const VBDA_CONSISTENT = &H20
  135. Global Const VBDA_SQLPASSTHROUGH = &H40
  136.  
  137. 'db create/compact constants
  138. Global Const DB_CREATE_GENERAL = ";langid=0x0809;cp=1252;country=0"
  139. Global Const DB_VERSION10 = 1
  140.  
  141. ' Microsoft Access QueryDef types
  142. Global Const DB_QACTION = &HF0
  143. Global Const DB_QCROSSTAB = &H10
  144. Global Const DB_QDELETE = &H20
  145. Global Const DB_QUPDATE = &H30
  146. Global Const DB_QAPPEND = &H40
  147. Global Const DB_QMAKETABLE = &H50
  148.  
  149. ' Index Attributes
  150. Global Const DB_UNIQUE = 1
  151. Global Const DB_PRIMARY = 2
  152. Global Const DB_PROHIBITNULL = 4
  153. Global Const DB_IGNORENULL = 8
  154. Global Const DB_DESCENDING = 1  'For each field in Index
  155.  
  156. Function ActionQueryType (qn As String) As String
  157.   Dim i As Integer
  158.  
  159.   gTableListSS.MoveFirst
  160.   While gTableListSS.EOF = False And gTableListSS!Name <> qn
  161.     gTableListSS.MoveNext
  162.   Wend
  163.   If gTableListSS!Name = qn Then
  164.     Select Case gTableListSS!Attributes
  165.       Case DB_QCROSSTAB
  166.         ActionQueryType = "Cross Tab"
  167.       Case DB_QDELETE
  168.         ActionQueryType = "Delete"
  169.       Case DB_QUPDATE
  170.         ActionQueryType = "Update"
  171.       Case DB_QAPPEND
  172.         ActionQueryType = "Append"
  173.       Case DB_QMAKETABLE
  174.         ActionQueryType = "Make Table"
  175.     End Select
  176.   Else
  177.     ActionQueryType = ""
  178.   End If
  179.  
  180. End Function
  181.  
  182. Function CheckTransPending (msg As String) As Integer
  183.  
  184.   If gfTransPending = True Then
  185.     MsgBox msg + Chr(13) + Chr(10) + "Execute Commit or Rollback First.", 48
  186.     CheckTransPending = True
  187.   Else
  188.     CheckTransPending = False
  189.   End If
  190.  
  191. End Function
  192.  
  193. Sub CloseAllDynasets ()
  194.   Dim i As Integer
  195.  
  196.   MsgBar "Closing Dynasets", True
  197.   While i < forms.Count
  198.     If forms(i).Tag = "Dynaset" Then
  199.       Unload forms(i)
  200.     Else
  201.       i = i + 1
  202.     End If
  203.   Wend
  204.   MsgBar "", False
  205.  
  206. End Sub
  207.  
  208. Function CopyData (from_db As Database, to_db As Database, from_nm As String, to_nm As String) As Integer
  209.   On Error GoTo CopyErr
  210.  
  211.   Dim ds1 As Dynaset, ds2 As Dynaset
  212.   Dim i As Integer
  213.  
  214.   Set ds1 = from_db.CreateDynaset(from_nm)
  215.   Set ds2 = to_db.CreateDynaset(to_nm)
  216.  
  217.   While ds1.EOF = False
  218.     ds2.AddNew
  219.     For i = 0 To ds1.Fields.Count - 1
  220.       ds2(i) = ds1(i)
  221.     Next
  222.     ds2.Update
  223.     ds1.MoveNext
  224.   Wend
  225.  
  226.   CopyData = True
  227.   GoTo CopyEnd
  228.  
  229. CopyErr:
  230.   ShowError
  231.   CopyData = False
  232.   Resume CopyEnd
  233.  
  234. CopyEnd:
  235.  
  236. End Function
  237.  
  238. Function CopyStruct (from_db As Database, to_db As Database, from_nm As String, to_nm As String, create_ind As Integer) As Integer
  239.   On Error GoTo CSErr
  240.  
  241.   Dim i As Integer
  242.   Dim tbl As New Tabledef    'table object
  243.   Dim fld As Field           'field object
  244.   Dim ind As Index           'index object
  245.  
  246.   'search to see if table exists
  247. namesearch:
  248.   For i = 0 To to_db.TableDefs.Count - 1
  249.     If UCase(to_db.TableDefs(i).Name) = UCase(to_nm) Then
  250.       If MsgBox(to_nm + " already exists, delete it?", 4) = YES Then
  251.          to_db.TableDefs.Delete to_db.TableDefs(to_nm)
  252.       Else
  253.          to_nm = InputBox("Enter New Table Name:")
  254.          If to_nm = "" Then
  255.            Exit Function
  256.          Else
  257.            GoTo namesearch
  258.          End If
  259.       End If
  260.       Exit For
  261.     End If
  262.   Next
  263.  
  264.   'strip off owner if needed
  265.   If InStr(to_nm, ".") <> 0 Then
  266.     to_nm = Mid(to_nm, InStr(to_nm, ".") + 1, Len(to_nm))
  267.   End If
  268.   tbl.Name = to_nm
  269.  
  270.   'create the fields
  271.   For i = 0 To from_db.TableDefs(from_nm).Fields.Count - 1
  272.     Set fld = New Field
  273.     fld.Name = from_db.TableDefs(from_nm).Fields(i).Name
  274.     fld.Type = from_db.TableDefs(from_nm).Fields(i).Type
  275.     fld.Size = from_db.TableDefs(from_nm).Fields(i).Size
  276.     fld.Attributes = from_db.TableDefs(from_nm).Fields(i).Attributes
  277.     tbl.Fields.Append fld
  278.   Next
  279.  
  280.   'create the indexes
  281.   If create_ind <> False Then
  282.     For i = 0 To from_db.TableDefs(from_nm).Indexes.Count - 1
  283.       Set ind = New Index
  284.       ind.Name = from_db.TableDefs(from_nm).Indexes(i).Name
  285.       ind.Fields = from_db.TableDefs(from_nm).Indexes(i).Fields
  286.       ind.Unique = from_db.TableDefs(from_nm).Indexes(i).Unique
  287.       If gstDataType <> "ODBC" Then
  288.         ind.Primary = from_db.TableDefs(from_nm).Indexes(i).Primary
  289.       End If
  290.       tbl.Indexes.Append ind
  291.     Next
  292.   End If
  293.  
  294.   'append the new table
  295.   to_db.TableDefs.Append tbl
  296.  
  297.   CopyStruct = True
  298.   GoTo CSEnd
  299.  
  300. CSErr:
  301.   ShowError
  302.   CopyStruct = False
  303.   Resume CSEnd
  304.  
  305. CSEnd:
  306.  
  307. End Function
  308.  
  309. 'sub used to create a sample table and fill it
  310. 'with NumbRecs number of rows
  311. 'can only be called from the debug window
  312. 'for example:
  313. 'CreateSampleTable "mytbl",100
  314. Sub CreateSampleTable (TblName As String, NumbRecs As Long)
  315.   Dim ds As Dynaset
  316.   Dim ii As Long
  317.   Dim t1 As New Tabledef
  318.   Dim f1 As New Field
  319.   Dim f2 As New Field
  320.   Dim f3 As New Field
  321.   Dim f4 As New Field
  322.   Dim i1 As New Index
  323.   Dim i2 As New Index
  324.  
  325.   'create the data holding table
  326.   t1.Name = TblName
  327.   
  328.   f1.Name = "name"
  329.   f1.Type = FT_STRING
  330.   f1.Size = 25
  331.   t1.Fields.Append f1
  332.  
  333.   f2.Name = "address"
  334.   f2.Type = FT_STRING
  335.   f2.Size = 25
  336.   t1.Fields.Append f2
  337.  
  338.   f3.Name = "record"
  339.   f3.Type = FT_STRING
  340.   f3.Size = 10
  341.   t1.Fields.Append f3
  342.  
  343.   f4.Name = "id"
  344.   f4.Type = FT_LONG
  345.   f4.Size = 4
  346.   t1.Fields.Append f4
  347.  
  348.   gCurrentDB.TableDefs.Append t1
  349.  
  350.   'add the indexes
  351.   i1.Name = TblName + "1"
  352.   i1.Fields = "name"
  353.   i1.Unique = False
  354.   gCurrentDB.TableDefs(TblName).Indexes.Append i1
  355.  
  356.   i2.Name = TblName + "2"
  357.   i2.Fields = "id"
  358.   i2.Unique = True
  359.   gCurrentDB.TableDefs(TblName).Indexes.Append i2
  360.  
  361.   'add records to the table in reverse order
  362.   'so indexes have some work to do
  363.   Set ds = gCurrentDB.CreateDynaset(TblName)
  364.   For ii = NumbRecs To 1 Step -1
  365.     ds.AddNew
  366.     ds(0) = "name" + CStr(ii)
  367.     ds(1) = "addr" + CStr(ii)
  368.     ds(2) = "rec" + CStr(ii)
  369.     ds(3) = ii
  370.     ds.Update
  371.   Next
  372.  
  373. End Sub
  374.  
  375. Function GetFieldType (ft As String) As Integer
  376.   'return field length
  377.   If ft = "String" Then
  378.     GetFieldType = FT_STRING
  379.   Else
  380.     Select Case ft
  381.       Case "Counter"
  382.         GetFieldType = FT_LONG
  383.       Case "True/False"
  384.         GetFieldType = FT_TRUEFALSE
  385.       Case "Byte"
  386.         GetFieldType = FT_BYTE
  387.       Case "Integer"
  388.         GetFieldType = FT_INTEGER
  389.       Case "Long"
  390.         GetFieldType = FT_LONG
  391.       Case "Currency"
  392.         GetFieldType = FT_CURRENCY
  393.       Case "Single"
  394.         GetFieldType = FT_SINGLE
  395.       Case "Double"
  396.         GetFieldType = FT_DOUBLE
  397.       Case "Date/Time"
  398.         GetFieldType = FT_DATETIME
  399.       Case "Binary"
  400.         GetFieldType = FT_BINARY
  401.       Case "Memo"
  402.         GetFieldType = FT_MEMO
  403.     End Select
  404.   End If
  405.  
  406. End Function
  407.  
  408. Function GetFieldWidth (t As Integer)
  409.   'determines the form control width
  410.   'based on the field type
  411.   Select Case t
  412.     Case FT_TRUEFALSE
  413.       GetFieldWidth = 850
  414.     Case FT_BYTE
  415.       GetFieldWidth = 650
  416.     Case FT_INTEGER
  417.       GetFieldWidth = 900
  418.     Case FT_LONG
  419.       GetFieldWidth = 1100
  420.     Case FT_CURRENCY
  421.       GetFieldWidth = 1800
  422.     Case FT_SINGLE
  423.       GetFieldWidth = 1800
  424.     Case FT_DOUBLE
  425.       GetFieldWidth = 2200
  426.     Case FT_DATETIME
  427.       GetFieldWidth = 2000
  428.     Case FT_STRING
  429.       GetFieldWidth = 3250
  430.     Case FT_BINARY
  431.       GetFieldWidth = 3250
  432.     Case FT_MEMO
  433.       GetFieldWidth = 3250
  434.     Case Else
  435.       GetFieldWidth = 3250
  436.   End Select
  437.  
  438. End Function
  439.  
  440. Function GetINIString$ (ByVal szItem$, ByVal szDefault$)
  441.   Dim tmp As String
  442.   Dim x As Integer
  443.  
  444.   tmp = String$(2048, 32)
  445.   x = OSGetPrivateProfileString("VISDATA", szItem$, szDefault$, tmp, Len(tmp), "VISDATA.INI")
  446.  
  447.   GetINIString = Mid$(tmp, 1, x)
  448. End Function
  449.  
  450. Function GetNumbRecs (FDS As Dynaset) As Long
  451.   Dim ds As Dynaset
  452.  
  453.   On Error GoTo GNRErr
  454.  
  455.   Set ds = FDS.Clone()
  456.   If Not ds.EOF Then ds.MoveLast
  457.   GetNumbRecs = ds.RecordCount
  458.   ds.Close
  459.   If FDS.Updatable = True Then
  460.     gfUpdatable = True
  461.   End If
  462.  
  463.   GoTo GNREnd
  464.  
  465. GNRErr:
  466.   'just return because row count is non critical
  467.   GetNumbRecs = -1
  468.   Resume GNREnd
  469.  
  470. GNREnd:
  471.  
  472. End Function
  473.  
  474. Function GetNumbRecsSS (FDS As Snapshot) As Long
  475.   Dim ds As Snapshot
  476.  
  477.   On Error GoTo GNRSSErr
  478.  
  479.   Set ds = FDS.Clone()
  480.   If Not ds.EOF Then ds.MoveLast
  481.   GetNumbRecsSS = ds.RecordCount
  482.   ds.Close
  483.   If FDS.Updatable = True Then
  484.     gfUpdatable = True
  485.   End If
  486.  
  487.   GoTo GNRSSEnd
  488.  
  489. GNRSSErr:
  490.   'just return because row count is non critical
  491.   GetNumbRecsSS = -1
  492.   Resume GNRSSEnd
  493.  
  494. GNRSSEnd:
  495.  
  496. End Function
  497.  
  498. Function GetNumbRecsTbl (tbl As Table) As Long
  499.   Dim tbl2 As Table
  500.  
  501.   On Error GoTo GNRTErr
  502.  
  503.   Set tbl2 = tbl.Clone()
  504.   If Not tbl2.EOF Then tbl2.MoveLast
  505.   GetNumbRecsTbl = tbl2.RecordCount
  506.   tbl2.Close
  507.   gfUpdatable = True
  508.  
  509.   GoTo GNRTEnd
  510.  
  511. GNRTErr:
  512.   'just return because row count is non critical
  513.   GetNumbRecsTbl = -1
  514.   Resume GNRTEnd
  515.  
  516. GNRTEnd:
  517.  
  518. End Function
  519.  
  520. '----------------------------------------------------------------------------
  521. 'to use this function in any app,
  522. '1. create a form with a grid
  523. '2. create a dynaset
  524. '3. call this function from the form with
  525. '   grd    = your grid control name
  526. '   dynst$ = your dynaset open string (table name or SQL select statement)
  527. '   numb&  = the max number of rows to load (grid is limited to 2000)
  528. '   start& = starting row (needed to display the record number in the
  529. '            left column when loading blocks of records as the
  530. '            DynaGrid form in this app does with the "More" button)
  531. '----------------------------------------------------------------------------
  532. Function LoadGrid (grd As Control, FDS As Snapshot, dynst$, numb&, start&) As Integer
  533.    Dim ft As Integer               'field type
  534.    Dim i As Integer, j As Integer  'for loop indexes
  535.    Dim fn As String                'field name
  536.    Dim rc As Integer               'record count
  537.    Dim gs As String                'grid string
  538.  
  539.    On Error GoTo LGErr
  540.  
  541.    MsgBar "Loading Grid for Table View", True
  542.    'setup the grid
  543.    grd.Rows = 2       'reduce the grid
  544.    grd.FixedRows = 0  'allow next step
  545.    grd.Rows = 1       'clears the grid completely
  546.    grd.Cols = FDS.Fields.Count + 1
  547.  
  548.    If start& = 0 Then        'only do it on first call
  549.      On Error Resume Next
  550.      'set the column widths
  551.      For i = 0 To FDS.Fields.Count - 1
  552.        ft = FDS(i).Type
  553.        If ft = FT_STRING Then
  554.          If FDS(i).Size > Len(FDS(i).Name) Then
  555.            If FDS(i).Size <= 10 Then
  556.              grd.ColWidth(i + 1) = FDS(i).Size * fTables.TextWidth("A")
  557.            Else
  558.              grd.ColWidth(i + 1) = 10 * fTables.TextWidth("A")
  559.            End If
  560.          Else
  561.            If Len(FDS(i).Name) <= 10 Then
  562.              grd.ColWidth(i + 1) = Len(FDS(i).Name) * fTables.TextWidth("A")
  563.            Else
  564.              grd.ColWidth(i + 1) = 10 * fTables.TextWidth("A")
  565.            End If
  566.          End If
  567.        ElseIf ft = FT_MEMO Then
  568.          grd.ColWidth(i + 1) = 1200
  569.        Else
  570.          grd.ColWidth(i + 1) = GetFieldWidth(ft)
  571.        End If
  572.      Next
  573.  
  574.      On Error GoTo LGErr
  575.      'load the field names
  576.      grd.Row = 0
  577.      For i = 0 To FDS.Fields.Count - 1
  578.        grd.Col = i + 1
  579.        grd.Text = UCase(FDS(i).Name)
  580.      Next
  581.    End If
  582.  
  583.    rc = 1
  584.  
  585.    'fill method 1
  586.    'add the rows with the additem method
  587.    While FDS.EOF = False And rc <= numb
  588.      gs = CStr(rc + start) + Chr$(9)
  589.      For i = 0 To FDS.Fields.Count - 1
  590.        If FDS(i).Type = FT_MEMO Then
  591.          If FDS(i).FieldSize() < 255 Then
  592.            gs = gs + StripNonAscii(vFieldVal(FDS(i))) + Chr$(9)
  593.          Else
  594.            'can only get the 1st 255 chars
  595.            gs = gs + StripNonAscii(vFieldVal(FDS(i).GetChunk(0, 255))) + Chr$(9)
  596.          End If
  597.        ElseIf FDS(i).Type = FT_STRING Then
  598.          gs = gs + StripNonAscii(vFieldVal(FDS(i))) + Chr$(9)
  599.        Else
  600.          gs = gs + vFieldVal(FDS(i)) + Chr$(9)
  601.        End If
  602.      Next
  603.      gs = Mid(gs, 1, Len(gs) - 1)
  604.      grd.AddItem gs
  605.      FDS.MoveNext
  606.      rc = rc + 1
  607.    Wend
  608.  
  609.    'fill method 2
  610.    'add the cells individually
  611. '   While fds.EOF = False And rc <= numb
  612. '     grd.Rows = rc + 1
  613. '     grd.Row = rc
  614. '     grd.Col = 0
  615. '     grd.Text = CStr(rc + start)
  616. '     For i = 0 To fds.Fields.Count - 1
  617. '       grd.Col = i + 1
  618. '       If fds(i).Type = FT_MEMO Then
  619. '         'can only get the 1st 255 chars
  620. '         grd.Text = StripNonAscii(vFieldVal((fds(i).GetChunk(0, 255))))
  621. '       ElseIf fds(i).Type = FT_STRING Then
  622. '         grd.Text = StripNonAscii(vFieldVal((fds(i))))
  623. '       Else
  624. '         grd.Text = CStr(vFieldVal(fds(i)))
  625. '       End If
  626. '     Next
  627. '     fds.MoveNext
  628. '     rc = rc + 1
  629. '   Wend
  630.  
  631.    grd.FixedRows = 1   'freeze the field names
  632.    grd.FixedCols = 1   'freeze the row numbers
  633.    grd.Row = 1         'set current position
  634.    grd.Col = 1
  635.  
  636.    LoadGrid = rc       'return number added
  637.    GoTo LGEnd
  638.  
  639. LGErr:
  640.    ShowError
  641.    LoadGrid = False    'return 0
  642.    Resume LGEnd
  643.  
  644. LGEnd:
  645.    MsgBar "", False
  646.  
  647. End Function
  648.  
  649. Sub MsgBar (msg As String, pw As Integer)
  650.   If msg = "" Then
  651.     VDMDI.cMsg = "Ready"
  652.   Else
  653.     If pw = True Then
  654.       VDMDI.cMsg = msg + ", please wait..."
  655.     Else
  656.       VDMDI.cMsg = msg
  657.     End If
  658.   End If
  659.   VDMDI.cMsg.Refresh
  660. End Sub
  661.  
  662. Sub Outlines (formname As Form)
  663.     Dim drkgray As Long, fullwhite As Long
  664.     Dim i As Integer
  665.     Dim ctop As Integer, cleft As Integer, cright As Integer, cbottom As Integer
  666.  
  667.     ' Outline a form's controls for 3D look unless control's TAG
  668.     ' property is set to "skip".
  669.  
  670.     Dim cname As Control
  671.     drkgray = RGB(128, 128, 128)
  672.     fullwhite = RGB(255, 255, 255)
  673.  
  674.     For i = 0 To (formname.Controls.Count - 1)
  675.         Set cname = formname.Controls(i)
  676.         If TypeOf cname Is Menu Then
  677.             'Debug.Print "menu item"
  678.         ElseIf (UCase(cname.Tag) = "OL") Then
  679.                 ctop = cname.Top - screen.TwipsPerPixelY
  680.                 cleft = cname.Left - screen.TwipsPerPixelX
  681.                 cright = cname.Left + cname.Width
  682.                 cbottom = cname.Top + cname.Height
  683.                 formname.Line (cleft, ctop)-(cright, ctop), drkgray
  684.                 formname.Line (cleft, ctop)-(cleft, cbottom), drkgray
  685.                 formname.Line (cleft, cbottom)-(cright, cbottom), fullwhite
  686.                 formname.Line (cright, ctop)-(cright, cbottom), fullwhite
  687.         End If
  688.     Next i
  689. End Sub
  690.  
  691. Sub PicOutlines (pic As Control, ctl As Control)
  692.     Dim drkgray As Long, fullwhite As Long
  693.     Dim ctop As Integer, cleft As Integer, cright As Integer, cbottom As Integer
  694.  
  695.     ' Outline a form's controls for 3D look unless control's TAG
  696.     ' property is set to "skip".
  697.  
  698.     Dim cname As Control
  699.     drkgray = RGB(128, 128, 128)
  700.     fullwhite = RGB(255, 255, 255)
  701.  
  702.     ctop = ctl.Top - screen.TwipsPerPixelY
  703.     cleft = ctl.Left - screen.TwipsPerPixelX
  704.     cright = ctl.Left + ctl.Width
  705.     cbottom = ctl.Top + ctl.Height
  706.     pic.Line (cleft, ctop)-(cright, ctop), drkgray
  707.     pic.Line (cleft, ctop)-(cleft, cbottom), drkgray
  708.     pic.Line (cleft, cbottom)-(cright, cbottom), fullwhite
  709.     pic.Line (cright, ctop)-(cright, cbottom), fullwhite
  710.  
  711. End Sub
  712.  
  713. Sub RefreshTables (tbl_list As Control, IncludeQueries As Integer)
  714.    Dim i As Integer, j As Integer, h As Integer
  715.    Dim st As String
  716.    Dim OkayToAdd As Integer
  717.  
  718.    On Error GoTo TRefErr
  719.  
  720.    MsgBar "Refreshing Table List", True
  721.    SetHourglass VDMDI
  722.  
  723.    Set gTableListSS = gCurrentDB.ListTables()
  724.    tbl_list.Clear
  725.  
  726.    If IncludeQueries And gstDataType = "MS Access" Then
  727.      ' the ListTables method is used to display querydefs that might
  728.      ' be present in an Access database, see below for optional code
  729.      While gTableListSS.EOF = False
  730.        st = gTableListSS!Name
  731.        If VDMDI.PrefAllowSys.Checked = False Then
  732.          If (gTableListSS!Attributes And DB_SYSTEMOBJECT) = 0 Then
  733.            tbl_list.AddItem st
  734.          End If
  735.        Else
  736.          tbl_list.AddItem st
  737.        End If
  738.        gTableListSS.MoveNext
  739.      Wend
  740.    Else
  741.      ' this method uses the tabledefs collection but will not display
  742.      ' querydefs in an Access database
  743.      tbl_list.Clear
  744.      For i = 0 To gCurrentDB.TableDefs.Count - 1
  745.        st = gCurrentDB.TableDefs(i).Name
  746.        If (gCurrentDB.TableDefs(i).Attributes And DB_SYSTEMOBJECT) = 0 Then
  747.          tbl_list.AddItem st
  748.        End If
  749.      Next
  750.    End If
  751.   
  752.    GoTo TRefEnd
  753.  
  754. TRefErr:
  755.    ShowError
  756.    gfDBOpenFlag = False
  757.    Resume TRefEnd
  758.  
  759. TRefEnd:
  760.    ResetMouse VDMDI
  761.    MsgBar "", False
  762.  
  763. End Sub
  764.  
  765. Sub ResetMouse (f As Form)
  766.   VDMDI.MousePointer = DEFAULT_MOUSE
  767.   f.MousePointer = DEFAULT_MOUSE
  768. End Sub
  769.  
  770. Function SetFldProperties (ft As String) As String
  771.   'return field length
  772.   If ft = "String" Then
  773.     gwFldType = FT_STRING
  774.   Else
  775.     Select Case ft
  776.       Case "Counter"
  777.         SetFldProperties = "4"
  778.         gwFldType = FT_LONG
  779.         gwFldSize = 4
  780.       Case "True/False"
  781.         SetFldProperties = "1"
  782.         gwFldType = FT_TRUEFALSE
  783.         gwFldSize = 1
  784.       Case "Byte"
  785.         SetFldProperties = "1"
  786.         gwFldType = FT_BYTE
  787.         gwFldSize = 1
  788.       Case "Integer"
  789.         SetFldProperties = "2"
  790.         gwFldType = FT_INTEGER
  791.         gwFldSize = 2
  792.       Case "Long"
  793.         SetFldProperties = "4"
  794.         gwFldType = FT_LONG
  795.         gwFldSize = 4
  796.       Case "Currency"
  797.         SetFldProperties = "8"
  798.         gwFldType = FT_CURRENCY
  799.         gwFldSize = 8
  800.       Case "Single"
  801.         SetFldProperties = "4"
  802.         gwFldType = FT_SINGLE
  803.         gwFldSize = 4
  804.       Case "Double"
  805.         SetFldProperties = "8"
  806.         gwFldType = FT_DOUBLE
  807.         gwFldSize = 8
  808.       Case "Date/Time"
  809.         SetFldProperties = "8"
  810.         gwFldType = FT_DATETIME
  811.         gwFldSize = 8
  812.       Case "Binary"
  813.         SetFldProperties = "0"
  814.         gwFldType = FT_BINARY
  815.         gwFldSize = 0
  816.       Case "Memo"
  817.         SetFldProperties = "0"
  818.         gwFldType = FT_MEMO
  819.         gwFldSize = 0
  820.     End Select
  821.   End If
  822. End Function
  823.  
  824. Sub SetHourglass (f As Form)
  825.   DoEvents  'cause forms to repaint before going on
  826.   VDMDI.MousePointer = HOURGLASS
  827.   f.MousePointer = HOURGLASS
  828. End Sub
  829.  
  830. Sub ShowError ()
  831.   Dim s As String
  832.   Dim crlf As String
  833.  
  834.   crlf = Chr(13) + Chr(10)
  835.   s = "The following Error occurred:" + crlf + crlf
  836.   'add the error string
  837.   s = s + Error$ + crlf
  838.   'add the error number
  839.   s = s + "Number: " + CStr(Err)
  840.   'beep and show the error
  841.   Beep
  842.   MsgBox (s)
  843.  
  844. End Sub
  845.  
  846. Function StripFileName (fname As String) As String
  847.   On Error Resume Next
  848.   Dim i As Integer
  849.  
  850.   For i = Len(fname) To 1 Step -1
  851.     If Mid(fname, i, 1) = "\" Then
  852.       Exit For
  853.     End If
  854.   Next
  855.  
  856.   StripFileName = Mid(fname, 1, i - 1)
  857.  
  858. End Function
  859.  
  860. Function StripNonAscii (vs As Variant) As String
  861.   Dim i As Integer
  862.   Dim ts As String
  863.  
  864.   For i = 1 To Len(vs)
  865.     If Asc(Mid(vs, i, 1)) < 32 Or Asc(Mid(vs, i, 1)) > 126 Then
  866.       ts = ts + " "
  867.     Else
  868.       ts = ts + Mid(vs, i, 1)
  869.     End If
  870.   Next
  871.  
  872.   StripNonAscii = ts
  873.  
  874. End Function
  875.  
  876. Function stTrueFalse (tf As Variant) As String
  877.   If tf = True Then
  878.     stTrueFalse = "True"
  879.   Else
  880.     stTrueFalse = "False"
  881.   End If
  882. End Function
  883.  
  884. Function TableType (tbl As String) As Integer
  885.   Dim i As Integer
  886.  
  887.   gTableListSS.MoveFirst
  888.   While gTableListSS.EOF = False And gTableListSS!Name <> tbl
  889.     gTableListSS.MoveNext
  890.   Wend
  891.   If gTableListSS!Name = tbl Then
  892.     TableType = gTableListSS!TableType
  893.   Else
  894.     TableType = 0
  895.   End If
  896.  
  897. End Function
  898.  
  899. Function vFieldVal (fval As Variant) As Variant
  900.   If IsNull(fval) Then
  901.     vFieldVal = ""
  902.   Else
  903.     vFieldVal = CStr(fval)
  904.   End If
  905. End Function
  906.  
  907.