set exclusive on

[zlaweq]

I run dbase5 in a multi-user envoronment on Windows NT. I need a routine that will give me an error message when I try to set exclusive on and open a file that another user has locked and that will allow me to do a retry until the file is closed.

 

[dbMark]

This may have more detail than you're looking for, but you can adapt it for your needs. This routine will write to the bottom line so you cannot be in a window that is smaller than the full screen (unless you change that). If you wish you can have the error routine define or activate a window and display everything within that window, then deactivate or release the window when done.

PROCEDURE ERR_RSQ
PARAMETERS ProgName, ProgLine, P_Opts  && PROGLINE IS NUMERIC HERE
* TO BE USED ONLY IN FULL SIZE SCREEN/WINDOW - USES LINE 24 !
PRIVATE hold_print, c_name, c_line, c_opts, c_error, ans
PRIVATE n_wlines, n_wcols, c_errmsg
* ACTIVATE SCREEN HERE?
hold_print=SET("PRINT")
SET PRINT OFF
n_wlines=24  && full screen is 25, range is 0-24)
n_wcols=80
c_name=IIF(TYPE("PROGNAME")="C",PROGNAME,"?")
c_line=IIF(TYPE("PROGLINE")="C",PROGLINE, ;
       IIF(TYPE("PROGLINE")="N",LTRIM(STR(PROGLINE)),"?"))
IF TYPE("P_OPTS")="C" .AND. "S" $ P_OPTS  && SKIP OPTION REQUESTED
   c_opts = "@M R,S,Q"
   C_TEXT = "Retry/Skip/Quit"
ELSE
   c_opts = "@M R,Q"
   C_TEXT = "Retry/Quit"
ENDIF
c_error=LTRIM(STR(ERROR()))
temp_err=ERROR()   && save here just in case
PRIVATE msg_detail
msg_detail=MESSAGE()
IF "FILE IN USE BY ANOTHER" $ UPPER(MESSAGE())
   * Change "ON ERROR" so we don't loop
   * (reverts to original error setting upon exit)
   ON ERROR DO Message WITH PROGRAM()+" "+LTRIM(STR(LINE())) ;
                    +" Err#"+LTRIM(STR(ERROR()))+" "+MESSAGE()
   * Insert code here to look at a table, if any,
   * you may have tracking files users have open...
ENDIF

ans="R"
c_errmsg=c_name+" L#"+c_line+" Err#"+c_error+" "+msg_detail
c_errmsg=LEFT(c_line24,n_wcols-(7+LEN(C_TEXT)))+": "+C_TEXT+" ?"
@ n_wlines,0 SAY c_errmsg GET ans PICTURE (c_opts)
       * PICT (c_opts) works with standard vars structure but using
       * PICT EVAL(c_opts) or &c_opts requires quotes INSIDE the var string too
READ
@ 24,0 SAY SPACE(79)

DO CASE
   CASE ans $ "R"  && RETRY
        SET PRINT &hold_print  && Restore printer status
        RETRY
   CASE ans $ "Q" .AND. SET("DEVELOPMENT")="ON" ;
                  .AND. "ADMIN" $ ID() .OR. "{MYNAME}" $ $ ID()
        * If you are the debugger this lets you examine running status
        * With Novell ID() will return UPPER(loginname)+"1"
        * With Windows servers ID() will return UPPER(computername)+"1"
        ?? CHR(7)  && BEEP
        SET COLOR OF NORMAL TO G+/N
        @24,1 SAY " Program suspended, files still open . . . Type "
        SET COLOR OF NORMAL TO R+/N
        ?? "QUIT"
        SET COLOR OF NORMAL TO G+/N
        ?? " to close all. "
        SET COLOR OF NORMAL TO W+/B  && STANDARD DEFAULT
        SUSPEND
   CASE ans $ "Q"
        QUIT
   CASE ans $ "S"  && SKIP
        SET PRINT &hold_print  && Restore printer status
        RETURN  && USE ONLY IF UPON RETURN CODE CAN CONTINUE AFTER FAILURE!
ENDCASE
RETURN