home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 5 / 05.iso / a / a106 / 2.ddi / APPPROC.PR_ / APPPROC.bin
Encoding:
Text File  |  1994-04-28  |  13.3 KB  |  515 lines
  1. *!*****************************************************************
  2. *!
  3. *!      Procedure: FORCEEXT
  4. *!
  5. *!*****************************************************************
  6. FUNCTION forceext
  7. * Force the extension of "filname" to be whatever ext is.
  8. PARAMETERS filname,ext
  9. PRIVATE ALL
  10. IF SUBSTR(m.ext,1,1) = "."
  11.    m.ext = SUBSTR(m.ext,2,3)
  12. ENDIF
  13.  
  14. m.pname = justpath(m.filname)
  15. m.filname = justfname(UPPER(ALLTRIM(m.filname)))
  16. IF AT('.',m.filname) > 0
  17.    m.filname = SUBSTR(m.filname,1,AT('.',m.filname)-1) + '.' + m.ext
  18. ELSE
  19.    m.filname = m.filname + '.' + m.ext
  20. ENDIF
  21. RETURN addbs(m.pname) + m.filname
  22. *!*****************************************************************
  23. *!
  24. *!      Procedure: DEFAULTEXT
  25. *!
  26. *!*****************************************************************
  27. FUNCTION defaultext
  28. * Force the extension of "filname" to be whatever ext is, but only
  29. * if filname doesn't already have an extension.
  30. PARAMETERS filname,ext
  31. PRIVATE ALL
  32. IF EMPTY(justext(m.filname))
  33.    IF SUBSTR(m.ext,1,1) = "."
  34.       m.ext = SUBSTR(m.ext,2,3)
  35.    ENDIF
  36.  
  37.    RETURN m.filname + '.' + m.ext
  38. ELSE 
  39.    RETURN filname
  40. ENDIF      
  41.  
  42. *!*****************************************************************
  43. *!
  44. *!      Procedure: JUSTFNAME
  45. *!
  46. *!*****************************************************************
  47. FUNCTION justfname
  48. * Return just the filename (i.e., no path) from "filname"
  49. PARAMETERS filname
  50. PRIVATE ALL
  51. IF RAT('\',m.filname) > 0
  52.    m.filname = SUBSTR(m.filname,RAT('\',m.filname)+1,255)
  53. ENDIF
  54. IF AT(':',m.filname) > 0
  55.    m.filname = SUBSTR(m.filname,AT(':',m.filname)+1,255)
  56. ENDIF
  57. RETURN ALLTRIM(UPPER(m.filname))
  58.  
  59. *!*****************************************************************
  60. *!
  61. *!      Procedure: JUSTSTEM
  62. *!
  63. *!*****************************************************************
  64. FUNCTION juststem
  65. * Return just the stem name from "filname"
  66. PARAMETERS filname
  67. PRIVATE ALL
  68. IF RAT('\',m.filname) > 0
  69.    m.filname = SUBSTR(m.filname,RAT('\',m.filname)+1,255)
  70. ENDIF
  71. IF AT(':',m.filname) > 0
  72.    m.filname = SUBSTR(m.filname,AT(':',m.filname)+1,255)
  73. ENDIF
  74. IF AT('.',m.filname) > 0
  75.    m.filname = SUBSTR(m.filname,1,AT('.',m.filname)-1)
  76. ENDIF
  77. RETURN ALLTRIM(UPPER(m.filname))
  78.  
  79. *!*****************************************************************
  80. *!
  81. *!      Procedure: JUSTEXT
  82. *!
  83. *!*****************************************************************
  84. FUNCTION justext
  85. * Return just the extension from "filname"
  86. PARAMETERS filname
  87. PRIVATE ALL
  88. filname = JustFname(m.filname)   && prevents problems with ..\ paths
  89. m.ext = ""
  90. IF AT('.',m.filname) > 0
  91.    m.ext = SUBSTR(m.filname,AT('.',m.filname)+1,3)
  92. ENDIF
  93. RETURN UPPER(m.ext)
  94.  
  95.  
  96. *!*****************************************************************
  97. *!
  98. *!      Procedure: JUSTPATH
  99. *!
  100. *!*****************************************************************
  101. FUNCTION justpath
  102. * Return just the path name from "filname"
  103. PARAMETERS filname
  104. PRIVATE ALL
  105. m.filname = ALLTRIM(UPPER(m.filname))
  106. IF '\' $ m.filname
  107.    m.filname = SUBSTR(m.filname,1,RAT('\',m.filname))
  108.    IF RIGHT(m.filname,1) = '\' AND LEN(m.filname) > 1 ;
  109.          AND SUBSTR(m.filname,LEN(m.filname)-1,1) <> ':'
  110.       m.filname = SUBSTR(m.filname,1,LEN(m.filname)-1)
  111.    ENDIF
  112.    RETURN m.filname
  113. ELSE
  114.    RETURN ''
  115. ENDIF
  116.  
  117. *!*****************************************************************
  118. *!
  119. *!      Procedure: ADDBS
  120. *!
  121. *!*****************************************************************
  122. FUNCTION addbs
  123. * Add a backslash to a path name, if there isn't already one there
  124. PARAMETER pathname
  125. PRIVATE ALL
  126. m.pathname = ALLTRIM(UPPER(m.pathname))
  127. IF !(RIGHT(m.pathname,1) $ '\:') AND !EMPTY(m.pathname)
  128.    m.pathname = m.pathname + '\'
  129. ENDIF
  130. RETURN m.pathname
  131.  
  132. *!*****************************************************************
  133. *!
  134. *!      Procedure: CASCADE
  135. *!
  136. *!*****************************************************************
  137. PROCEDURE cascade
  138. PARAMETERS aliasname, mode
  139. * Recursive procedure to cascade deletes out of the aliasname file and
  140. * its children.  Aliasname is the alias of a database known to be open.
  141. * Delete any child records with a key of keyvalue, but only if the user
  142. * has selected the cascading delete option for the child database.
  143. PRIVATE i, aliasname, keyfield, keyvalue
  144. aliasname = juststem(UPPER(ALLTRIM(aliasname)))
  145.  
  146. * First, see which files are children of this one and cascade them
  147. FOR i = 1 TO m.numareas
  148.    IF Juststem(UPPER(ALLTRIM(dbflist[i,m.pdbfnum]))) == m.aliasname
  149.       * 'i' points at a child of 'aliasname'
  150.       * Did the user elect to cascade deletes into this file?  Are there
  151.       * any matching child records to delete?
  152.       IF dbflist[i,m.cascadenum] = 'Y' and !EOF(dbflist[i,m.cstemnum])
  153.          * Select the child database
  154.          SELECT (dbflist[i,m.cstemnum])
  155.          
  156.          * We will already be positioned on the key value because of the
  157.          * relations that have been set.
  158.          keyfield = dbflist[i,m.cfldnum]
  159.          keyvalue = &keyfield
  160.          DO WHILE &keyfield == m.keyvalue and !EOF()
  161.             * But first delete any applicable children of this child database
  162.             DO cascade WITH dbflist[i,m.cstemnum], mode
  163.             
  164.             * Delete this child database record itself
  165.             IF mode = "DELETE"
  166.                DELETE
  167.                IF !EOF()
  168.                   SKIP
  169.                ENDIF
  170.             ENDIF
  171.          ENDDO
  172.       ENDIF
  173.    ENDIF
  174. ENDFOR
  175. SELECT (aliasname)
  176.  
  177. RETURN
  178.  
  179.  
  180. *!*****************************************************************
  181. *!
  182. *!      Procedure: INVERT
  183. *!
  184. *!*****************************************************************
  185. PROCEDURE invert
  186. * Invert (i.e., index on all fields) the "filname" database
  187.  
  188. PARAMETERS filname
  189. PRIVATE comp_stat, safe_stat, in_area, fstem, i
  190.  
  191. comp_stat = SET("COMPATIBLE")
  192. safe_stat = SET("SAFETY")
  193. SET COMPATIBLE TO FOXPLUS
  194. SET SAFETY OFF
  195.  
  196. m.in_area = SELECT()          && currently selected area
  197.  
  198. m.fstem = juststem(m.filname)
  199. IF USED(m.fstem)
  200.    SELECT (m.fstem)
  201. ELSE
  202.    SELECT 0
  203.    USE (m.filname)
  204. ENDIF
  205.  
  206.  
  207. FOR i = 1 TO FCOUNT()
  208.    fldname = FIELD(i)
  209.    IF !INLIST(TYPE(m.fldname),"M","G","P")
  210.       WAIT WINDOW "Indexing on "+m.fldname NOWAIT
  211.       INDEX ON &fldname TAG (m.fldname)
  212.    ENDIF
  213. ENDFOR
  214.  
  215. IF m.in_area <> SELECT()
  216.    USE
  217. ENDIF
  218. SELECT (m.in_area)
  219. IF m.comp_stat = "ON" OR m.comp_stat = "DB4"
  220.    SET COMPATIBLE TO DB4
  221. ENDIF
  222. IF m.safe_stat = "ON"
  223.    SET SAFETY ON
  224. ENDIF
  225. RETURN
  226.  
  227.  
  228. *!*****************************************************************
  229. *!
  230. *!      Procedure: OPENDBF
  231. *!
  232. *!*****************************************************************
  233. FUNCTION opendbf
  234. * Open a database and return the alias name, or an empty string
  235. *   if the database could not be opened.  Prompt user to find 
  236. *   database if necessary
  237. PARAMETERS fname
  238. PRIVATE stem
  239. IF FILE(m.fname)
  240.    m.stem = juststem(m.fname)
  241.    IF USED(m.stem)
  242.       SELECT (m.stem)
  243.    ELSE
  244.       SELECT 0
  245.       m.fname = LOCFILE(m.fname,'DBF',;
  246.          'Please locate the '+juststem(m.fname)+' database')
  247.       IF EMPTY(m.fname)
  248.          RETURN ''
  249.       ELSE
  250.          USE (m.fname)
  251.       ENDIF
  252.    ENDIF
  253.    RETURN ALIAS()
  254. ELSE
  255.    RETURN ''
  256. ENDIF
  257.  
  258. *!*****************************************************************
  259. *!
  260. *!      Procedure: ACTWIN
  261. *!
  262. *!*****************************************************************
  263. FUNCTION actwin
  264. * Activate window wind_name
  265.  
  266. parameter wind_name
  267. PRIVATE ALL
  268. wind_name = UPPER(ALLTRIM(m.wind_name))
  269. IF !EMPTY(m.wind_name) AND WEXIST(m.wind_name)
  270.    ACTIVATE WINDOW (m.wind_name)
  271. ENDIF
  272. RETURN ''
  273.  
  274.  
  275. *!*****************************************************************
  276. *!
  277. *!      Procedure: ALERT
  278. *!
  279. *!*****************************************************************
  280. PROCEDURE alert
  281. * Display an error message, automatically sizing the message window
  282. *    as necessary.  Semicolons in "strg" mean "new line".
  283. PARAMETERS strg
  284. PRIVATE in_talk, in_cons, numlines, i, remain, maxlen, keycode
  285.  
  286. in_talk = SET('TALK')
  287. SET TALK OFF
  288. in_cons = SET('CONSOLE')
  289.  
  290. m.numlines = OCCURS(';',m.strg) + 1
  291.  
  292. DIMENSION alert_arry[m.numlines]
  293. m.remain = m.strg
  294. m.maxlen = 0
  295. FOR i = 1 TO m.numlines
  296.    IF AT(';',m.remain) > 0
  297.       alert_arry[i] = SUBSTR(m.remain,1,AT(';',m.remain)-1)
  298.       alert_arry[i] = CHRTRAN(alert_arry[i],';','')
  299.       m.remain = SUBSTR(m.remain,AT(';',m.remain)+1)
  300.    ELSE
  301.       alert_arry[i] = m.remain
  302.       m.remain = ''
  303.    ENDIF
  304.    IF LEN(alert_arry[i]) > SCOLS() - 6
  305.       alert_arry[i] = SUBSTR(alert_arry[i],1,SCOLS()-6)
  306.    ENDIF
  307.    IF LEN(alert_arry[i]) > m.maxlen
  308.       m.maxlen = LEN(alert_arry[i])
  309.    ENDIF
  310. ENDFOR
  311.  
  312. m.top_row = INT( (SROWS() - 4 - m.numlines) / 2)
  313. m.bot_row = m.top_row + 3 + m.numlines
  314.  
  315. m.top_col = INT((SCOLS() - m.maxlen - 6) / 2)
  316. m.bot_col = m.top_col + m.maxlen + 6
  317.  
  318. DEFINE WINDOW alert FROM m.top_row,m.top_col TO m.bot_row,m.bot_col;
  319.    DOUBLE COLOR SCHEME 7
  320. ACTIVATE WINDOW alert
  321.  
  322. FOR i = 1 TO m.numlines
  323.    @ i,3 SAY PADC(alert_arry[i],m.maxlen)
  324. ENDFOR
  325.  
  326. SET CONSOLE OFF
  327. keycode = 0
  328. DO WHILE m.keycode = 0
  329.    keycode = INKEY(0,'HM')
  330. ENDDO
  331. SET CONSOLE ON
  332.  
  333. RELEASE WINDOW alert
  334.  
  335. IF m.in_talk = "ON"
  336.    SET TALK ON
  337. ENDIF
  338. IF m.in_cons = "OFF"
  339.    SET CONSOLE OFF
  340. ENDIF
  341.  
  342.  
  343. *!*****************************************************************
  344. *!
  345. *!      Procedure: APPERROR
  346. *!
  347. *!*****************************************************************
  348. PROCEDURE apperror
  349. * Simple ON ERROR routine for FoxApp application
  350.  
  351. PARAMETERS e_program,e_message,e_source,e_lineno,e_error
  352. CLEAR TYPEAHEAD
  353.  
  354. DO CASE
  355. CASE e_error = 217     && invalid display mode
  356.    SET CURSOR OFF
  357.    WAIT WINDOW "That display mode is not available on your computer."
  358.    SET CURSOR ON
  359.    RETURN
  360. CASE e_error = 1707    && CDX not found.  Ignore it.
  361.    RETURN
  362. OTHERWISE
  363.  
  364.    ON ERROR
  365.    m.e_source = ALLTRIM(m.e_source)
  366.    DO alert WITH 'Line No.: '+ALLTRIM(STR(m.e_lineno,5))+';' ;
  367.       +'Program: '+m.e_program +';' ;
  368.       +'  Error: '+m.e_message +';' ;
  369.       +' Source: '+IIF(LEN(m.e_source)<50,;
  370.       m.e_source,SUBSTR(m.e_source,1,50)+'...')
  371.    ON KEY
  372.    CLOSE ALL
  373.    CLEAR PROGRAM
  374.    CLEAR WINDOW
  375.    SET SYSMENU TO DEFAULT
  376.    IF FILE("foxapp.fky")
  377.       RESTORE MACROS FROM foxapp.fky
  378.       DELETE FILE foxapp.fky
  379.    ENDIF
  380.    * Restore original error routine if possible
  381.    IF TYPE('fxapp_error') = 'C'
  382.       ON ERROR &fxapp_error
  383.    ENDIF
  384.  
  385.    CANCEL
  386. ENDCASE
  387. RETURN
  388.  
  389. *!*****************************************************************
  390. *!
  391. *!      Procedure: SHOWPOP
  392. *!
  393. *!*****************************************************************
  394. PROCEDURE showpop
  395. * Determine if a popup can be displayed for this field
  396. PARAMETERS sourcedbf, varname
  397.  
  398. PRIVATE sourcedbf, targetdbf, varname, i, retval
  399.  
  400. * varname is in Proper case coming from BROWSE
  401. varname = UPPER(ALLTRIM(m.varname))
  402.  
  403. * See if any databases are keyed on varname
  404. m.targetdbf = 0
  405. FOR i = 1 TO m.numareas
  406.    IF SUBSTR(dbflist[i,m.cfldnum],AT('.',dbflist[i,m.cfldnum])+1);
  407.          == m.varname
  408.       m.targetdbf = i
  409.    ENDIF
  410. ENDFOR
  411.  
  412. * Make sure we can display list
  413. DO CASE
  414. CASE m.targetdbf = 0
  415.    WAIT WINDOW "No pick list is available for ";
  416.       +PROPER(m.varname)+'.' NOWAIT
  417.    retval = "NULL"
  418. CASE dbflist[m.targetdbf,m.cstemnum] = m.sourcedbf
  419.    * The target database is the one we are in!
  420.  
  421.    * Show the popup, but don't allow any replacements.
  422.    =disppop(dbflist[m.targetdbf,m.cdbfnum], m.varname)
  423.    retval = "NULL"
  424. OTHERWISE
  425.    retval = disppop(dbflist[m.targetdbf,m.cdbfnum], m.varname)
  426. ENDCASE
  427.  
  428. * Replace the selected value into the current field
  429. IF TYPE("retval") = "C"
  430.    IF retval <> "NULL"
  431.       REPLACE &varname WITH retval
  432.    ENDIF
  433. ELSE
  434.    REPLACE &varname WITH retval
  435. ENDIF
  436.  
  437. RETURN
  438. *!*****************************************************************
  439. *!
  440. *!      Procedure: DISPPOP
  441. *!
  442. *!*****************************************************************
  443. FUNCTION disppop
  444. * Display a scrollable list of items in the popdbf database
  445. PARAMETERS popdbf, varname
  446. PRIVATE ALL
  447.  
  448. * Store the value that varname has in the current database
  449. varnameval = &varname
  450.  
  451. in_area = SELECT()
  452. SELECT 0
  453. USE (popdbf) AGAIN
  454.  
  455. * Make sure it has a TAG of varname
  456. i = 1
  457. tag_found = .F.
  458. DO WHILE !EMPTY(TAG(i)) AND !tag_found
  459.    tag_found = (TAG(i) == varname)
  460.    IF !tag_found
  461.       i = i + 1
  462.    ENDIF
  463. ENDDO
  464. IF !tag_found
  465.    INDEX ON (varname) TAG (varname)
  466. ENDIF
  467. SET ORDER TO TAG (varname)
  468.  
  469. * Position picklist at the default value 
  470. SEEK varnameval
  471. IF !FOUND()
  472.    GOTO TOP
  473. ENDIF
  474.  
  475. * Figure out where the pick list should go
  476. DO CASE
  477. CASE COL() < scol()/2
  478.    s_col = scol()/2 + 1
  479.    e_col = scol() - 1
  480.    s_row = 5
  481.    e_row = SROWS() - 3
  482. CASE COL() >= scol()/2
  483.    s_col = 2
  484.    e_col = scol()/2 - 1
  485.    s_row = 5
  486.    e_row = SROWS() - 3
  487. ENDCASE
  488.  
  489. * Display pick list
  490. DEFINE WINDOW dbfwin FROM s_row, s_col TO e_row, e_col ;
  491.    TITLE PROPER(varname)+" pick list" ;
  492.    CLOSE GROW ZOOM FLOAT MINIMIZE ;
  493.    COLOR SCHEME 11
  494. *   COLOR W+/W,N/W,BG/N,BG/N,BG/N,N/BG,N/W,N+/N,BG/N,BG/N,+
  495.  
  496. ON KEY LABEL enter KEYBOARD CHR(23)
  497. SET SYSMENU OFF
  498. BROWSE WINDOW dbfwin NOEDIT NOAPPEND NODELETE
  499. SET SYSMENU AUTOMATIC
  500. ON KEY LABEL enter
  501.  
  502. * If user selected an item, return its value
  503. IF LASTKEY() <> 27
  504.    retval = &varname
  505. ELSE
  506.    retval = "NULL"
  507. ENDIF
  508.  
  509. * Do housekeeping and return
  510. RELEASE WINDOW dbfwin
  511. USE
  512. SELECT (in_area)
  513.  
  514. RETURN retval
  515.