bg.prg

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

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


 SET TALK OFF
 SET CONSOLE OFF
 SET EXACT ON
 SET SAFETY OFF
 IF 1 = 0
 SET DEFAULT TO \xbbjs
 MMBZ4 = '4'
 NIAN = '1998'
 YUE = '12'
 ENDIF 
 SET TALK OFF
 SET  ???SET[9A] OFF
 SET ESCAPE ON
 SET SAFETY OFF
 SET COLOR OF SCHEME 3 TO RGB( 0 , 0 , 0 , 192 , 192 , 192) 
 DEFINE WINDOW W1 FROM 5 , 18 TO 20 , 60 DOUBLE
 DO WHILE .T.
 M_BH = '00'
 DO FORM .\src\form\gong2
 SS = M_BH
 IF M_BH = '00'
 RETURN 
 ENDIF 
 USE LIB\BZL.DAT
 LOCATE FOR BH = SS
 M_BM = BM
 SELECT 10
  USE LIB\XM&SS..DAT
 LOCATE FOR LEFT(XMDH,1) = 'b'
 IF EOF()
 BBM = 'b'
 ELSE 
 BJ = 1
 Q_QUIT = .F.
 DO FORM src\form\bgxz
 IF Q_QUIT
 LOOP 
 ENDIF 
 IF BJ = 1
 BBM = 'B'
 ELSE 
 BBM = 'BB'
 ENDIF 
 ENDIF 
 DO BGZC
 ENDDO 

PROCEDURE bgzc
 PRIVATE X , Y , K , X0 , Y0 , CCC( 2 ) , ZW , CR , HX , XQ , YQ , XZ , YZ , SWAP , SX ,  ;
      DHXS , XBH , XSY , SX0
 PRIVATE T , W , OBXWZ , OXHT , OXHW , YS , C , U , N , D , HX0
 PRIVATE YT
 YT = 0
 SELECT 10
  USE lib\&bbm.T1.dat
 LOCATE FOR BH = SS
 IF FOUND()
 YT = WZ
 ENDIF 
 SELECT 5
 DIMENSION CCC( 2 )
 HX0 = ''
 SX0 = ''
 SET DOHISTORY OFF
 C = '字符型'
 N = '数值型'
 D = '日期型'
 U = '运算符'
 XSY = 1
 YS = 'w/1,,'
 OXHT = 81
 OXHW = 0
 OBXWZ = 239
 XBH = 1
 SX = 0
 HX = 0
 CR = 1
 ZW = ''
 X = 0
 Y = 1
 X0 = 1
 Y0 = 1
 XZ = 0
 XQ = 0
 YZ = 0
 YQ = 0
 IF BBM == 'b' .OR. BBM == 'B'
 BDTS = ALLTRIM(M_BM) + '格式编辑'
 ELSE 
 BDTS = ALLTRIM(M_BM) + '补充资料格式编辑'
 ENDIF 
 BDTS1 = '行:    列:     修改      线保护'
 DHXS =  ;
      'F1:帮助 F2:保护 F3:制表 F4:删表 F5:表体 F6:删行 F7:删列:F9:插行 F10:插列 '
 DEFINE WINDOW YXL10 FROM 2 , 5 TO 30 , 90 COLOR SCHEME 3 DOUBLE
 MOVE WINDOW YXL10 CENTER 
 ACTIVATE WINDOW YXL10
 CLEAR 
 @ 1 , 2 SAY BDTS
 @ 1 , 30 SAY BDTS1
 @ 2 , 0 SAY REPLICATE('━',39)
 @ 22 , 0 SAY DHXS
 @ 21 , 0 SAY REPLICATE('━',39)
 SELECT 5
  IF files("lib\&bbm&ss..dat")
  use lib\&bbm&ss..dat alia e
 ELSE 
  use lib\&bbm.04.dat alia e
  copy stru to lib\&bbm&ss..dat
  use lib\&bbm&ss..dat alia e
 FOR XHK = 1 TO 18
 APPEND BLANK
 ENDFOR 
 ENDIF 
 DELETE FOR RECNO() > 18
 PACK 
 JL = 1
 SCAN 
 @ Y0 + JL + 1 , 1 SAY SUBSTR(P,1,76)
 JL = JL + 1
 ENDSCAN 
 FLAG = 0
 DO WHILE .T.
 IF EOF()
 FLAG = 1
 GO BOTTOM
 ELSE 
 IF FLAG = 1
 FLAG = 0
 GO BOTTOM
 ELSE 
 GO Y + Y0 - 1
 ENDIF 
 ENDIF 
 RECC = Y + Y0 - 1
 SCATTER TO CCC
 @ 1 , 32 SAY Y + Y0 - 1 PICTURE '@b 999'
 @ 1 , 39 SAY X + X0 PICTURE '@b 999'
 @ Y + 2 , X + 1 SAY ''
 K = INKEY(0)
 K = IIF(K = 39,34,K)
 DO CASE 
 CASE K = 4
 DO K4
 CASE K = 19
 DO K19
 CASE K = 24
 DO K24
 CASE K = 5
 DO K5
 CASE K = 1
 X = 0
 DO HZCL
 CASE K = 6
 X = 75
 DO HZCL
 CASE K = 13
 IF SUBSTR(CCC(1),X0 + X,1) = '&'
 KEYBOARD '&'
 LOOP 
 ENDIF 
 CASE K = -6
 DO SCYL
 CASE K > 31 AND K < 127
 IF YT <> RECNO()
 IF CR = 1
 DO SRYW
 ELSE 
 DO SRYWC
 ENDIF 
 ENDIF 
 CASE K > 160
 IF YT <> RECNO()
 IF CR = 1
 DO SRZW
 ELSE 
 DO SRZWC
 ENDIF 
 ENDIF 
 CASE K = 27
 CLOSE DATABASES 
 DEACTIVATE WINDOW YXL10
 DEACTIVATE WINDOW W1
 RELEASE WINDOW YXL10 , W1
 RETURN 
 CASE K = 22
 DO K22
 CASE K = 7
 DO K7
 CASE K = 18
 DO K18
 CASE K = 3
 DO K3
 CASE K = 9
 DO K4
 DO K4
 DO K4
 DO K4
 DO K4
 CASE K = 15
 DO K19
 DO K19
 DO K19
 DO K19
 DO K19
 CASE (K = -2 .OR. K = 146) AND SX = 0
 DO ZBDW
 CASE (K = 147 .OR. K = -3) AND HX = 0
 DO SBDW
 CASE K = -5
 DO SCYH
 CASE K = -8
 DO CRYH
 CASE K = -1
 DO XBH
 CASE K = -4
 DO LRZD
 CASE K = -9 .OR. K = 10
 DO CRYL
 CASE K = 28
 CASE K = 127
 DO K19
 DO K7
 ENDCASE 
 IF  .NOT. EOF()
 GATHER FROM CCC
 ENDIF 
 ENDDO 
 DEACTIVATE WINDOW YXL10
 RELEASE WINDOW YXL10
 CLOSE PROCEDURE 
 RETURN 
ENDPROC
*------
PROCEDURE xsxh
 PRIVATE OI , OL
 OI = 1
 SELECT 5
 OL = RECNO()
 GO Y0
 SKIP OI - 1
 DO WHILE OI < 19
 @ OI + 2 , 1 SAY B
 SKIP 
 OI = OI + 1
 ENDDO 
 GO OL
 SCATTER TO CCC
 XSY = 1
 RETURN 
ENDPROC
*------
PROCEDURE k4
 IF SUBSTR(CCC(1),X0 + X,1) > CHR(160)
 X = X + 2
 ELSE 
 X = X + 1
 ENDIF 
 IF X > 75 AND X0 < 160
 X0 = X0 + 38
 GATHER FROM CCC
 DO XSCK
 X = 38
 ENDIF 
 X = IIF(X > 75,75,X)
 RETURN 
ENDPROC
*------
PROCEDURE k19
 X = X - 1
 IF ASC(SUBSTR(CCC(1),X0 + X,1)) > 160
 X = X - 1
 ENDIF 
 IF X < 0 AND X0 > 38
 X = 0
 X0 = X0 - 38
 GATHER FROM CCC
 DO XSCK
 ENDIF 
 X = IIF(X < 0,0,X)
 RETURN 
ENDPROC
*------
PROCEDURE k24
 IF Y < 18
 Y = Y + 1
 GATHER FROM CCC
 SKIP 
 SCATTER TO CCC
 DO HZCL
 ENDIF 
 RETURN 
ENDPROC
*------
PROCEDURE k5
 IF Y > 1
 Y = Y - 1
 GATHER FROM CCC
 SKIP -1
 SCATTER TO CCC
 DO HZCL
 ELSE 
 ENDIF 
 RETURN 
ENDPROC
*------
PROCEDURE k22
 CR = IIF(CR = 1,0,1)
 @ 1 , 45 SAY IIF(CR = 1,'修改','插入')
 RETURN 
ENDPROC
*------
PROCEDURE sryw
 IF (SUBSTR(CCC(1),X0 + X,1) <> '&' .OR. K = 38) AND  ;
(SUBSTR(CCC(1),X0 + X,1) <> CHR(169) .OR. XBH = 0)
 IF SUBSTR(CCC(1),X0 + X,1) > CHR(160)
 CCC( 1 ) = STUFF(CCC(1),X0 + X,2,CHR(K) + ' ')
 @ Y + 2 , X + 1 SAY CHR(K) + ' '
 ELSE 
 CCC( 1 ) = STUFF(CCC(1),X0 + X,1,CHR(K))
 @ Y + 2 , X + 1 SAY CHR(K)
 ENDIF 
 ENDIF 
 DO K4
 ZW = ''
 RETURN 
ENDPROC
*------
PROCEDURE srywc
 PRIVATE C0
 IF XBH = 0
 CCC( 1 ) = STUFF(CCC(1),X0 + X,0,CHR(K))
 IF RIGHT(CCC(1),1) < CHR(160)
 CCC( 1 ) = LEFT(CCC(1),240)
 ELSE 
 CCC( 1 ) = LEFT(CCC(1),239) + ' '
 ENDIF 
 ELSE 
 DO CZBX
 C0 = LEFT(CCC(1),OBXWZ - 1)
 IF RIGHT(C0,1) <> CHR(38)
 C0 = STUFF(C0,X0 + X,0,CHR(K))
 IF ASC(RIGHT(C0,1)) < 160
 C0 = LEFT(C0,OBXWZ - 1)
 ELSE 
 C0 = LEFT(C0,OBXWZ - 2) + ' '
 ENDIF 
 CCC( 1 ) = C0 + RIGHT(CCC(1),LEN(CCC(1)) - OBXWZ + 1)
 ENDIF 
 ENDIF 
 @ Y + 2 , X + 1 SAY TRIM(SUBSTR(CCC(1),X0 + X,76 - X))
 DO K4
 ZW = ''
 RETURN 
ENDPROC
*------
PROCEDURE srzw
 PRIVATE ZF1 , ZF2
 IF LEN(ZW) = 0
 ZW = CHR(K)
 RETURN 
 ENDIF 
 ZF1 = SUBSTR(CCC(1),X0 + X,1)
 ZF2 = SUBSTR(CCC(1),X0 + X + 1,1)
 DO CASE 
 CASE ZF1 > CHR(160) AND (ZF1 <> CHR(169) .OR. XBH = 0)
 CCC( 1 ) = STUFF(CCC(1),X0 + X,2,ZW + CHR(K))
 @ Y + 2 , X + 1 SAY ZW + CHR(K)
 CASE ZF1 < CHR(160) AND ZF2 < CHR(160) AND (ZF1 <> CHR(169) .OR. XBH = 0) AND ZF1 <> '&' AND  ;
ZF2 <> '&'
 CCC( 1 ) = STUFF(CCC(1),X0 + X,2,ZW + CHR(K))
 @ Y + 2 , X + 1 SAY ZW + CHR(K)
 CASE ZF1 < CHR(160) AND ZF2 > CHR(160) AND (ZF2 <> CHR(169) .OR. XBH = 0) AND ZF1 <> '&'
 CCC( 1 ) = STUFF(CCC(1),X0 + X,3,ZW + CHR(K) + ' ')
 @ Y + 2 , X + 1 SAY ZW + CHR(K) + ' '
 ENDCASE 
 ZW = ''
 DO K4
 RETURN 
ENDPROC
*------
PROCEDURE srzwc
 PRIVATE C0
 IF LEN(ZW) = 0
 ZW = CHR(K)
 RETURN 
 ENDIF 
 IF XBH = 0
 CCC( 1 ) = STUFF(CCC(1),X0 + X,0,ZW + CHR(K))
 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 
 ELSE 
 DO CZBX
 C0 = LEFT(CCC(1),OBXWZ - 1)
 IF  .NOT. CHR(38) $ RIGHT(C0,2)
 C0 = STUFF(C0,X0 + X,0,ZW + CHR(K))
 IF ASC(RIGHT(C0,1)) < 160 AND ASC(RIGHT(C0,2)) > 160
 C0 = LEFT(C0,OBXWZ - 2) + ' '
 ELSE 
 C0 = LEFT(C0,OBXWZ - 1)
 ENDIF 
 CCC( 1 ) = C0 + RIGHT(CCC(1),LEN(CCC(1)) - OBXWZ + 1)
 ENDIF 
 ENDIF 
 @ Y + 2 , X + 1 SAY TRIM(SUBSTR(CCC(1),X0 + X,76 - X))
 ZW = ''
 DO K4
 RETURN 
ENDPROC
*------
PROCEDURE k7
 PRIVATE ZF
 ZF = SUBSTR(CCC(1),X0 + X,1)
 IF ZF <> '&'
 IF XBH = 0
 IF ZF < CHR(160)
 CCC( 1 ) = STUFF(CCC(1),X0 + X,1,'') + ' '
 ELSE 
 CCC( 1 ) = STUFF(CCC(1),X0 + X,2,'') + '  '
 ENDIF 
 ELSE 
 DO CZBX
 IF ZF < CHR(160)
 CCC( 1 ) = STUFF(CCC(1),OBXWZ,0,' ')
 CCC( 1 ) = STUFF(CCC(1),X0 + X,1,'')
 ELSE 
 CCC( 1 ) = STUFF(CCC(1),OBXWZ,0,'  ')
 CCC( 1 ) = STUFF(CCC(1),X0 + X,2,'')
 ENDIF 
 ENDIF 
 ENDIF 
 @ Y + 2 , X + 1 SAY SUBSTR(CCC(1),X0 + X,76 - X)
 ZW = ''
 RETURN 
ENDPROC
*------
PROCEDURE k18
 PRIVATE Y00
 Y00 = Y0
 IF Y0 > 1
 Y0 = Y0 - 9
 GATHER FROM CCC
 Y0 = IIF(Y0 < 1,1,Y0)
 GO Y0
 IF Y < 11
 Y = Y + Y00 - Y0
 ELSE 
 X = 0
 Y = 1
 ENDIF 
 DO XSCK
 GO Y0 + Y - 1
 SCATTER TO CCC
 ENDIF 
 RETURN 
ENDPROC
*------
PROCEDURE k3
 PRIVATE Y00
 Y00 = Y0
 IF Y0 < 62
 Y0 = Y0 + 9
 Y0 = IIF(Y0 > 62,62,Y0)
 GATHER FROM CCC
 GO Y0
 IF Y > 10
 Y = Y + Y00 - Y0
 ELSE 
 X = 0
 Y = 1
 ENDIF 
 DO XSCK
 GO Y0 + Y - 1
 SCATTER TO CCC
 ENDIF 
 RETURN 
ENDPROC
*------
PROCEDURE hzcl
 PRIVATE K , S , Z
 S = X0 + X
 IF ASC(SUBSTR(CCC(1),S,1)) < 160
 RETURN 
 ENDIF 
 K = 1
 Z = 0
 DO WHILE K < S
 Z = IIF(ASC(SUBSTR(CCC(1),K,1)) > 160,Z + 1,Z)
 K = K + 1
 ENDDO 
 X = X - MOD(Z,2)
 RETURN 
ENDPROC
*------
PROCEDURE zdhx
 PRIVATE OJL , XX , TX , YY
 YY = YQ
 OJL = RECNO()
 GO YQ
 DO WHILE YY <= YZ
 SCATTER TO CCC
 XX = XQ
 DO WHILE XX <= XZ
 DO CASE 
 CASE XX > XQ AND XX < XZ AND YY > YQ AND YY < YZ
 XX = XZ
 LOOP 
 CASE (YY = YQ .OR. YY = YZ) AND XX > XQ AND XX < XZ .OR. YQ = YZ
 TX = '─'
 CASE (XX = XQ .OR. XX = XZ) AND YY > YQ AND YY < YZ .OR. XQ = XZ
 TX = '│'
 CASE XX = XQ AND YQ <> YZ AND YY = YQ AND XQ <> XZ
 TX = '┌'
 CASE XX = XZ AND YQ <> YZ AND YY = YQ AND XQ <> XZ
 TX = '┐'
 CASE XX = XQ AND YQ <> YZ AND YY = YZ AND XQ <> XZ
 TX = '└'
 CASE XX = XZ AND YQ <> YZ AND YY = YZ AND XQ <> XZ
 TX = '┘'
 ENDCASE 
 DO TRBX
 XX = XX + 2
 ENDDO 
 IF YY - Y0 + 1 >= 0 AND YY - Y0 + 1 < 21
 @ YY - Y0 + 3 , 1 SAY TRIM(SUBSTR(CCC(1),X0,76))
 ENDIF 
 YY = YY + 1
 GATHER FROM CCC
 SKIP 
 ENDDO 
 GO OJL
 SCATTER TO CCC
 RETURN 
ENDPROC
*------
PROCEDURE trbx
 DO CASE 
 CASE TX = '─'
 DO CASE