main.prg

我自己编写的用VFP的简单进销存程序供大家参考

SET ESCA ON
SET SYSMENU TO
SET TALK OFF
SET ECHO OFF
SET STEP OFF
SET SAFE OFF
SET EXCL OFF
SET DATE TO ANSI
SET CENT ON
SET HOUR TO 24
SET MULT ON
SET DELE ON

LCDEFA=SET('DEFAULT')
LCDEFAULTNOW=JUSTPATH(SYS(16))
IF RIGHT(LCDEFAULTNOW,1)<>'\'
 LCDEFAULTNOW=LCDEFAULTNOW+'\'
ENDI
LLCALLAPP=IIF(TYPE('LCCALLAPP')='C',LCCALLAPP=='CALLAPP',.F.)
IF !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 LABE F12 DO ONESCAPEF12
*SET DEFA TO &LCDEFAULTNOW
_SCREEN.WINDOWSTATE=2
_SCREEN.Caption='商品管理'
_screen.icon='stock.ico'
_SCREEN.AddObject('imgBK','image')&&按程序主界面的大小插入背景图片
_SCREEN.imgBK.Picture = "mainview.gif"
_SCREEN.imgBK.Stretch = 2
_SCREEN.imgBK.Width=_SCREEN.WIDTH
_SCREEN.imgBK.Height = _SCREEN.HEIGHT
_SCREEN.imgBK.VISIBLE=.T.
_SCREEN.REFRESH
ENDI
CLOSE DATA ALL
CLOSE TABLE ALL

PUBLIC USERNAME,SHORTNAME,FULLNAME,ADDR
SELE 0
USEDBFCOMPANY()
M.SHORTNAME=COMPANY.NAME
M.FULLNAME=COMPANY.FULLNAME
M.ADDR=COMPANY.ADDR
USE
USERNAME=''
USEDBFEMPLOYEE()
DO FORM LOGIN NAME FORMLOGIN LINK
USEDBFEMPLOYEE()
USE
IF LEN(ALLT(USERNAME))>0
 _SCREEN.CAPTION='商品管理  操作员：'+USERNAME
 SET SYSM TO DEFA
 DO MAINMENU.MPR
 READ EVENTS
ENDI
SET SYSMENU TO DEFAULT
CLOSE DATA ALL
CLOSE TABLE ALL
IF LLCALLAPP
RETU
ELSE
ON SHUTDOWN
QUIT
ENDI

PROC ONERROR  &&错误处理程序
PARA MERROR, MESS, MESS1, MPROG, MLINENO
DO CASE
 CASE MERROR=0
  WAIT WINDOW '出错信息：数据超出指定范围，需要重新输入。' TIMEOUT 3
  RETU
 CASE MERROR=1707
  WAIT WINDOW '出错信息：找不到 .CDX 索引文件，忽略索引。' TIMEOUT 3
  RETRY
ENDCASE
=AERROR(aErrorArray)
IF TYPE('aErrorArray')='U'
LCERRM1=''
LCERRM2=''
LCERRM3=''
LCERRM4=''
LCERRM5=''
LCERRM6=''
LCERRM7=''
ELSE
LCERRM1=aErrorArray(1)
LCERRM2=aErrorArray(2)
LCERRM3=aErrorArray(3)
LCERRM4=aErrorArray(4)
LCERRM5=aErrorArray(5)
LCERRM6=aErrorArray(6)
LCERRM7=aErrorArray(7)
ENDI
LCERR0='出错程序：'+MPROG+CHR(13)+'出错行号：'+LTRIM(STR(MLINENO))+CHR(13)+'出错代码：'+MESS1+CHR(13)
LCERR1='错误编号：'+ALLT(IIF(TYPE('LCERRM1')='C' AND !ISNULL(LCERRM1),LCERRM1,IIF(TYPE('LCERRM1')='N',STR(LCERRM1),'')))+CHR(13)
LCERR2='错误信息：'+ALLT(IIF(TYPE('LCERRM2')='C' AND !ISNULL(LCERRM2),LCERRM2,IIF(TYPE('LCERRM2')='N',STR(LCERRM2),'')))+CHR(13)
LCERR3='附加信息：'+ALLT(IIF(TYPE('LCERRM3')='C' AND !ISNULL(LCERRM3),LCERRM3,IIF(TYPE('LCERRM3')='N',STR(LCERRM3),'')))+CHR(13)
LCERR4='错误状态：'+ALLT(IIF(TYPE('LCERRM4')='C' AND !ISNULL(LCERRM4),LCERRM4,IIF(TYPE('LCERRM4')='N',STR(LCERRM4),'')))+CHR(13)
LCERR5='触发信息：'+ALLT(IIF(TYPE('LCERRM5')='C' AND !ISNULL(LCERRM5),LCERRM5,IIF(TYPE('LCERRM5')='N',STR(LCERRM5),'')))+CHR(13)
LCERR6='相关标识：'+ALLT(IIF(TYPE('LCERRM6')='C' AND !ISNULL(LCERRM6),LCERRM6,IIF(TYPE('LCERRM6')='N',STR(LCERRM6),'')))+CHR(13)
LCERR7='异常信息：'+ALLT(IIF(TYPE('LCERRM7')='C' AND !ISNULL(LCERRM7),LCERRM7,IIF(TYPE('LCERRM7')='N',STR(LCERRM7),'')))+CHR(13)+SPACE(50)+CHR(13)
ERRMSG=MESSAGEBOX(LCERR0+LCERR1+LCERR2+LCERR3+LCERR4+LCERR5+LCERR6+LCERR7;
+'是否要终止？  (建议终止本程序并与程序设计或数据管理人员联系)    ',2+48,'出错信息')
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 REALQUIT
ENDCASE
RETU

PROC REALQUIT  &&退出
CLEAR WINDOWS ALL
CLOSE ALTE ALL
CLOSE DATA ALL
CLOSE FORMAT ALL
CLOSE INDE ALL
CLOSE TABLES ALL
CLEAR READ ALL
CLEAR EVENTS
SET SYSM TO DEFA
IF LLCALLAPP
RETU
ELSE
ON SHUTDOWN
QUIT
ENDI

PROC ONSHUTD  &&退出处理程序
IF MESSAGEBOX("是否要退出本系统?    ",32+1,"退出")=1
DO REALQUIT
ENDI

PROC ONESCAPE  &&按ESC键处理程序
=MESSAGEBOX("ESCAPE键中止！    ",4+48,"中止")
DO ONSHUTD
RETU

PROC ONESCAPEF12  &&按F12键处理程序
=MESSAGEBOX("F12 键中止！    ",4+48,"中止")
DO ONSHUTD
RETU