Hi folks.

After much deliberation and mucking around with this problem I came up with the following solution.

Dont know whether it is of help to anyone else


Regards
Geoff Scott

*eInitCmds='contractor=contsub.contractor;subcode=contsub.subcode'
*cAlias='contwrk'
*cOrder='contsubcat'
*lRecallAsk=.T.
*l=TableAddRec(eInitCmds, lRecallAsk, cAlias, cOrder)

* TableAddRec([eKey],[eInitCmds], [lAsk], [cAlias], [cOrder])
PROCEDURE TableAddRec
LPARAMETERS eInitCmds, lRecallAsk, cAlias, cOrder
*
* TableAddRec reduces the probability of a
* duplicate key for new records in multiuser environment
* caused by users cancelling out of an add function
* on the same table thus violating a primary or candidate
* key.
*
* There remains a possible problem where two users both opt
* out of an add on the same table.
*
* Use 'eInitCmds' in situations where you need to set part of a key
* when adding the key. This should be done when adding records to
* a child table to reduce the possible incidence of error.
*
* this may be built from the relational expression
* 'eInitCmds=.RelationalExpr'
* if you wish.
*
LOCAL nSaveRecNo, cSaveAlias, cSaveOrder, cThisAlias, cThisOrder
LOCAL cMessage
LOCAL eCmds, eObj

* ---Init---
nSaveRecNo = RECNO()
cSaveAlias = ALIAS()
cSaveOrder = Order()
IF TYPE(eKey)='U' && undefined
eKey=""
ENDIF
IF TYPE(eInitCmds)='U' && undefined
eInitCmds=""
ENDIF
IF TYPE(lRecallAsk)='U' && undefined
lRecallAsk=.F.
ENDIF
IF TYPE('cAlias')='C' AND NOT EMPTY(cAlias)
cThisAlias=cAlias
ELSE && undefined
cThisAlias=cSaveAlias
ENDIF
IF TYPE('cOrder')='C' AND NOT EMPTY(cOrder)
cThisOrder=cOrder
ELSE && undefined
cThisOrder=cSaveOrder
ENDIF


* ---Clean Shell----
SELECT (cThisAlias)
SET ORDER TO (cOrder)
SCATTER NAME myrec BLANK && clean sheet
*
* Initialise key fields on record
eKeyCmds = ALLTRIM(eInitCmds)
DO WHILE !EMPTY(eKeyCmds)
nCmdLen=ATC(';',eKeyCmds)
IF nCmdLen != 0
eCmd=SUBSTR(eKeyCmds,1,nCmdLen-1)
eKeyCmds=SUBSTR(eKeyCmds,nCmdLen+1) && rest of commands
ELSE
eCmd=ALLTRIM(eKeyCmds)
eKeyCmds="" && no more commands
ENDIF
nObjLen=ATC('=',eCmd)
eObj='myrec.'+SUBSTR(eCmd,1,nObjLen-1) && l value
eCmd=SUBSTR(eCmd,nObjLen+1) && r value
&eObj=EVALUATE(eCmd) && do the command
ENDDO
*
* Build the key
lInFunct =.F.
lPrefix = .F.
lQuoted = .F.
cOutKey = ''
cPartKey = ''
eKey=ALLTRIM(KEY())
nKeyLen=LEN(eKey)
IF nKeyLen !=0
FOR i=1 TO nKeyLen+1
cChar = SUBSTR(eKey,i,1)
DO CASE
CASE INLIST(cChar, '+',',',')',']','}') OR ;
i=nKeyLen &&
IF NOT lPrefix
cOutkey=cOutkey+'myrec.'+cPartKey && add prefix
cPartKey=''
ELSE
cOutKey=cOutKey+cPartKey
lPrefix=.F.
ENDIF
cOutKey=cOutKey+cChar && add the delimeter
CASE INLIST(cChar, '(','[')
cOutkey=cOutkey+cPartKey
cPartKey=''
cOutKey=cOutKey+cChar
lPrefix=.F.
CASE INLIST(cChar, '.','{')
cOutkey=cOutkey+cPartKey
cPartKey=''
lPrefix=.T.
CASE INLIST(cChar, CHR(96), CHR(39), CHR(34)) &&
IF lQuoted
cOutKey=cOutKey+cPartKey
cPartKey=''
lQuoted=.F.
ELSE
lQuoted=.T.
ENDIF
cOutKey=cOutKey+cChar
OTHERWISE
cPartKey=cPartKey+cChar && add the chartactor
ENDCASE
ENDFOR
ENDIF
*
* Check for existing record
SET DELETED OFF
cKey=EVALUATE(cOutKey)
IF nKeyLen !=0 AND INDEXSEEK(EVALUATE(eKey),.T.) && is there a duplicate
IF DELETED()
IF lRecallAsk &&
cMessage='A record with key :- '+CHR(13)+;
CHR(96)+cKey+CHR(39)+CHR(13)+;
'already exists' + CHR(13)+;
'Recall record?'
IF MESSAGEBOX(cMessage,36,'Duplicate record') = 6
RECALL NEXT 1 && yes recall it
ENDIF
ELSE
RECALL NEXT 1 && reuse existing record shell
GATHER NAME myrec && initialised record
ENDIF
ELSE && is an existing record
&& return existing record
ENDIF
ELSE && No duplicate
APPEND BLANK && initialised record
GATHER NAME myrec
ENDIF

* ----Restore pointers----
SELECT(cSaveAlias)
SET ORDER TO (cSaveOrder)
GO nSaveRecNo

ENDPROC

May all your weeds be wildflowers