phs.prg

一个非常好用的财务软件源程序

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



PROCEDURE ptsxx
 DEFINE WINDOW WTSXX FROM 1 , 60 TO 6 , 95 TITLE '提示信息' SYSTEM 
 ACTIVATE WINDOW WTSXX
 @ 1 , 1 SAY '正在处理,请稍侯...' FONT '宋体' , 12
 MOVE WINDOW WTSXX CENTER 
 RETURN 
ENDPROC
*------
PROCEDURE puse
 PARAMETER BDBFNAME
 IF USED(BDBFNAME)
    SELECT (BDBFNAME)
 ELSE 
    SELECT 0
    USE (BDBFNAME)
 ENDIF 
 RETURN 
ENDPROC
*------
PROCEDURE phf
 J = 1
 ON ERROR do pcxcw
 I = MESSAGEBOX('数据恢复时要保证无其它人使用,准备好数据盘后继续',65,'提示信息')
 IF I = 1
    USE ksjwz
    AAA = SJPATH + '\*.*'
    EEE = SUBSTR(SJPATH,1,3)
    BBB = ALLTRIM(FBFWZ) + '.arj'
    CCC = 'a:\' + ALLTRIM(FBFWZ) + '.arj'
    USE 
    IF FILE(CCC)
       DDD = FDATE(CCC)
       I =  ;
            MESSAGEBOX('该数据为' + DTOC(DDD) + '备份,是否使用该数据恢复?',65,'提示信息')
       IF I = 1
           erase &bbb
           run arj a &bbb &aaa -y
           run arj x &ccc &eee -y
          IF J = 1
             = MESSAGEBOX('  数据恢复成功!  ',64,'提示信息')
          ENDIF 
       ENDIF 
    ELSE 
       = MESSAGEBOX('A盘中没有数据备份盘!',64,'提示信息')
       RETURN 
    ENDIF 
 ENDIF 
 RETURN 
ENDPROC
*------
PROCEDURE pcxcw
 = MESSAGEBOX('您的数据盘已损坏,恢复不成功,系统仍使用原数据!',64,'提示信息')
  run arj x &bbb &eee -y
 J = 0
ENDPROC
*------
PROCEDURE psjbf
 USE ksjwz
 BBB = ALLTRIM(FBFWZ) + '.arj'
 CCC = 'a:\' + ALLTRIM(FBFWZ) + '.arj'
 USE 
 ON ERROR do pbfjc
 SET COMPATIBLE ON
 J = 1
 I = MESSAGEBOX('请插入软盘,按确定后继续',65,'提示信息')
 IF I = 1
    AAA = SJPATH + '\*.*'
     run  arj a &bbb  &aaa 
     erase &ccc
    IF J = 1
       SET DEFAULT TO a:
       AA = DISKSPACE()
        set defa to &cxpath
       IF AA > FSIZE(BBB) AND J = 1
           copy file &bbb to &ccc
          IF J = 1
              erase &bbb
             I = MESSAGEBOX('数据备份完毕!',64,'提示信息')
          ELSE 
             ON ERROR 
          ENDIF 
       ELSE 
           erase &bbb
          I = MESSAGEBOX('该软盘剩余空间不够,备份不成功!',64,'提示信息')
       ENDIF 
    ELSE 
       ON ERROR 
    ENDIF 
 ENDIF 
 SET COMPATIBLE OFF
ENDPROC
*------
PROCEDURE pbfjc
 IF ERROR() = 1002
    = MESSAGEBOX('A盘没有软盘或软盘损坏,备份不成功!','提示信息')
 ENDIF 
 J = 0
 RETURN 
ENDPROC
*------
PROCEDURE crepath
 PARAMETER CREPATH
 PRIVATE OLDPATH , CREPATH
 OLDPATH = FULLPATH('')
 IF AT('\',CREPATH) >= 2
    NEWDIR = ''
    FOR ATT = 1 TO LEN(CREPATH)
       ONECHAR = SUBSTR(CREPATH,ATT,1)
       IF (ONECHAR = '\' AND ATT > 3) .OR. ATT = LEN(CREPATH)
          IF LEN(CREPATH) = ATT
             NEWDIR = NEWDIR + ONECHAR
          ENDIF 
          IF ADIR(EXISTPATH,NEWDIR,'D') = 0
             ON ERROR mm=1
              md &newdir
             ON ERROR 
          ENDIF 
       ENDIF 
       NEWDIR = NEWDIR + ONECHAR
    ENDFOR 
 ENDIF 
  set defa to &oldpath
ENDPROC
*------
PROCEDURE pjz
 PARAMETER BBSH
 = PUSE('kcr')
 SET ORDER TO fbsh
 SEEK BBSH
 IF FOUND()
    USE 
    SELECT KPZ
    RETURN .T.
 ELSE 
    USE 
    DO PKJQJ
    BNAME = 'kzc' + STR(YEAR(BKSQ),4)
    BNAME1 = 'fjeye' + ALLTRIM(STR(MONTH(BKSQ),2))
    BNAME2 = 'fslye' + ALLTRIM(STR(MONTH(BKSQ),2))
    = PUSE(BNAME)
     loca for fbsh=bbsh.and.(&bname1<>0.or.&bname2<>0)
    IF FOUND()
       USE 
       SELECT KPZ
       RETURN .T.
    ENDIF 
    USE 
    SELECT KPZ
    RETURN .F.
 ENDIF 
ENDPROC
*------
PROCEDURE hbnjer
 PARAMETER BPZH
 SEEK BPZH
 IF EOF()
    RETURN 0
 ELSE 
    RETURN FBNJER
 ENDIF 
ENDPROC
*------
PROCEDURE hbnjec
 PARAMETER BPZH
 SEEK BPZH
 IF EOF()
    RETURN 0
 ELSE 
    RETURN FBNJEC
 ENDIF 
ENDPROC
*------
PROCEDURE hbjjer
 PARAMETER BPZH
 SEEK BPZH
 IF EOF()
    RETURN 0
 ELSE 
    RETURN FBJJER
 ENDIF 
ENDPROC
*------
PROCEDURE hbjjec
 PARAMETER BPZH
 SEEK BPZH
 IF EOF()
    RETURN 0
 ELSE 
    RETURN FBJJEC
 ENDIF 
ENDPROC
*------
PROCEDURE hbyjer
 PARAMETER BPZH
 SEEK BPZH
 IF EOF()
    RETURN 0
 ELSE 
    RETURN FJER
 ENDIF 
ENDPROC
*------
PROCEDURE hbyjec
 PARAMETER BPZH
 SEEK BPZH
 IF EOF()
    RETURN 0
 ELSE 
    RETURN FJEC
 ENDIF 
ENDPROC
*------
PROCEDURE hncyer
 PARAMETER BPZH
 SEEK BPZH
 IF EOF()
    RETURN 0
 ELSE 
    RETURN FNCYE
 ENDIF 
ENDPROC
*------
PROCEDURE hncyec
 PARAMETER BPZH
 SEEK BPZH
 IF EOF()
    RETURN 0
 ELSE 
    RETURN -FNCYE
 ENDIF 
ENDPROC
*------
PROCEDURE hycyer
 PARAMETER BPZH
 SEEK BPZH
 IF EOF()
    RETURN 0
 ELSE 
    RETURN FYCYE
 ENDIF 
ENDPROC
*------
PROCEDURE hycyec
 PARAMETER BPZH
 SEEK BPZH
 IF EOF()
    RETURN 0
 ELSE 
    RETURN -FYCYE
 ENDIF 
ENDPROC
*------
PROCEDURE hyer
 PARAMETER BPZH
 SEEK BPZH
 IF EOF()
    RETURN 0
 ELSE 
    RETURN FYE
 ENDIF 
ENDPROC
*------
PROCEDURE hyec
 PARAMETER BPZH
 SEEK BPZH
 IF EOF()
    RETURN 0
 ELSE 
    RETURN -FYE
 ENDIF 
ENDPROC
*------
PROCEDURE hdxyer
 PARAMETER BPZH0 , BPZH1
 LLL = LEN(ALLTRIM(BPZH0))
 SUM FOR FBSH >= BPZH0 AND FBSH <= BPZH1 AND LEN(ALLTRIM(FBSH)) = LLL TO BYE FYE
 RETURN BYE
ENDPROC
*------
PROCEDURE hdxyec
 PARAMETER BPZH0 , BPZH1
 LLL = LEN(ALLTRIM(BPZH0))
 SUM FOR FBSH >= BPZH0 AND FBSH <= BPZH1 AND LEN(ALLTRIM(FBSH)) = LLL TO BYE FYE
 RETURN -BYE
ENDPROC
*------
PROCEDURE hdxncyer
 PARAMETER BPZH0 , BPZH1
 LLL = LEN(ALLTRIM(BPZH0))
 SUM FOR FBSH >= BPZH0 AND FBSH <= BPZH1 AND LEN(ALLTRIM(FBSH)) = LLL TO BNCYE FNCYE
 RETURN BNCYE
ENDPROC
*------
PROCEDURE hdxncyec
 PARAMETER BPZH0 , BPZH1
 LLL = LEN(ALLTRIM(BPZH0))
 SUM FOR FBSH >= BPZH0 AND FBSH <= BPZH1 AND LEN(ALLTRIM(FBSH)) = LLL TO BNCYE FNCYE
 RETURN -BNCYE
ENDPROC
*------
PROCEDURE hdxycyer
 PARAMETER BPZH0 , BPZH1
 LLL = LEN(ALLTRIM(BPZH0))
 SUM FOR FBSH >= BPZH0 AND FBSH <= BPZH1 AND LEN(ALLTRIM(FBSH)) = LLL TO BYCYE FYCYE
 RETURN BYCYE
ENDPROC
*------
PROCEDURE hdxycyec
 PARAMETER BPZH0 , BPZH1
 LLL = LEN(ALLTRIM(BPZH0))
 SUM FOR FBSH >= BPZH0 AND FBSH <= BPZH1 AND LEN(ALLTRIM(FBSH)) = LLL TO BYCYE FYCYE
 RETURN -BYCYE
ENDPROC
*------
PROCEDURE hdxbnjer
 PARAMETER BPZH0 , BPZH1
 LLL = LEN(ALLTRIM(BPZH0))
 SUM FOR FBSH >= BPZH0 AND FBSH <= BPZH1 AND LEN(ALLTRIM(FBSH)) = LLL TO BBNJER  ;
      FBNJER
 RETURN BBNJER
ENDPROC
*------
PROCEDURE hdxbnjec
 PARAMETER BPZH0 , BPZH1
 LLL = LEN(ALLTRIM(BPZH0))
 SUM FOR FBSH >= BPZH0 AND FBSH <= BPZH1 AND LEN(ALLTRIM(FBSH)) = LLL TO BBNJEC  ;
      FBNJEC
 RETURN BBNJEC
ENDPROC
*------
PROCEDURE hdxbyjer
 PARAMETER BPZH0 , BPZH1
 LLL = LEN(ALLTRIM(BPZH0))
 SUM FOR FBSH >= BPZH0 AND FBSH <= BPZH1 AND LEN(ALLTRIM(FBSH)) = LLL TO BJER FJER
 RETURN BJER
ENDPROC
*------
PROCEDURE hdxbyjec
 PARAMETER BPZH0 , BPZH1
 LLL = LEN(ALLTRIM(BPZH0))
 SUM FOR FBSH >= BPZH0 AND FBSH <= BPZH1 AND LEN(ALLTRIM(FBSH)) = LLL TO BJEC FJEC
 RETURN BJEC
ENDPROC
*------
PROCEDURE plock
 PARAMETER BDBFNAME
 = PUSE(BDBFNAME)
 I = 4
 DO WHILE I = 4
    IF FLOCK()
       I = 0
    ELSE 
       I = MESSAGEBOX('数据库被其他用户锁定,是否重试',37,'提示信息')
    ENDIF 
 ENDDO 
 RETURN I
ENDPROC
*------
PROCEDURE pszzh
 PARAMETER BSZ1
 DO CASE 
 CASE BSZ1 = '1'
    RETURN '壹'
 CASE BSZ1 = '2'
    RETURN '贰'
 CASE BSZ1 = '3'
    RETURN '叁'
 CASE BSZ1 = '4'
    RETURN '肆'
 CASE BSZ1 = '5'
    RETURN '伍'
 CASE BSZ1 = '6'
    RETURN '陆'
 CASE BSZ1 = '7'
    RETURN '柒'
 CASE BSZ1 = '8'
    RETURN '捌'
 CASE BSZ1 = '9'
    RETURN '玖'
 CASE BSZ1 = '0'
    RETURN '零'
 OTHERWISE 
    RETURN '零'
 ENDCASE 
ENDPROC
*------
PROCEDURE pdyh
 FOR I = 1 TO 8
    IF USED('kdyh' + ALLTRIM(STR(I,2)))
       RETURN 
    ENDIF 
 ENDFOR 
 B2 = .F.
 FOR I = 1 TO 8
    BBB = BSJWZ + '\kdyh' + ALLTRIM(STR(I,2))
    B1 = BYHSM
    SELECT 0
     use &bbb excl
    IF B1 = BYHSM
       IF B2
          USE 
       ENDIF 
       B2 = .T.
    ENDIF 
    IF BYHSM = BYHSM0
       IF BYHSM0 = 1
          = MESSAGEBOX('单机版软件，不得多人同时操作！',64,'提示信息')
       ELSE 
          = MESSAGEBOX(ALLTRIM(STR(BYHSM)) + '用户版软件，不得超过' + ALLTRIM(STR(BYHSM)) +  ;
         '用户同时操作！',64,'提示信息')
       ENDIF 
       CLOSE DATABASES ALL
       QUIT 
    ENDIF 
 ENDFOR 
 RETURN 
ENDPROC
*------*