main.prg

通过VFP编程来将数据压缩并存放在软盘内上报

* -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
*  文件名: MAIN.PRG(主文件) <-- 本文件由 UnFoxAll 创建
* -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-


 SET ESCAPE ON
 SET SYSMENU TO
 SET TALK OFF
 SET ECHO OFF
 SET STEP OFF
 SET SAFETY OFF
 SET EXCLUSIVE OFF
 SET DATE TO ANSI
 SET CENTURY ON
 SET HOURS TO 24
 SET MULTILOCKS ON
 SET DELETED ON
 SET COMPATIBLE ON
 LCTEMP = SYS(2023)
 LNTEMP = LEN(LCTEMP)
 LCDEFA = SET('DEFAULT')
 LCDEFAULTNOW = JUSTPATH(SYS(16))
 IF RIGHT(LCDEFAULTNOW,1) <> '\'
    LCDEFAULTNOW = LCDEFAULTNOW + '\'
 ENDIF 
 LLCALLAPP = IIF(TYPE('LCCALLAPP') = 'C',LCCALLAPP == 'CALLAPP',.F.)
 IF  .NOT. LLCALLAPP
    ON SHUTDOWN DO ONSHUTD
    ON ESCAPE DO ONESCAPE
    ON ERROR DO ONERROR WITH ERROR(), MESSAGE(), MESSAGE(1), PROGRAM(), LINENO(1)
    ON READERROR DO ONERROR WITH ERROR(), MESSAGE(), MESSAGE(1), PROGRAM(), LINENO(1)
    ON KEY LABEL F12 DO ONESCAPEF12
    _SCREEN.WINDOWSTATE = 2
    _SCREEN.CAPTION = '数据报送'
    _SCREEN.ICON = 'DATAREPO.ICO'
 ENDIF 
 CLOSE DATABASES ALL
 CLOSE TABLE ALL
 PUBLIC USERNAME , SHORTNAME , FULLNAME , ADDR
 SELECT 0
  USEDBFCOMPANY()
 M.SHORTNAME = COMPANY.NAME
 M.FULLNAME = COMPANY.FULLNAME
 M.ADDR = COMPANY.ADDR
 USE 
 USERNAME = ''
 DO FORM MAINFORM NAME FORMMAINFORM LINKED 
 SET SYSMENU TO DEFAULT
 CLOSE DATABASES ALL
 CLOSE TABLE ALL
 IF LLCALLAPP
    RETURN 
 ELSE 
    ON SHUTDOWN 
    QUIT 
 ENDIF 

PROCEDURE ONERROR
 PARAMETER MERROR , MESS , MESS1 , MPROG , MLINENO
 DO CASE 
 CASE MERROR = 0
    WAIT WINDOW TIMEOUT 6  ;
         '错 误 号：' + ALLTRIM(STR(MERROR)) + '  出错信息：' + MESS +  ;
   '  数据超出指定范围，需要重新输入。'
    RETURN 
 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
    RETURN 
 CASE ERRMSG = 3
    DO ONSHUTD
 ENDCASE 
 RETURN 
ENDPROC
*------
PROCEDURE ONSHUTD
 IF MESSAGEBOX('是否要退出本系统?    ',33,'退出') = 1
    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 
ENDPROC
*------
PROCEDURE ONESCAPE
 = MESSAGEBOX('ESCAPE键中止！    ',52,'中止')
 DO ONSHUTD
 RETURN 
ENDPROC
*------
PROCEDURE ONESCAPEF12
 = MESSAGEBOX('F12 键中止！    ',52,'中止')
 DO ONSHUTD
 RETURN 
ENDPROC
*------
PROCEDURE USEDBF
 PARAMETER LCFN1 , LCALI , LCFN2 , LCFN3 , LCFN4 , LCFN5 , LCCMD , LNSELE
 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)
     &LCDCMD
 ENDIF 
  ON ERROR &LCERR
 IF  .NOT. USED()
    = MESSAGEBOX('需要的数据文件未能打开!!! 本程序结束。    ',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 
 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 
    DO ONSHUTD
 ENDCASE 
 RETURN 
ENDPROC
*------*