home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / dtadmo / module1.bas < prev    next >
Encoding:
BASIC Source File  |  1994-10-15  |  13.8 KB  |  504 lines
  1. 'copyright (c) 1994 by Bruce Fulton
  2. 'All Rights Reserved
  3. 'You may use this program for your own education
  4. 'and information, and you may give a copy of the program,
  5. 'completely intact, to others to help them learn, but
  6. 'you may not charge for the program nor may you charge
  7. 'any fee for copying it for others.
  8. Option Explicit
  9.  
  10. 'program declarations
  11. Global ThePath As String
  12. Global Const MB_YESNO = 4              ' Yes and No buttons
  13. Global Const IDYES = 6                 ' Yes button pressed
  14. Global Const MB_DEFBUTTON2 = 256       ' Second button is default
  15.  
  16.  
  17. ' from the data.txt constant file
  18. ' Data Access constants
  19. ' not all of these are used in this program
  20. '
  21. ' Option argument values (CreateDynaset, etc)
  22. Global Const DB_DENYWRITE = &H1
  23. Global Const DB_DENYREAD = &H2
  24. Global Const DB_READONLY = &H4
  25. Global Const DB_APPENDONLY = &H8
  26. Global Const DB_INCONSISTENT = &H10
  27. Global Const DB_CONSISTENT = &H20
  28. Global Const DB_SQLPASSTHROUGH = &H40
  29.  
  30. ' SetDataAccessOption
  31. Global Const DB_OPTIONINIPATH = 1
  32.  
  33. ' Field Attributes
  34. Global Const DB_FIXEDFIELD = &H1
  35. Global Const DB_VARIABLEFIELD = &H2
  36. Global Const DB_AUTOINCRFIELD = &H10
  37. Global Const DB_UPDATABLEFIELD = &H20
  38.  
  39. ' Field Data Types
  40. Global Const DB_BOOLEAN = 1
  41. Global Const DB_BYTE = 2
  42. Global Const DB_INTEGER = 3
  43. Global Const DB_LONG = 4
  44. Global Const DB_CURRENCY = 5
  45. Global Const DB_SINGLE = 6
  46. Global Const DB_DOUBLE = 7
  47. Global Const DB_DATE = 8
  48. Global Const DB_TEXT = 10
  49. Global Const DB_LONGBINARY = 11
  50. Global Const DB_MEMO = 12
  51.  
  52. ' TableDef Attributes
  53. Global Const DB_ATTACHEXCLUSIVE = &H10000
  54. Global Const DB_ATTACHSAVEPWD = &H20000
  55. Global Const DB_SYSTEMOBJECT = &H80000002
  56. Global Const DB_ATTACHEDTABLE = &H40000000
  57. Global Const DB_ATTACHEDODBC = &H20000000
  58.  
  59. ' ListTables TableType
  60. Global Const DB_TABLE = 1
  61. Global Const DB_QUERYDEF = 5
  62.  
  63. ' ListTables Attributes (for QueryDefs)
  64. Global Const DB_QACTION = &HF0
  65. Global Const DB_QCROSSTAB = &H10
  66. Global Const DB_QDELETE = &H20
  67. Global Const DB_QUPDATE = &H30
  68. Global Const DB_QAPPEND = &H40
  69. Global Const DB_QMAKETABLE = &H50
  70.  
  71. ' ListIndexes IndexAttributes values
  72. Global Const DB_UNIQUE = 1
  73. Global Const DB_PRIMARY = 2
  74. Global Const DB_PROHIBITNULL = 4
  75. Global Const DB_IGNORENULL = 8
  76. ' ListIndexes FieldAttributes value
  77. Global Const DB_DESCENDING = 1  'For each field in Index
  78.  
  79. ' CreateDatabase and CompactDatabase Language constants
  80. Global Const DB_LANG_GENERAL = ";LANGID=0x0809;CP=1252;COUNTRY=0"
  81. Global Const DB_LANG_SPANISH = ";LANGID=0x040A;CP=1252;COUNTRY=0"
  82. Global Const DB_LANG_DUTCH = ";LANGID=0x0413;CP=1252;COUNTRY=0"
  83. Global Const DB_LANG_SWEDFIN = ";LANGID=0x040C;CP=1252;COUNTRY=0"   'VB3 andAccess 1.1 Databases
  84. Global Const DB_LANG_NORWDAN = ";LANGID=0x0414;CP=1252;COUNTRY=0"   'VB3 andAccess 1.1 Databases
  85. Global Const DB_LANG_ICELANDIC = ";LANGID=0x040F;CP=1252;COUNTRY=0" 'VB3 andAccess 1.1 Databases
  86. Global Const DB_LANG_NORDIC = ";LANGID=0x041D;CP=1252;COUNTRY=0"    'Access 1.0 Databases only
  87.  
  88. ' CreateDatabase and CompactDatabase options
  89. Global Const DB_VERSION10 = 1        ' Microsoft Access Version 1.0
  90. Global Const DB_ENCRYPT = 2          ' Make database encrypted.
  91. Global Const DB_DECRYPT = 4          ' Decrypt database while compacting.
  92.  
  93. 'Collating order values
  94. Global Const DB_SORTGENERAL = 256    ' Sort by EFGPI rules (English, French,  German,Portuguese, Italian)
  95. Global Const DB_SORTSPANISH = 258    ' Sort by Spanish rules
  96. Global Const DB_SORTDUTCH = 259      ' Sort by Dutch rules
  97. Global Const DB_SORTSWEDFIN = 260    ' Sort by Swedish, Finnish rules
  98. Global Const DB_SORTNORWDAN = 261    ' Sort by Norwegian, Danish rules
  99. Global Const DB_SORTICELANDIC = 262  ' Sort by Icelandic rules
  100. Global Const DB_SORTPDXINTL = 4096   ' Sort by Paradox international rules
  101. Global Const DB_SORTPDXSWE = 4097    ' Sort by Paradox Swedish, Finnish rules
  102. Global Const DB_SORTPDXNOR = 4098    ' Sort by Paradox Norwegian, Danish rules
  103. Global Const DB_SORTUNDEFINED = -1   ' Sort rules are undefined or unknown
  104.  
  105. Sub addfield ()
  106.     'turn on the errorhandler
  107.     On Error GoTo addfieldERR
  108.     screen.MousePointer = 11
  109.     
  110.     'dim variables as a database and field objects
  111.     Dim db As database
  112.     Dim newf As New field
  113.  
  114.     'define the name, the type and if applicable,
  115.     'the length and attributes for the field.
  116.     newf.Name = "Comment"
  117.     newf.Type = DB_MEMO
  118.     'open the database
  119.     Set db = OpenDatabase(ThePath + "USPLACE.MDB")
  120.     'add the new field to the Place Names table in the database
  121.     db.TableDefs("Place Names").Fields.Append newf
  122.     'close the database
  123.     db.Close
  124.     screen.MousePointer = 0
  125.     MsgBox "Field 'Comments' successfully added to Place Names."
  126.     
  127.     
  128. 'error trapping routine
  129. GoTo addfieldEND
  130. addfieldERR:
  131.     showerror
  132.     Resume addfieldEND
  133. addfieldEND:
  134. screen.MousePointer = 0
  135.  
  136. End Sub
  137.  
  138. Sub additems (lbl As Label)
  139. 'turn on error trapping
  140. On Error GoTo additemsERR
  141. screen.MousePointer = 11
  142.  
  143. 'declare needed variables
  144. Dim filnam, lin As String
  145. Dim db As database, tb As table
  146. Dim elapsed, itmcnt As Long
  147.  
  148. 'open the database
  149. Set db = OpenDatabase(ThePath + "USPLACE.MDB", True)
  150. 'select/open the table to add to
  151. Set tb = db.OpenTable("Place Names")
  152.  
  153. 'we'll read data in from a
  154. 'fixed field ascii file and add it to the mdb database.
  155. 'You could also load from other file formats or from
  156. 'values in text boxes.
  157. filnam = ThePath + "sample.dta"
  158. Open filnam For Input As #1
  159. 'just skip any duplicate key errors
  160. On Error Resume Next
  161. 'let's see how long it takes
  162. elapsed = Timer
  163. While Not EOF(1)
  164.     'experiment with adding or commenting out the
  165.     'following two statements to see the performance
  166.     'hit!
  167.     
  168.     'DoEvents
  169.     'FreeLocks
  170.     
  171.     'use the addnew method
  172.     tb.AddNew
  173.         Line Input #1, lin
  174.         tb("Name") = Trim$(Mid$(lin, 1, 48))
  175.         lbl.Caption = "Adding " & tb("Name")
  176.         tb("State Code") = Val(Mid$(lin, 60, 2))
  177.         tb("County Code") = Val(Mid$(lin, 62, 3))
  178.         'str2dec converts latitude/longitude
  179.         'in dddhhmm format to decimal format
  180.         tb("Latitude") = str2dec(Mid$(lin, 73, 6))
  181.         tb("Longitude") = str2dec(Mid$(lin, 80, 7))
  182.     'if you don't 'update', the data is not added
  183.     tb.Update
  184.     If Err <> 0 Then
  185.         lbl.Caption = "ERROR - did not add " & tb("Name")
  186.         Err = 0
  187.     Else
  188.         'just counting how many items we've done
  189.         itmcnt = itmcnt + 1
  190.     End If
  191.     'save some time by commenting out the label refresh
  192.     'command
  193.     lbl.Refresh
  194. Wend
  195.  
  196. 'restore regular error handler and close everything
  197. On Error GoTo additemsERR
  198. tb.Close
  199. db.Close
  200. Close #1
  201. form1.Label3.Caption = ""
  202. screen.MousePointer = 0
  203. 'how did we do?
  204. elapsed = Timer - elapsed
  205. MsgBox Str$(itmcnt) & " items successfully added in " & Str$(elapsed) & " seconds."
  206.  
  207. 'error trapping routine
  208. GoTo additemsEND
  209. additemsERR:
  210.     showerror
  211.     Resume additemsEND
  212. additemsEND:
  213. screen.MousePointer = 0
  214. End Sub
  215.  
  216. Sub addnameidx ()
  217.     'turn on the errorhandler
  218.     On Error GoTo addnameidxERR
  219.     screen.MousePointer = 11
  220.     
  221.     'dim database, new index objects
  222.     Dim db As database
  223.     Dim ix As New Index
  224.     Dim elapsed
  225.     'name the new table
  226.     ix.Name = "Name Index"
  227.     ix.Fields = "Name"
  228.     ix.Unique = False
  229.     ix.Primary = False
  230.     'let's see how long it took
  231.     elapsed = Timer
  232.     'open the database
  233.     Set db = OpenDatabase(ThePath + "USPLACE.MDB")
  234.     'add the new table to the database
  235.     db.TableDefs("Place Names").Indexes.Append ix
  236.     'close the database
  237.     db.Close
  238.     elapsed = Timer - elapsed
  239.     screen.MousePointer = 0
  240.     MsgBox "Secondary index on Name for table Place Names successfully created. It took " & Str$(elapsed) & " seconds."
  241.  
  242. 'error trapping routine
  243. GoTo addnameidxEND
  244. addnameidxERR:
  245.     showerror
  246.     Resume addnameidxEND
  247. addnameidxEND:
  248. screen.MousePointer = 0
  249.  
  250. End Sub
  251.  
  252. Sub addtucson ()
  253. 'turn on error trapping
  254. On Error GoTo addtucsonERR
  255. screen.MousePointer = 11
  256.  
  257. 'declare needed variables
  258. Dim db As database, tb As table
  259.  
  260. 'open the database
  261. Set db = OpenDatabase(ThePath + "USPLACE.MDB")
  262. 'select the table to add to
  263. Set tb = db.OpenTable("Place Names")
  264.  
  265. 'start addnew method
  266. tb.AddNew
  267.     tb("Name") = "Tucson"
  268.     tb("State Code") = 4
  269.     tb("County Code") = 19
  270.     tb("Latitude") = 32.2667
  271.     tb("Longitude") = 111.0083
  272. 'perform the update
  273. tb.Update
  274. 'If Tucson is already in the database, this will
  275. 'generate a dupe primary key error and not add the item.
  276. 'If the primary key index has not been defined, then
  277. 'you can add this item, but when you try to add the
  278. 'primary index, you will get an error.
  279. 'close the table and database
  280. tb.Close
  281. db.Close
  282. screen.MousePointer = 0
  283. MsgBox "Tucson successfully added"
  284.  
  285. On Error GoTo addtucsonERR
  286.  
  287. 'error trapping routine
  288. GoTo addtucsonEND
  289. addtucsonERR:
  290.     showerror
  291.     Resume addtucsonEND
  292. addtucsonEND:
  293. screen.MousePointer = 0
  294. End Sub
  295.  
  296. Sub killmdb ()
  297.     On Error GoTo killmdbERR
  298.     Dim filspec, s
  299.     filspec = ThePath & "USPLACE.MDB"
  300.     Kill filspec
  301.     filspec = ThePath & "USPLACE.LDB"
  302.     Kill filspec
  303.     s = ThePath & "USPLACE.MDB successfully deleted."
  304.     MsgBox s
  305.  
  306. 'error trapping routine
  307. GoTo killmdbEND
  308. killmdbERR:
  309.     showerror
  310.     Resume killmdbEND
  311. killmdbEND:
  312.  
  313. End Sub
  314.  
  315. Sub makedb ()
  316.     'turn on error handler
  317.     On Error GoTo makedbERR
  318.     screen.MousePointer = 11
  319.     
  320.     'dim a variable as a database object
  321.     Dim Newdb As database
  322.     
  323.     'create the database
  324.     Set Newdb = CreateDatabase(ThePath + "USPLACE.MDB", DB_LANG_GENERAL)
  325.     'close the database
  326.     Newdb.Close
  327.     
  328.     screen.MousePointer = 0
  329.     MsgBox "Database USPLACE.MDB successfully created."
  330.  
  331. 'error trapping routine
  332. GoTo makedbEND
  333. makedbERR:
  334.     showerror
  335.     Resume makedbEND
  336. makedbEND:
  337. screen.MousePointer = 0
  338. End Sub
  339.  
  340. Sub makeindex ()
  341.     'turn on the errorhandler
  342.     On Error GoTo makeindexERR
  343.     screen.MousePointer = 11
  344.     
  345.     'dim database, new index objects
  346.     Dim db As database
  347.     Dim ix As New Index
  348.  
  349.     'name the new index and set properties
  350.     ix.Name = "Lat_Long Index"
  351.     ix.Fields = "Latitude;Longitude"
  352.     ix.Unique = True
  353.     ix.Primary = True
  354.  
  355.     
  356.     'open the database
  357.     Set db = OpenDatabase(ThePath + "USPLACE.MDB")
  358.     'add the new index to the table in the database
  359.     db.TableDefs("Place Names").Indexes.Append ix
  360.     'close the database
  361.     db.Close
  362.     screen.MousePointer = 0
  363.     MsgBox "Primary Key for table Place Names successfully created."
  364.  
  365. 'error trapping routine
  366. GoTo makeindexEND
  367. makeindexERR:
  368.     showerror
  369.     Resume makeindexEND
  370. makeindexEND:
  371. screen.MousePointer = 0
  372.  
  373. End Sub
  374.  
  375. Sub maketable ()
  376.     'turn on the errorhandler
  377.     On Error GoTo maketableERR
  378.     screen.MousePointer = 11
  379.     
  380.     'dim variables as a database, table, field and index objects
  381.     Dim db As database
  382.     Dim Newtd As New tabledef
  383.     ReDim newf(6) As New field
  384.  
  385.     
  386.     'name the new table
  387.     Newtd.Name = "Place Names"
  388.     
  389.     'you must append at least one field when you create
  390.     'a table. you can, of course, do more than one, but
  391.     'you must do at least one
  392.  
  393.     'for each field, set the name, the type and if applicable,
  394.     'the length and attributes. Then, append the new fields
  395.     'to the table object
  396.     newf(1).Name = "RecID"
  397.     newf(1).Type = DB_LONG
  398.     newf(1).Attributes = DB_AUTOINCRFIELD
  399.     Newtd.Fields.Append newf(1)
  400.  
  401.     newf(2).Name = "Name"
  402.     newf(2).Type = DB_TEXT
  403.     newf(2).Size = 48
  404.     Newtd.Fields.Append newf(2)
  405.  
  406.     newf(3).Name = "State Code"
  407.     newf(3).Type = DB_INTEGER
  408.     Newtd.Fields.Append newf(3)
  409.     
  410.     newf(4).Name = "County Code"
  411.     newf(4).Type = DB_INTEGER
  412.     Newtd.Fields.Append newf(4)
  413.  
  414.     newf(5).Name = "Latitude"
  415.     newf(5).Type = DB_CURRENCY
  416.     Newtd.Fields.Append newf(5)
  417.  
  418.     newf(6).Name = "Longitude"
  419.     newf(6).Type = DB_CURRENCY
  420.     Newtd.Fields.Append newf(6)
  421.  
  422.     'open the database
  423.     Set db = OpenDatabase(ThePath + "USPLACE.MDB")
  424.     'add the new table to the database
  425.     db.TableDefs.Append Newtd
  426.     'close the database
  427.     db.Close
  428.     screen.MousePointer = 0
  429.     MsgBox "Table Place Names successfully created."
  430.     
  431. 'error trapping routine
  432. GoTo maketableEND
  433. maketableERR:
  434.     showerror
  435.     Resume maketableEND
  436. maketableEND:
  437. screen.MousePointer = 0
  438. End Sub
  439.  
  440. Sub seekname ()
  441.     'turn on the errorhandler
  442.     On Error GoTo seeknameERR
  443.     'dim database, new index objects
  444.     Dim db As database
  445.     Dim tb As table
  446.     Dim ix As Index
  447.     Dim tmpstr, crlf As String
  448.     crlf = Chr$(13) + Chr$(10)
  449.     'open the database
  450.     Set db = OpenDatabase(ThePath + "USPLACE.MDB")
  451.     'open the table
  452.     Set tb = db.OpenTable("Place Names")
  453.     'specify the index
  454.     tb.Index = "Name Index"
  455.     'perform the seek:
  456.     tb.Seek ">=", InputBox$("Name to look for:")
  457.     If tb.NoMatch Then
  458.         MsgBox "Record not found."
  459.     Else
  460.         tmpstr = tb("name") & crlf & "Latitude: " & Str$(tb("Latitude")) & crlf & "Longitude: " & Str$(tb("Longitude"))
  461.         MsgBox tmpstr
  462.     End If
  463.     tb.Close
  464.     db.Close
  465.  
  466. 'error trapping routine
  467. GoTo seeknameEND
  468. seeknameERR:
  469.     showerror
  470.     Resume seeknameEND
  471. seeknameEND:
  472. screen.MousePointer = 0
  473.  
  474.  
  475. End Sub
  476.  
  477. Sub showerror ()
  478.   Dim s As String
  479.   Dim crlf As String
  480.  
  481.   crlf = Chr(13) + Chr(10)
  482.   s = "The following Error occurred:" + crlf + crlf
  483.   'add the error string
  484.   s = s + Error$ + crlf
  485.   'add the error number
  486.   s = s + "Number: " + CStr(Err)
  487.   'beep and show the error
  488.   Beep
  489.   MsgBox (s)
  490.  
  491. End Sub
  492.  
  493. Function str2dec (strval As String) As Currency
  494.     If Len(strval) = 6 Then
  495.         str2dec = Val(Left$(strval, 2)) + Val(Mid$(strval, 3, 2)) / 60 + Val(Right$(strval, 2)) / 360
  496.     ElseIf Len(strval) = 7 Then
  497.         str2dec = Val(Left$(strval, 3)) + Val(Mid$(strval, 4, 2)) / 60 + Val(Right$(strval, 2)) / 360
  498.     Else
  499.         str2dec = 0
  500.     End If
  501.  
  502. End Function
  503.  
  504.