编程工具.prg

通用题库组卷系统 1.本来是一个学生的本科毕业课题

    if n_tag=1
      exit
    endif
    n_tag=n_tag-1
    dime m_tmp_dir(n_tag)
  endif
enddo
*rd &c_dir
if DirEctory(c_dir)
  return .f.
endif
return .t.
 
**********************************修改系统日期时间 
FUNCTION setsystime
PARAMETERS updtdate,updtime
DECLARE SHORT SetLocalTime IN win32api STRING SystemTime
   SystemTime = word2str(YEAR(updtdate)) + ;
      word2str(MONTH(updtdate)) + ;
      word2str(DOW(updtdate) - 1) + ;
      word2str(DAY(updtdate))+ ;
      word2str(VAL(LEFT(updtime, 2))) + ;
      word2str(VAL(SUBSTR(updtime, 4, 2))) + ;
      word2str(VAL(SUBSTR(updtime, 7, 2))) + ;
      word2str(VAL(RIGHT(updtime, 2)))
   retval = SetLocalTime(SystemTime)
   FUNCTION word2str
   PARAMETERS wordval
   PRIVATE i, retstr
   retstr = ""
   FOR i = 8 TO 0 STEP -8
      retstr = CHR(INT(wordval/(2^i))) + retstr
      wordval = MOD(wordval, (2^i))
   NEXT
   RETURN retstr

****************************************************************************
* 主要功能:显示等待牌 使用wait窗口             林宇洪
****************************************************************************
proc H_W_设立等待
para _ots
if empty(_ots)   && 没有传递要显示的字 默认使用下面的句子
  _ots = "程序正在进行复杂的数据整理，请您稍候......"
endif
WAIT WINDOW _ots AT (SROW()+13)/2, (SCOLS()-LEN(_ots))/2  NOCLEAR 

proc H_W_消除等待
WAIT clear

****************************************************************************
* 主要功能:显示等待牌  使用旧定义窗口             林宇洪
****************************************************************************
proc H_设立等待
para _ots
if empty(_ots)
  _ots='程序正在进行复杂的数据整理，请您稍候......'
endif
_owa=(SROW())/2
_owb=(SCOLS()-LEN(_ots)-6)/2
defi windows W_等待 at _owa,_owb size 3,len(_ots)+6 in desktop;
     none nofloat nogrow noclose color rgb(255,0,0,188,222,188);
     title "信息提示窗" ;
     font '宋体',12 style 'T'  
activate windows W_等待
@ 1,3 say _ots
return 


proc H_消除等待
rele windows w_等待

*以下程序为景林老师的南平林政资源系统所用的辅助程序块
*由及是以下和网络处理有关通用模块程序块,是通过大量测试编写的,
*在调用程序要考虑周全，当我们这些函数返回.f.值时，应当退出当前表单，否则肯定要出错了
*编程日期 1999.01.28 -- 1999.01.31

************ novell 网上数据库锁定的程序段
proc H_表锁定           &&弹出一个介面告知正在锁定当前数据库
reprold=set("repr")     &&如果返回.f.则说明锁定失败则在调用程序要考虑到如何结束当前工作
set repr to 1   && 设置自动加锁检测为１次
if .not. flock()      
  =H_设立等待("正在锁定表，请您等待....[ESC]放弃")
  do while .not. flock()
    kkey=inkey(0.2,"hM")
    if kkey=27 
      if MESSAGEBOX("放弃锁定操作将放弃本次"+;
              "存盘工作，是否真的放弃？",48+256+4,"")=6      
        exit
      else  
        loop
      endif
    endif      
  enddo   
  =H_消除等待()
  if .not. flock()
    =MESSAGEBOX("加锁数据库失败，放弃存盘退出！",48+0+0,"")
    set repr to reprold
    return .f.      &&表示锁定失败了
  endif
endif
set repr to reprold
return .t.

************ novell 网上数据库锁定的程序段
proc H_表试探锁定 &&弹出一个介面正在试图锁定当前数据库，或指定数据库
                   &&试探性的操作，如果失败一声不吭的返回一个.f.  
reprold=set("repr")     &&如果返回.f.则说明锁定失败则在调用程序要考虑到如何结束当前工作
set repr to 1   && 设置自动加锁检测为１次
if .not. flock()
  =H_设立等待("网络上有操作员正在工作中！")
  set repr to reprold
  return .f.      &&表示锁定失败了
endif
set repr to reprold
return .T.      &&表示锁定成功


************ novell 网上记录锁定的程序段
proc H_记录锁定  &&弹出一个介面告知正在锁定当前数据库
reprold=set("repr")
set repr to 1   && 设置自动加锁检测为１次
if .not. rlock()      
  =H_设立等待("正在锁定记录，请您等待....[ESC]放弃")
  do while .not. rlock()
    kkey=inkey(0.2,"hM")
    if kkey=27
      if MESSAGEBOX("放弃锁定操作将放弃本次"+;
              "存盘工作，是否真的放弃？",48+256+4,"")=6      
         exit
      else  
          loop
      endif
    endif      
  enddo   
  =H_消除等待()
  if .not. rlock()
    =MESSAGEBOX("加锁数据库失败，放弃存盘退出！",48+0+0,"")
    set repr to reprold
    return .f.      &&表示锁定失败了
  endif
endif
set repr to reprold
return .t.

******************  novell 独占测试
proc H_表独占  &&弹出一个介面正在试图独占当前数据库，或指定数据库
para dbfname,alianame,norde    &&第一参数为数据库名,第二参数为别名,第三参数为工作区
ocsgs=para()    && 如果什么参数都没有加则在当前工作区处理当前数据库
do case         && 如果加了一个参数则在一新的工作区内打开指定文件名的数据库
case ocsgs=0   && 说明未带参数,则默认锁定当前数据库
  dbfname=dbf()
case ocsgs=3
  sele norde
other
  sele 0
endcase
olderr=on("ERROR")
nerr=0
on error nerr=error()
if type("alianame")="C"   &&有别名参数
  aliatrue="alia &alianame"
else
  aliatrue=""
endif  
use &dbfname excl &aliatrue
if nerr=1705    && 该文件打不开
  =H_设立等待("正在独占文件，请您稍候....[ESC]放弃")
  do while .t.
     use &dbfname excl  &aliatrue
     if flock()=.t.   && 没有独占成功的话flock文件将失灵
        exit
     endif
     kkey=inkey(0.2,"hM")
     if kkey=27
       if MESSAGEBOX("放弃此操作将放弃本次"+;
          "工作，是否真的放弃？",48+256+4,"")=6      
        exit
      else  
        loop
      endif
    endif      
  enddo   
  =H_消除等待()
  if .not. flock()
    =MESSAGEBOX("独占数据库失败，退出此次操作！",48+0+0,"")
    on error &olderr.
    return .f.      &&表示锁定失败了
  endif
endif
on error &olderr.
return .t.

******************  novell 独占测试
proc H_表试探独占  &&弹出一个介面正在试图独占当前数据库，或指定数据库
                   &&试探性的独占，如果失败一声不吭的返回一个.f.  
para dbfname,alianame,norde    &&第一参数为数据库名,第二参数为别名,第三参数为工作区
ocsgs=para()    && 如果什么参数都没有加则在当前工作区处理当前数据库
do case         && 如果加了一个参数则在一新的工作区内打开指定文件名的数据库
case ocsgs=0   && 说明未带参数,则默认锁定当前数据库
  dbfname=dbf()
case ocsgs=3
  sele norde
other
  sele 0
endcase
olderr=on("ERROR")
nerr=0
on error nerr=error()
if type("alianame")="C"   &&有别名参数
  aliatrue="alia &alianame"
else
  aliatrue=""
endif  
use &dbfname excl &aliatrue
if nerr=1705    && 该文件打不开
  use &dbfname excl  &aliatrue
  if flock()=.t.   && 没有独占成功的话flock文件将失灵
    exit
  endif
  if .not. flock()
    =H_设立等待("网络上有人正在使用本系统！")
    on error &olderr.
    return .f.      &&表示锁定失败了
  endif
endif
on error &olderr.
return .t.


******************
  &&VFP在不稳定的网络上时常会发生不是一个表的错误，本模块针对该现象编写了测试程序
proc H_表测试  &&测试表结构是否完整 &&本程序会导致工作区变化了
para dbfname   &&转到一个零空间　　打开所指定的数据库
olderr=on("ERROR")
nerr=0
on error nerr=error()
sele 0
use &dbfname shar
use
l_err=.t.
if nerr=1705    && 该文件打不开
  if .not. flock()
    wait windows "网络上有人正在使用该文件！" nowait
    l_err=.t.
  endif
endif
if nerr=15    && 该文件表结构损坏
  l_err=.f.
endif
on error &olderr.
return l_err

************************通用错误 陷井
proc H_通用错误    && 本模块拦载网络工享造成的错误并可让用户参与选择
nerr=error()
if nerr=108 .or.nerr=109 
      && 108 109 1.别人正在共享锁定使用数据库，而当前工作站又企图操作brow或repl
      &&   108 为文件被他人使用   109 为当前记录被他人占用
     if MESSAGEBOX("别人已锁住了当前库，建议您再试几次，"+chr(13)+"取消将不存储当前修改了的数据！",32+0+5,"") =4     
         retry
     else 
         return 
     endif
endif
if  nerr=1705        
 && 1705为别人正在独占打开数据库，当前工作站企图想打开数据库
 && 或别人正在共享数据库，当前工作站企图想独占数据库      
     if MESSAGEBOX("正在处理的文件不可修改，可能其属性为只读或其它用户正在使用中，建议您再试几次，取消放弃此项工作！",32+0+5,"") =4     
         retry
     else 
         return 
     endif
endif
if nerr=4 &&数据库末尾错误"
  messagebox("已到数据库的末尾，当前库也许是个空库",0,"提示")
  return 
endif
**************
wait windows "发现一个可能不重要的错误,错误号为"+allt(str(nerr)) nowait
if nerr=1426 .or. nerr=1943 .or. nerr=12 .or. nerr=107   &&发生excel文件被关闭错误
  if type("L_error_记忆")<>"L"
    public L_error_记忆,N_error_记忆
    l_error_记忆=.f.
    N_error_记忆=0
  endif
  N_error_记忆=N_error_记忆+1
  if l_error_记忆=.f. .or. N_error_记忆>=500
    if messagebox("发现系统控制的库文件被关闭，为了数据完整性"+chr(13)+"请点击[确定]以退出系统？",32+1+256,"请注意")=1
      quit
      return
    else
      l_error_记忆=.t.
      N_error_记忆=0
    endif
  endif
endif
*if messagebox("发现一个可能不重要的错误,错误号为"+allt(str(nerr))+"选择确定将退出系统!",32+0+5,"") =4     
*  quit
*endif


************************通用错误 陷井
proc H_忽略错误    && 本模块拦载网络共享造成的错误，尽量忽略此发生的一切错误，当
                   && 然为保证系统不崩溃，自然要增加后继程序段来处理
                   && 主要用于避免不必要的中断，使系统出乱子      
nerr=error()
if nerr=1705.or. nerr=108 .or.nerr=109 
      && 108 109 1.别人正在共享锁定使用数据库，而当前工作站又企图操作brow或repl
      &&   108 为文件被他人使用   109 为当前记录被他人占用
      && 1705为别人正在独占打开数据库或文件，当前工作站企图想打开数据库或删除文件
   wait windows "发现当前处理文件被独点，自动忽略此中断!" nowait
   return .t.
endif


proc 单击关闭
if messagebox("您真的要强制退出系统吗？",32+1+256,"请注意")=1
  quit
  return
endif

proc 重新登录
on shut
clear events

proc 退出系统
pub不退出=.f.
on shut
clear events

proc vfpdeltree
para c_dir
if .not. DirEctory(c_dir)   &&目录名给错了，返回一个.f.值
  return .f.
endif
olderr=on("ERROR")  &&保存旧的错误处理程序
on erro do H_忽略错误  &&设置错误中断工作方式为忽略错误方式
dime m_tmp_dir(1)
m_tmp_dir(1)=allt(c_dir)
n_tag=1
n_temp_sum=0
do while .t.
  n_temp_sum=  n_temp_sum+1
  if n_temp_sum>=100 && 有100层目录或死循环100次
    exit  &&强行退出
  endif  
  n_Ok=adir(m_目录列表,m_tmp_dir(n_tag)+"\*.","D")
  n_OK=n_ok-2
  =adel(M_目录列表,1)
  =adel(M_目录列表,1)
  l_dir=.f.   &&是否有目录的标志
  for n_tmp=1 to n_ok
    if "D" $ m_目录列表(n_tmp,5)
      l_dir=.t.
      exit
    endif
  endfor
  if l_dir
    n_tag=n_tag+1
    dime m_tmp_dir(n_tag)
    m_tmp_dir(n_tag)=m_tmp_dir(n_tag-1)+"\"+allt(m_目录列表(n_tmp,1))
  else
    c_tmp=m_tmp_dir(n_tag)+"\*.*"
    erase (c_tmp) recycle
    rd (m_tmp_dir(n_tag))
    if n_tag=1
      exit
    endif
    n_tag=n_tag-1
    dime m_tmp_dir(n_tag)
  endif
enddo
if DirEctory(c_dir)
  &&用程序删除无效转入使用DOS命令删除
  C_dir_dele="deltree /y "+c_dir
  DO RUNdos WITH (C_dir_dele)
  =inkey(1,'hm') &&等两秒
endif
on error &olderr.
l_err=.t.
if DirEctory(c_dir)
  l_err=.f.
endif
return l_err
 
**********************************修改系统日期时间 
FUNCTION setsystime
PARAMETERS updtdate,updtime
DECLARE SHORT SetLocalTime IN win32api STRING SystemTime
   SystemTime = word2str(YEAR(updtdate)) + ;
      word2str(MONTH(updtdate)) + ;
      word2str(DOW(updtdate) - 1) + ;
      word2str(DAY(updtdate))+ ;
      word2str(VAL(LEFT(updtime, 2))) + ;
      word2str(VAL(SUBSTR(updtime, 4, 2))) + ;
      word2str(VAL(SUBSTR(updtime, 7, 2))) + ;
      word2str(VAL(RIGHT(updtime, 2)))
   retval = SetLocalTime(SystemTime)
   FUNCTION word2str
   PARAMETERS wordval
   PRIVATE i, retstr
   retstr = ""
   FOR i = 8 TO 0 STEP -8
      retstr = CHR(INT(wordval/(2^i))) + retstr
      wordval = MOD(wordval, (2^i))
   NEXT
   RETURN retstr

********************  &&不黑屏运行DOS命令
FUNCTION rundos 
PARAMETER doscmd 
DECLARE INTEGER WinExec IN win32api AS run ; 
        STRING command, INTEGER param 
  cmdstart = fullpath("FOXRUN.PIF")+" /C" 
fullcmd = cmdstart + doscmd 
retval = run(fullcmd, 0)
clear dlls
RETURN retval