bg.prg

使用VFP编写的信用社系统专用会计报表系统,可上报,汇总,打印.是一款优秀的信用社会计报表系统

 CASE SUBSTR(CCC(1),XX,2) = '│'
 DO CASE 
 CASE XX = XQ
 TX = '├'
 CASE XX = XZ
 TX = '┤'
 OTHERWISE 
 TX = '┼'
 ENDCASE 
 CASE SUBSTR(CCC(1),XX,2) $ '├┤'
 TX = '┼'
 CASE SUBSTR(CCC(1),XX,2) $ '├┤┬┴┼'
 TX = SUBSTR(CCC(1),XX,2)
 CASE SUBSTR(CCC(1),XX,2) $ '┌┐'
 TX = '┬'
 CASE SUBSTR(CCC(1),XX,2) $ '└┘'
 TX = '┴'
 ENDCASE 
 CASE TX = '│'
 DO CASE 
 CASE SUBSTR(CCC(1),XX,2) = '─'
 ZB = 'pp'
 YB = 'pp'
 IF XX < 236
 YB = SUBSTR(CCC(1),XX + 2,2)
 ENDIF 
 IF XX > 2
 ZB = SUBSTR(CCC(1),XX - 2,2)
 ENDIF 
 DO CASE 
 CASE YY = YQ
 TX = '┬'
 CASE YY = YZ
 TX = '┴'
 OTHERWISE 
 DO CASE 
 CASE ZB = '  '
 TX = '├'
 CASE YB = '  '
 TX = '┤'
 OTHERWISE 
 TX = '┼'
 ENDCASE 
 ENDCASE 
 CASE SUBSTR(CCC(1),XX,2) $ '┬┴'
 TX = '┼'
 CASE SUBSTR(CCC(1),XX,2) $ '├┤┤┼'
 TX = SUBSTR(CCC(1),XX,2)
 CASE SUBSTR(CCC(1),XX,2) $ '┌└'
 TX = '├'
 CASE SUBSTR(CCC(1),XX,2) $ '┐┘'
 TX = '┤'
 ENDCASE 
 CASE TX = '┌'
 DO CASE 
 CASE SUBSTR(CCC(1),XX,2) $ '│└├'
 TX = '├'
 CASE SUBSTR(CCC(1),XX,2) $ '─┐┬'
 TX = '┬'
 CASE SUBSTR(CCC(1),XX,2) $ '┘┴┤┼'
 TX = '┼'
 ENDCASE 
 CASE TX = '┐'
 DO CASE 
 CASE SUBSTR(CCC(1),XX,2) $ '│┘┤'
 TX = '┤'
 CASE SUBSTR(CCC(1),XX,2) $ '─┌┬'
 TX = '┬'
 CASE SUBSTR(CCC(1),XX,2) $ '└┼├┴'
 TX = '┼'
 ENDCASE 
 CASE TX = '└'
 DO CASE 
 CASE SUBSTR(CCC(1),XX,2) $ '│┌├'
 TX = '├'
 CASE SUBSTR(CCC(1),XX,2) $ '─┘┴'
 TX = '┴'
 CASE SUBSTR(CCC(1),XX,2) $ '┐┼┬┤'
 TX = '┼'
 ENDCASE 
 CASE TX = '┘'
 DO CASE 
 CASE SUBSTR(CCC(1),XX,2) $ '│┐┤'
 TX = '┤'
 CASE SUBSTR(CCC(1),XX,2) $ '─└┴'
 TX = '┴'
 CASE SUBSTR(CCC(1),XX,2) $ '┌┼├┬'
 TX = '┼'
 ENDCASE 
 ENDCASE 
 DO BXGX
 RETURN 
ENDPROC
*------
PROCEDURE shx
 GATHER FROM CCC
 PRIVATE XX
 XX = XQ
 DO WHILE XX <= XZ
 DO CASE 
 CASE SUBSTR(CCC(1),XX,2) $ '┼' AND XX = XZ
 TX = '├'
 CASE SUBSTR(CCC(1),XX,2) $ '┼' AND XX = XQ
 TX = '┤'
 CASE SUBSTR(CCC(1),XX,2) $ '┼├┤│'
 TX = '│'
 OTHERWISE 
 TX = '  '
 ENDCASE 
 DO BXGX
 XX = XX + 2
 ENDDO 
 @ Y + 2 , 1 SAY SUBSTR(CCC(1),X0,76)
 GATHER FROM CCC
 RETURN 
ENDPROC
*------
PROCEDURE ssx
 PRIVATE YY , XX , OJL
 XX = XQ
 YY = YQ
 OJL = RECNO()
 GO YY
 DO WHILE YY <= YZ
 SCATTER TO CCC
 DO CASE 
 CASE SUBSTR(CCC(1),XX,2) $ '┼' AND YY = YZ
 TX = '┬'
 CASE SUBSTR(CCC(1),XX,2) $ '┼' AND YY = YQ
 TX = '┴'
 CASE SUBSTR(CCC(1),XX,2) $ '┼┬┴─'
 TX = '─'
 OTHERWISE 
 TX = '  '
 ENDCASE 
 DO BXGX
 IF YY - Y0 + 1 >= 0 AND YY - Y0 + 1 < 19
 @ YY - Y0 + 3 , 1 SAY TRIM(SUBSTR(CCC(1),X0,76))
 ENDIF 
 GATHER FROM CCC
 YY = YY + 1
 SKIP 
 ENDDO 
 GO OJL
 SCATTER TO CCC
 RETURN 
ENDPROC
*------
PROCEDURE bxgx
 PRIVATE ZF
 ZF = SUBSTR(CCC(1),XX,2)
 DO CASE 
 CASE '&' $ ZF
 CASE ASC(ZF) > 160
 CCC( 1 ) = STUFF(CCC(1),XX,2,TX)
 CASE ASC(ZF) < 160 AND ASC(RIGHT(ZF,1)) < 160
 CCC( 1 ) = STUFF(CCC(1),XX,2,TX)
 CASE ASC(ZF) < 160 AND ASC(RIGHT(ZF,1)) > 160
 CCC( 1 ) = STUFF(CCC(1),XX,3,TX + ' ')
 ENDCASE 
 RETURN 
ENDPROC
*------
PROCEDURE scyh
 IF RECNO() < YT .OR. YT = 0
 DELETE 
 PACK 
 APPEND BLANK
 GO RECC
 SCATTER TO CCC
 DO XSCK
 SELECT 10
 IF YT <> 0
 REPLACE WZ WITH WZ - 1
 YT = YT - 1
 ENDIF 
 SELECT 5
 ENDIF 
 RETURN 
ENDPROC
*------
PROCEDURE cryh
 IF RECNO() <= YT .OR. YT = 0
 PRIVATE XX , YY
 DO CASE 
 CASE RECNO() <= OXHT
 OXHT = OXHT + 1
 OXHW = OXHW + 1
 CASE RECNO() > OXHT AND RECNO() <= OXHW
 OXHW = OXHW + 1
 ENDCASE 
 YY = Y + Y0 - 1
 INSERT BLANK BEFORE 
 XX = 1
 DO WHILE XX < 240
 IF SUBSTR(CCC(1),XX,2) $ '│ └ ┘├ ┤ ┴ ┼'
 REPLACE P WITH STUFF(P,XX,2,'│')
 ENDIF 
 XX = XX + 2
 ENDDO 
 SELECT 5
 GDK = STR(Y + 2,2) + '012077U'
 YS = IIF(Y0 + Y - 1 >= OXHT .AND. Y0 + Y - 1 <= OXHW,'0/3,,','w/1,,')
 @ Y + 2 , 1 SAY TRIM(SUBSTR(P,X0,76))
 SCATTER TO CCC
 DO XSCK
 IF YT <> 0
 SELECT 10
 REPLACE WZ WITH WZ + 1
 YT = YT + 1
 SELECT 5
 ENDIF 
 ENDIF 
 RETURN 
ENDPROC
*------
PROCEDURE czbx
 PRIVATE XX , ZF
 XX = X + X0
 IF CHR(169) $ RIGHT(CCC(1),241 - XX)
 DO WHILE XX < 238
 ZF = SUBSTR(CCC(1),XX,1)
 DO CASE 
 CASE ZF = CHR(169)
 OBXWZ = XX
 EXIT 
 CASE ZF > CHR(160)
 XX = XX + 2
 CASE ZF < CHR(161)
 XX = XX + 1
 ENDCASE 
 ENDDO 
 ELSE 
 OBXWZ = LEN(TRIM(CCC(1))) + 2
 OBXWZ = IIF(OBXWZ < XX + 2,XX + 2,OBXWZ)
 ENDIF 
 RETURN 
ENDPROC
*------
PROCEDURE xbh
 XBH = IIF(XBH = 0,1,0)
 @ 1 , 55 SAY IIF(XBH = 1,'线保护','      ')
 RETURN 
ENDPROC
*------
PROCEDURE sbdw
 PRIVATE K
 IF MOD(X,2) > 0
 @ 1 , 54 SAY '删线定位列坐标必须是奇数'
 K = INKEY(2)
 @ 1 , 54 SAY '                        '
 RETURN 
 ENDIF 
 IF SX = 0
 XQ = X0 + X
 YQ = Y0 + Y - 1
 SX0 = SUBSTR(CCC(1),X0 + X,2)
 @ YQ - Y0 + 3 , XQ - X0 + 1 SAY SX0
 SX = 1
 @ 1 , 54 SAY '删表首坐标行:    列:'
 @ 1 , 67 SAY YQ PICTURE '@b 999'
 @ 1 , 74 SAY XQ PICTURE '@b 999'
 ELSE 
 XZ = X0 + X
 YZ = Y0 + Y - 1
 IF XZ < XQ
 SWAP = XZ
 XZ = XQ
 XQ = SWAP
 ENDIF 
 IF YZ < YQ
 SWAP = YZ
 YZ = YQ
 YQ = SWAP
 ENDIF 
 IF XQ = XZ
 DO SSX
 SX = 0
 ENDIF 
 IF YQ = YZ
 DO SHX
 SX = 0
 ENDIF 
 IF SX = 0
 @ 1 , 54 SAY '                        '
 ENDIF 
 ENDIF 
 RETURN 
ENDPROC
*------
PROCEDURE cryl
 PRIVATE XCR , OJL , ZW
 XCR = X
 GATHER FROM CCC
 OJL = RECNO()
 GO 1
 DO WHILE  .NOT. EOF()
 IF LEN(TRIM(P)) = 0
 EXIT 
 ENDIF 
 SCATTER TO CCC
 X = XCR
 DO HZCL
 ZF = SUBSTR(CCC(1),X + X0,2)
 IF ZF $ '┐┘┬┴┼─┤'
 ZW = '─'
 ELSE 
 ZW = '  '
 ENDIF 
 CCC( 1 ) = STUFF(CCC(1),X0 + X,0,ZW)
 IF ASC(RIGHT(CCC(1),1)) < 160 AND ASC(RIGHT(CCC(1),2)) > 160
 CCC( 1 ) = LEFT(CCC(1),239) + ' '
 ELSE 
 CCC( 1 ) = LEFT(CCC(1),240)
 ENDIF 
 GATHER FROM CCC
 SKIP 
 ENDDO 
 GO OJL
 SCATTER TO CCC
 XSY = Y
 DO XSCK
 X = XCR
 RETURN 
ENDPROC
*------
PROCEDURE scyl
 PRIVATE XCR , OJL , ZW
 XCR = X
 GATHER FROM CCC
 OJL = RECNO()
 GO 1
 DO WHILE  .NOT. EOF()
 IF LEN(TRIM(P)) = 0
 EXIT 
 ENDIF 
 SCATTER TO CCC
 X = XCR
 ZF = SUBSTR(CCC(1),X + X0,1)
 IF ASC(ZF) = 38
 X = X + 1
 ENDIF 
 DO HZCL
 ZF = SUBSTR(CCC(1),X + X0,2)
 IF  .NOT. CHR(38) $ ZF
 DO CASE 
 CASE ASC(ZF) > 160
 CCC( 1 ) = STUFF(CCC(1),X0 + X,2,'') + '  '
 CASE ASC(RIGHT(ZF,1)) < 160 AND ASC(ZF) < 160
 CCC( 1 ) = STUFF(CCC(1),X0 + X,2,'') + '  '
 CASE ASC(RIGHT(ZF,1)) > 160 AND ASC(ZF) < 160
 CCC( 1 ) = STUFF(CCC(1),X0 + X,3,' ') + '  '
 ENDCASE 
 ENDIF 
 GATHER FROM CCC
 SKIP 
 ENDDO 
 GO OJL
 XSY = Y
 DO XSCK
 SCATTER TO CCC
 X = XCR
 RETURN 
ENDPROC
*------
PROCEDURE ZBDW
 PRIVATE K
 IF MOD(X,2) > 0
 @ 1 , 54 SAY '制表定位列坐标必须是奇数'
 K = INKEY(2)
 @ 1 , 54 SAY '                        '
 RETURN 
 ENDIF 
 IF HX = 0
 XQ = X0 + X
 YQ = Y0 + Y - 1
 HX0 = SUBSTR(CCC(1),X0 + X,2)
 @ YQ - Y0 + 3 , XQ - X0 + 1 SAY HX0
 HX = 1
 @ 1 , 54 SAY '制表首坐标行:    列:'
 @ 1 , 67 SAY YQ PICTURE '@b 999'
 @ 1 , 74 SAY XQ PICTURE '@b 999'
 ELSE 
 XZ = X0 + X
 YZ = Y0 + Y - 1
 IF XZ < XQ
 SWAP = XZ
 XZ = XQ
 XQ = SWAP
 ENDIF 
 IF YZ < YQ
 SWAP = YZ
 YZ = YQ
 YQ = SWAP
 ENDIF 
 DO ZDHX
 HX = 0
 @ 1 , 54 SAY '                        '
 ENDIF 
 RETURN 
ENDPROC
*------
PROCEDURE xsck
 PRIVATE OI , OL , YS
 XSY = IIF(XSY < 1,1,XSY)
 OI = 1
 SELECT 5
 OL = RECNO()
 GO 1
 SCAN 
 @ OI + 2 , 1 SAY SPACE(76)
 @ OI + 2 , 1 SAY TRIM(SUBSTR(P,X0,76))
 OI = OI + 1
 ENDSCAN 
 GO OL
 IF (SX = 1 .OR. HX = 1) AND YQ - Y0 + 1 > 0 AND YQ - Y0 + 1 < 21 AND XQ - X0 > -1 AND  ;
XQ - X0 < 80
 IF HX = 1
 @ YQ - Y0 + 3 , XQ - X0 + 2 SAY HX0
 ELSE 
 @ YQ - Y0 + 3 , XQ - X0 + 2 SAY SX0
 ENDIF 
 ENDIF 
 XSY = 1
 RETURN 
ENDPROC
*------
PROCEDURE LRZD
 SELECT 10
  USE lib\&bbm.T1.dat
 LOCATE FOR BH = SS
 IF FOUND()
 YT = WZ
 ELSE 
 APPEND BLANK
 REPLACE BH WITH SS
 ENDIF 
 SELECT 5
 EDED = RECNO()
 CISHU = OCCURS('│',CCC(1))
 IF CISHU = 0
 RETURN 
 ENDIF 
 IF YT > 0 AND RECNO() <> YT
 RETURN 
 ENDIF 
 IF OCCURS(' ',CCC(1)) < LEN(CCC(1)) - CISHU * 2 AND YT = 0
 @ 10 , 20 SAY '该行中还有其他字符,不能做表体'
 RETURN 
 ENDIF 
 SELECT 10
 REPLACE WZ WITH EDED
 DO LRBT
 SELECT 6
  USE lib\&bbm.T2.dat
 DO GBTY
 SELECT 10
 DO XZZD
 SELECT 5
 SELECT 9
 DO LRBT
 USE 
 SELECT 5
 RETURN 
ENDPROC
*------
PROCEDURE LRBT
 SELECT 6
  USE lib\&bbm.T2.dat
 DELETE FOR BH = SS
 PACK 
 FOR CICI = 1 TO CISHU
 APPEND BLANK
 REPLACE BH WITH SS
 CACA = AT('│',CCC(1),CICI)
 REPLACE CHANGDU WITH CACA
 ZDZD = ALLTRIM(SUBSTR(CCC(1),CACA + 2,10))
 ACAC = AT('│',ZDZD)
 IF ACAC > 0
 ZDZD = LEFT(ZDZD,ACAC - 1)
 ENDIF 
 ZDZD = ALLTRIM(ZDZD)
 REPLACE ZDMC WITH ZDZD
 ENDFOR 
ENDPROC
*------
PROCEDURE XZZD
 DIMENSION BBB( 20 )
 SELECT 10
 USE lib\BLK.dat
 COUNT FOR BH = SS TO CK
 DEFINE WINDOW YXL1 FROM 4 , 10 TO 6 + CK , 51 SHADOW TITLE '请选择字段名称：' DOUBLE
 ACTIVATE WINDOW YXL1
 DX = 0
 N = 1
 Z = '.'
 SCAN FOR BH = SS
 NN = LTRIM(STR(N)) - Z
 @ DX , 1 PROMPT NN + FIELD_NAME + '  ' + LHY
 BBB( N ) = FIELD_NAME
 DX = DX + 1
 N = N + 1
 ENDSCAN 
 BBB( N ) = 'xmmc'
 NN = LTRIM(STR(N)) - Z
 @ DX , 1 PROMPT NN + 'XMMC      ' + '  ' + '项目名称'
 MENU TO ZDXZ
 IF ZDXZ = 0
 DEACTIVATE WINDOW YXL1
 RETURN 
 ENDIF 
 SELECT 6
 ZUO = CHANGDU
 SKIP 
 YOU = CHANGDU
 SKIP -1
 SELECT 10
 ZDMM = ALLTRIM(BBB(ZDXZ))
 DEACTIVATE WINDOW YXL1
 ZDMM = ZDMM + SPACE(YOU - ZUO - LEN(ZDMM) - 2)
 SELECT 5
 @ Y + 2 , X + 1 SAY ZDMM
 CCC( 1 ) = STUFF(CCC(1),X0 + X,LEN(ZDMM),ZDMM)
 RETURN 
ENDPROC
*------
PROCEDURE GBTY
 SELECT 6
  USE lib\&bbm.T2.dat
 SCAN FOR BH = SS
 IF X0 + X <= CHANGDU
 IF  .NOT. RECNO() = 1
 SKIP -1
 ENDIF 
 X = CHANGDU - X0 + 2
 IF X < 0 AND X0 > 38
 X = 0
 X0 = X0 - 38
 ENDIF 
 EXIT 
 ENDIF 
 ENDSCAN 
 SELECT 5
ENDPROC
*------*