home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic 4 Unleashed / Visual_Basic_4_Unleashed_SAMS_Publishing_1995.iso / codebsic / unpack.exe / DEMOSUBS.BAS < prev    next >
Encoding:
BASIC Source File  |  1995-02-01  |  8.2 KB  |  319 lines
  1. Option Explicit
  2.  
  3. 'Global structure pointers
  4. Global cb As Long, rc As Integer
  5. Global fPath As String
  6. Global studentDbf As Long, schoolDbf As Long, gradesDbf As Long
  7. Global studentMaster As Long, schoolSlave As Long, gradesSlave As Long
  8. Global schoolIdTag As Long, gradesIdTag As Long
  9. Global schoolFldID As Long, studentFldID As Long
  10.  
  11. 'Global variables
  12. Global gbChangingRec As Integer, glPrevRecno As Long
  13. Global gbAppending As Integer, gbAutoSave As Integer
  14. Global gbQueryChanged As Integer, gbSortChanged As Integer
  15. Global gsTempBuf As String, gbOpenExcl As Integer
  16. Global giMsgResponse As Integer, gbFormPurpose As Integer
  17. Global gsQueryExpr As String, gsSortExpr As String
  18.  
  19. 'Loop counters
  20. Global i As Integer, j As Integer
  21.  
  22. 'Arrays of help information
  23. Global studentHelp() As String
  24. Global gradesHelp() As String
  25. Global schoolHelp() As String
  26. Global buttonHelp() As String
  27.  
  28. 'Program Messages
  29. Global Const TITLE = "CodeBasic 5.1"
  30. Global Const INVALID_TAG_NAME = "Invalid Tag name."
  31. Global Const LAST_SEEK_FAILED_MSG = "Would you like to return to your orginal position in database?"
  32. Global Const NAT_ORDER = "NATURAL ORDER"
  33. Global Const NAT_ORDER_INVALID_MSG = "You cannot use NATURAL ORDER in a seek operation. Select one of the other index tags from the list."
  34. Global Const UNIQUE_MSG = "This Student ID already exists, and this value must be unique. Cannot update."
  35. Global Const VALID_EXPR = "Expression(s) is valid."
  36.  
  37. Global Const CMD_OK = 0
  38. Global Const CMD_CANCEL = 1
  39.  
  40. 'Indexes of various button bars
  41.  
  42. 'File
  43. Global Const B_OPEN = 0
  44. Global Const B_CLOSE = 1
  45. Global Const B_EXIT = 2
  46. Global Const B_UNDO = 3
  47. Global Const B_SAVE = 4
  48.  
  49. 'Order/Query
  50. Global Const B_SEEK = 0
  51. Global Const B_QUERY = 1
  52. Global Const B_SORT = 2
  53.  
  54. 'Record
  55. Global Const B_APPEND = 0
  56. Global Const B_DELETE = 1
  57. Global Const B_PACK = 2
  58. Global Const B_ZAP = 3
  59.  
  60. 'Position
  61. Global Const B_TOP = 0
  62. Global Const B_NEXT = 2
  63. Global Const B_LAST = 1
  64. Global Const B_BOTTOM = 3
  65.  
  66.  
  67. 'Check Options
  68. Global Const C_AUTO_SAVE = 0
  69. Global Const C_HIDE_DEL = 1
  70. Global Const C_CON_DEL = 2
  71. Global Const C_OPEN_EXCL = 3
  72.  
  73. Global Const MED_BLUE = &H808000
  74. Global Const DK_BLUE = &HC00000
  75. Global Const DK_LAV = &H800080
  76. Global Const MED_GRAY = &HC0C0C0
  77. Global Const LT_YELLOW = &HFFFF&
  78. Global Const MED_RED = &HC0
  79.  
  80. 'Cursor values
  81. Global Const DEFAULT = 0
  82. Global Const HOURGLASS = 11
  83.  
  84. ' MsgBox parameters
  85. Global Const MB_OK = 0                 ' OK button only
  86. Global Const MB_OKCANCEL = 1           ' OK and Cancel buttons
  87. Global Const MB_ABORTRETRYIGNORE = 2   ' Abort, Retry, and Ignore buttons
  88. Global Const MB_YESNOCANCEL = 3        ' Yes, No, and Cancel buttons
  89. Global Const MB_YESNO = 4              ' Yes and No buttons
  90. Global Const MB_RETRYCANCEL = 5        ' Retry and Cancel buttons
  91.  
  92. Global Const MB_ICONSTOP = 16          ' Critical message
  93. Global Const MB_ICONQUESTION = 32      ' Warning query
  94. Global Const MB_ICONEXCLAMATION = 48   ' Warning message
  95. Global Const MB_ICONINFORMATION = 64   ' Information message
  96.  
  97. ' MsgBox return values
  98. Global Const IDOK = 1                  ' OK button pressed
  99. Global Const IDCANCEL = 2              ' Cancel button pressed
  100. Global Const IDABORT = 3               ' Abort button pressed
  101. Global Const IDRETRY = 4               ' Retry button pressed
  102. Global Const IDIGNORE = 5              ' Ignore button pressed
  103. Global Const IDYES = 6                 ' Yes button pressed
  104. Global Const IDNO = 7                  ' No button pressed
  105.  
  106. 'Key codes
  107. Global Const KEY_PRIOR = &H21
  108. Global Const KEY_NEXT = &H22
  109. Global Const KEY_END = &H23
  110. Global Const KEY_HOME = &H24
  111.  
  112. 'Flags for use of form 'GenForm'
  113. Global Const ZAP_FORM = 0
  114. Global Const GOTO_FORM = 1
  115.  
  116. Function atrim$ (s As String)
  117.  
  118.    atrim = LTrim$(RTrim$(s))
  119.  
  120. End Function
  121.  
  122. Function cbErr ()
  123.  
  124.    'This function resets error code to 0 ( non-error state)
  125.    'and returns true if an error state existed
  126.  
  127.    If code4errorCode(cb, 0) < 0 Then cbErr = True
  128.  
  129. End Function
  130.  
  131. Sub CenterForm (frm As Form)
  132.  
  133.    If frm.Width > Screen.Width Then
  134.       frm.Left = 0
  135.    Else
  136.       frm.Left = (Screen.Width - frm.Width) / 2
  137.    End If
  138.  
  139.    If frm.Height > Screen.Height Then
  140.       frm.Top = 0
  141.    Else
  142.       frm.Top = (Screen.Height - frm.Height) / 2
  143.    End If
  144.  
  145. End Sub
  146.  
  147. Sub FillList (c As Control, ByVal fldPtr As Long)
  148.  
  149.    'Fills a list box with field values
  150.  
  151.    Dim dbf As Long
  152.    dbf = f4data(fldPtr)    'Get data pointer from field pointer info
  153.  
  154.    rc = d4top(dbf)
  155.  
  156.    'Skip through each record
  157.    For i = 1 To d4reccount(dbf)
  158.       c.AddItem f4str(fldPtr)
  159.       rc = d4skip(dbf, 1)
  160.    Next
  161.  
  162. End Sub
  163.  
  164. Function GetTagName$ ()
  165.  
  166.    'This function returns the name of the currently selected tag
  167.  
  168.    Dim tempBuf As String
  169.  
  170.    tempBuf = tag4alias(d4tagSelected(studentDbf))
  171.  
  172.    If InStr(tempBuf, "0") > 0 Then
  173.       GetTagName = Left$(tempBuf, Len(tempBuf) - 1)
  174.    Else
  175.       GetTagName = tempBuf
  176.    End If
  177.  
  178. End Function
  179.  
  180. Sub InitHelp ()
  181.  
  182.    'This routine initializes various arrays of help information text
  183.    
  184.    ReDim studentHelp(0 To 9)
  185.    ReDim schoolHelp(0 To 3)
  186.    ReDim gradesHelp(0)
  187.    ReDim buttonHelp(3, 4)
  188.  
  189.    studentHelp(0) = "Enter student's first name"
  190.    studentHelp(1) = "Enter student's last name"
  191.    studentHelp(2) = "Enter student's ID"
  192.    studentHelp(3) = "Enter address"
  193.    studentHelp(4) = "Enter address"
  194.    studentHelp(5) = "Enter city"
  195.    studentHelp(6) = "Enter province or state abbreviation"
  196.    studentHelp(7) = "Enter postal or zip code"
  197.    studentHelp(8) = "Enter student's country"
  198.    studentHelp(9) = "Enter student's area code + ph. number"
  199.  
  200.    schoolHelp(0) = "Enter school name"
  201.    schoolHelp(1) = "Enter school type"
  202.    schoolHelp(2) = "Enter name of principal"
  203.    schoolHelp(3) = "Select school ID"
  204.  
  205.    gradesHelp(0) = "Enter grade for this class"
  206.  
  207.    buttonHelp(0, 0) = "Position to top of file"
  208.    buttonHelp(0, 1) = "Skip back one record"
  209.    buttonHelp(0, 2) = "Skip forward one record"
  210.    buttonHelp(0, 3) = "Position to end of file"
  211.  
  212.    buttonHelp(1, 0) = "Seek a record"
  213.    buttonHelp(1, 1) = "Perform a query"
  214.    buttonHelp(1, 2) = "Select record ordering via Index"
  215.  
  216.    buttonHelp(2, 0) = "Add a new record"
  217.    buttonHelp(2, 1) = "Mark/Unmark a record for deletion"
  218.    buttonHelp(2, 2) = "Remove deleted records (Pack)"
  219.    buttonHelp(2, 3) = "Remove a range of records (Zap)"
  220.  
  221.    buttonHelp(3, 0) = "Open demo files"
  222.    buttonHelp(3, 1) = "Close demo files"
  223.    buttonHelp(3, 2) = "Exit program"
  224.    buttonHelp(3, 3) = "Undo changes"
  225.    buttonHelp(3, 4) = "Save current changes"
  226.  
  227. End Sub
  228.  
  229. Sub ListTags (l As ComboBox)
  230.  
  231.    'Fill combo box with index tag names
  232.  
  233.    Dim tagPtr As Long
  234.  
  235.    l.AddItem "NATURAL ORDER"
  236.  
  237.    'Get first tag pointer, if any
  238.    tagPtr = d4tagNext(studentDbf, tagPtr)
  239.  
  240.    Do While tagPtr <> 0
  241.  
  242.       'Get tag name
  243.       gsTempBuf = tag4alias(tagPtr)
  244.  
  245.       'Don't show 'Filtered' tag names, which end in "0"
  246.       If Right$(gsTempBuf, 1) <> "0" Then l.AddItem gsTempBuf
  247.          
  248.       'Get next tag pointer if any
  249.       tagPtr = d4tagNext(studentDbf, tagPtr)
  250.  
  251.    Loop
  252.  
  253. End Sub
  254.  
  255. Sub Main ()
  256.  
  257.    'Initialize the CodeBasic 5.1 DLL
  258.    cb = d4init()
  259.  
  260.    'Error if cb = 0
  261.    If cb = 0 Then Exit Sub
  262.  
  263.    'Initialize arrays of help info
  264.    InitHelp
  265.  
  266.    'Do it
  267.    MainForm.Show 1
  268.  
  269.    'Free DLL resources
  270.    cb = d4initUndo(cb)
  271.  
  272.    End
  273.    
  274. End Sub
  275.  
  276. Sub SelectText ()
  277.  
  278.    Screen.ActiveControl.SelStart = 0
  279.    Screen.ActiveControl.SelLength = Len((Screen.ActiveControl.Text))
  280.    
  281. End Sub
  282.  
  283. Function UpperAlpha% (kAscii As Integer)
  284.  
  285.    If kAscii >= 97 And kAscii <= 122 Then
  286.       UpperAlpha = kAscii - 32
  287.    Else
  288.       UpperAlpha = kAscii
  289.    End If
  290.  
  291. End Function
  292.  
  293. Function ValidTagName (TagName$, dbfPtr&)
  294.  
  295.    'This function determines if 'TagName' is a valid tag for
  296.    'STUDENT.DBF
  297.  
  298.    Dim tagPtr As Long
  299.  
  300.    If atrim(TagName) = "" Then Exit Function
  301.  
  302.    If UCase(TagName) = "NATURAL ORDER" Then
  303.       ValidTagName = True
  304.       Exit Function
  305.    End If
  306.  
  307.    tagPtr = d4tagNext(dbfPtr, tagPtr)
  308.  
  309.    Do While tagPtr <> 0
  310.       If UCase$(tag4alias(tagPtr)) = UCase$(atrim(TagName)) Then
  311.          ValidTagName = True
  312.          Exit Function
  313.       End If
  314.       tagPtr = d4tagNext(studentDbf, tagPtr)
  315.    Loop
  316.  
  317. End Function
  318.  
  319.