usedbf.prg

我自己编写的用VFP的简单进销存程序供大家参考

PROC USEDBF  &&读取数据文件并处理相关的错误
PARA LCFN1,LCALI,LCFN2,LCFN3,LCFN4,LCFN5,LCCMD,LNSELE
*调用格式：=USEDBF('数据文件全名','别名','文件2','文件3','文件4','文件5','需要执行的命令，如新创建数据文件')
LCDELE=SET('DELE')
LCEXCL=SET('EXCL')
SET EXCL OFF
LCDCMD=''
LCERR=ON('ERROR')
ON ERROR DO ONERRORUSEDBF WITH ERROR(), MESSAGE(), MESSAGE(1), PROGRAM(), LINENO(1)
LCDAL=IIF(TYPE('LCALI')='C',LCALI,IIF(TYPE('LCFN1')='C',SUBS(LCFN1,RAT('\',LCFN1)+1,IIF('.DBF'$UPPE(LCFN1),RAT('.DBF',UPPE(LCFN1))-RAT('\',LCFN1)-1,LEN(LCFN1)-RAT('\',LCFN1))),' '))
LCFN1=IIF(TYPE('LCFN1')='C',IIF('.DBF'$UPPE(LCFN1),LCFN1,IIF(LEN(ALLT(LCFN1))>0,LCFN1+'.DBF',' ')),' ')
LNDSELE=IIF(TYPE('LNSELE')='N',LNSELE,0)
SELE (LNDSELE)
IF USED(LCDAL)
SELE (LCDAL)
ELSE
LCDAL=IIF(LEN(ALLT(LCDAL))>0,' ALIAS '+LCDAL,' ')
LCDCMD=IIF(TYPE('LCCMD')='C',LCCMD,'')
LCFN=IIF(TYPE('LCFN5')='C',IIF(FILE(LCFN5),LCFN5,''),'')
LCFN=IIF(TYPE('LCFN4')='C',IIF(FILE(LCFN4),LCFN4,LCFN),'')
LCFN=IIF(TYPE('LCFN3')='C',IIF(FILE(LCFN3),LCFN3,LCFN),'')
LCFN=IIF(TYPE('LCFN2')='C',IIF(FILE(LCFN2),LCFN2,LCFN),'')
LCFN=IIF(TYPE('LCFN1')='C',IIF(FILE(LCFN1),LCFN1,LCFN),'')
LCDCMD=IIF(LEN(LCFN)>0,'USE '+LCFN+LCDAL,LCDCMD)
*ON ERROR DO ERRRETU
&LCDCMD
ENDI
SET DELE &LCDELE
SET EXCL &LCEXCL
ON ERROR &LCERR
IF !USED()
=MESSAGEBOX("需要的数据文件未能打开!!! 本程序结束。    "+CHR(13)+CHR(13)+"信息：'"+LCDCMD+"'",48,'警告')
CLEAR WINDOWS ALL
CLOSE ALTE ALL
CLOSE DATA ALL
CLOSE FORMAT ALL
CLOSE INDE ALL
CLOSE TABLES ALL
CLEAR READ ALL
CLEAR EVENTS
SET SYSM TO DEFA
ON SHUTDOWN
QUIT
ENDI
IF LEN(LCDCMD)>10
IF 'CREA'$LEFT(LCDCMD,10) AND ('DBF'$LEFT(LCDCMD,10) OR 'TABL'$LEFT(LCDCMD,10))
LCDBF=DBF()
USE
USE &LCDBF
ENDI
ENDI
RETU


PROC ONERRORUSEDBF  &&错误处理程序
PARA MERROR, MESS, MESS1, MPROG, MLINENO
IF LEFT(ALLT(MESS1),1)='&'
MESS1=RIGHT(MESS1,LEN(MESS1)-1)
MESS1=EVAL(MESS1)
ENDIF
DO CASE
  CASE MERROR=0 &&数据超出指定范围
    WAIT WINDOW '错 误 号：'+ALLT(STR(MERROR))+'  出错信息：'+MESS+'  数据超出指定范围，需要重新输入。' TIMEOUT 6
    RETURN
  CASE MERROR=1 &&文件不存在
    IF '.DBC'$UPPE(MESS) AND '.DBF'$UPPE(LCFN)
      WAIT WINDOW '错 误 号：'+ALLT(STR(MERROR))+'  出错信息：'+MESS+' 释放数据表。' TIMEOUT 6
      FREE TABLE &LCFN
      RETRY
    ENDIF
  CASE MERROR=41 &&备注文件.FPT缺少或无效
    WAIT WINDOW '错 误 号：'+ALLT(STR(MERROR))+'  出错信息：'+MESS+' 重建备注文件。' TIMEOUT 6
    IF '.FPT'$UPPE(MESS) AND '.DBF'$UPPE(LCFN)
      CREA DBF 0(M M)
      USE
      C='COPY FILE 0.FPT TO '+LEFT(LCFN,LEN(LCFN)-4)+'.FPT'
      &C
      DELE FILE 0.DBF
      DELE FILE 0.FPT
      RETRY
    ENDIF
  CASE MERROR=114 &&索引与表不匹配
    WAIT WINDOW '错 误 号：'+ALLT(STR(MERROR))+'  出错信息：'+MESS+'  删除索引。' TIMEOUT 6
    DELE FILE (LEFT(LCFN,LEN(LCFN)-4)+'.CDX')
    RETRY
  CASE MERROR=1707 &&找不到结构 .CDX文件
    WAIT WINDOW '错 误 号：'+ALLT(STR(MERROR))+'  出错信息：'+MESS+'  忽略索引。' TIMEOUT 6
    RETRY
ENDCASE
ERRMSG=MESSAGEBOX('错 误 号：'+LTRIM(STR(MERROR))+CHR(13);
 +'出错信息：'+MESS+CHR(13)+'出错代码：'+MESS1+CHR(13)+'出错程序：'+MPROG;
 +CHR(13)+'出错行号：'+LTRIM(STR(MLINENO))+CHR(13);
 +'是否要终止？'+CHR(13);
 +'(建议终止本程序并与程序设计或数据管理人员联系)    ',2+48+0,'出错信息')
DO CASE
  CASE ERRMSG=4
    SET DEBUG ON
    SET ECHO ON
    RETRY
  CASE ERRMSG=5
    SET DEBUG ON
    SET ECHO ON
  CASE ERRMSG=3
IF TYPE('LCERR')='C'
ON ERROR &LCERR
ENDIF
&&执行退出程序
=MESSAGEBOX("需要的数据文件未能打开!!! 本程序结束。    "+CHR(13)+CHR(13)+"信息：'"+LCDCMD+"'",48,'警告')
CLEAR WINDOWS ALL
CLOSE ALTE ALL
CLOSE DATA ALL
CLOSE FORMAT ALL
CLOSE INDE ALL
CLOSE TABLES ALL
CLEAR READ ALL
CLEAR EVENTS
SET SYSM TO DEFA
ON SHUTDOWN
QUIT
ENDCASE
RETURN

PROC ERRRETU  &&错误处理忽略
RETU