usedbf.prg

我自己用VFP编写的查看指定数据库中的相关数据的程序供大家参考

* -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
*  文件名: USEDBF.PRG <-- 本文件由 UnFoxAll 创建
* -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-



PROCEDURE USEDBF
 PARAMETER LCFN1 , LCALI , LCFN2 , LCFN3 , LCFN4 , LCFN5 , LCCMD , LNSELE
 SET EXCLUSIVE 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',SUBSTR(LCFN1,RAT('\',LCFN1) + 1,IIF('.DBF' $ UPPER(LCFN1),RAT('.DBF',UPPER(LCFN1)) - RAT('\',LCFN1) - 1,LEN(LCFN1) - RAT('\',LCFN1))),' '))
 LCFN1 =  ;
      IIF(TYPE('LCFN1') = 'C',IIF('.DBF' $ UPPER(LCFN1),LCFN1,IIF(LEN(ALLTRIM(LCFN1)) > 0,LCFN1 + '.DBF',' ')),' ')
 LNDSELE = IIF(TYPE('LNSELE') = 'N',LNSELE,0)
 SELECT (LNDSELE)
 IF USED(LCDAL)
    SELECT (LCDAL)
 ELSE 
    LCDAL = IIF(LEN(ALLTRIM(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
 ENDIF 
  ON ERROR &LCERR
 IF  .NOT. USED()
    = MESSAGEBOX('需要的数据文件未能打开!!! 本程序结束。    ' + CHR(13) + CHR(13) + "信息：'" +  ;
   LCDCMD +  ;
   "'",48,'警告')
    CLEAR WINDOW
    CLOSE ALTERNATE 
    CLOSE DATABASES ALL
    CLOSE FORM
    CLOSE INDEXES 
    CLOSE TABLE ALL
    CLEAR READ ALL
    CLEAR EVENTS 
    SET SYSMENU TO DEFAULT
    ON SHUTDOWN 
    QUIT 
 ENDIF 
 IF LEN(LCDCMD) > 10
    IF 'CREA' $ LEFT(LCDCMD,10) AND ('DBF' $ LEFT(LCDCMD,10) .OR. 'TABL' $ LEFT(LCDCMD,10))
       LCDBF = DBF()
       USE 
        USE &LCDBF
    ENDIF 
 ENDIF 
 RETURN 
ENDPROC
*------
PROCEDURE ONERRORUSEDBF
 PARAMETER MERROR , MESS , MESS1 , MPROG , MLINENO
 IF LEFT(ALLTRIM(MESS1),1) = '&'
    MESS1 = RIGHT(MESS1,LEN(MESS1) - 1)
    MESS1 = EVALUATE(MESS1)
 ENDIF 
 DO CASE 
 CASE MERROR = 0
    WAIT WINDOW TIMEOUT 6  ;
         '错 误 号：' + ALLTRIM(STR(MERROR)) + '  出错信息：' + MESS +  ;
   '  数据超出指定范围，需要重新输入。'
    RETURN 
 CASE MERROR = 1
    IF '.DBC' $ UPPER(MESS) AND '.DBF' $ UPPER(LCFN)
       WAIT WINDOW TIMEOUT 6  ;
            '错 误 号：' + ALLTRIM(STR(MERROR)) + '  出错信息：' + MESS + ' 释放数据表。'
        FREE TABLE &LCFN
       RETRY  
    ENDIF 
 CASE MERROR = 41
    WAIT WINDOW TIMEOUT 6  ;
         '错 误 号：' + ALLTRIM(STR(MERROR)) + '  出错信息：' + MESS + ' 重建备注文件。'
    IF '.FPT' $ UPPER(MESS) AND '.DBF' $ UPPER(LCFN)
       CREATE TABLE 0 ( M M )
       USE 
       C = 'COPY FILE 0.FPT TO ' + LEFT(LCFN,LEN(LCFN) - 4) + '.FPT'
        &C
       DELETE File 0.DBF
       DELETE File 0.FPT
       RETRY  
    ENDIF 
 CASE MERROR = 114
    WAIT WINDOW TIMEOUT 6  ;
         '错 误 号：' + ALLTRIM(STR(MERROR)) + '  出错信息：' + MESS + '  删除索引。'
    DELETE File (LEFT(LCFN,LEN(LCFN) - 4) + '.CDX')
    RETRY  
 CASE MERROR = 1707
    WAIT WINDOW TIMEOUT 6  ;
         '错 误 号：' + ALLTRIM(STR(MERROR)) + '  出错信息：' + MESS + '  忽略索引。'
    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) +  ;
'(建议终止本程序并与程序设计或数据管理人员联系)    ',50,'出错信息')
 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 WINDOW
    CLOSE ALTERNATE 
    CLOSE DATABASES ALL
    CLOSE FORM
    CLOSE INDEXES 
    CLOSE TABLE ALL
    CLEAR READ ALL
    CLEAR EVENTS 
    SET SYSMENU TO DEFAULT
    ON SHUTDOWN 
    QUIT 
 ENDCASE 
 RETURN 
ENDPROC
*------
PROCEDURE ERRRETU
 RETURN 
ENDPROC
*------*