mypubproc.prg

foxpro连接sqlserver的例子

ofrmLeftTime = CREATEOBJECT('frmLeftTime',lnWaitSecs)
if lnWaitsecs > 0
	ofrmLeftTime.show
endif
*-- 提示对话框
  lnRetVal = MessageBox( lcMsgText, lnButtons, lcMsgTitle)

*!*	  ofrmLeftTime.release
*!*	  RELEASE ALL LIKE frmLeftTime
  showwait("")

RETURN lnRetVal

*-- 定义到记时对象
**************************************************
*-- 基类:    form
*
DEFINE CLASS frmLeftTime AS form


	Top = 12
	Left = 314
	Height = 40
	Width = 119
	ShowWindow = 1
	DoCreate = .T.
	Caption = "倒记时中..."
	ControlBox = .F.
	Closable = .F.
	MaxButton = .F.
	MinButton = .F.
	TitleBar = 1
	AlwaysOnTop = .T.
	lntotalsecs = 0
	Name = "frmLeftTime"
	tStartSecond = second()


	ADD OBJECT timer1 AS timer WITH ;
		Top = 0, ;
		Left = 84, ;
		Height = 23, ;
		Width = 23, ;
		Interval = 500, ;
		Name = "Timer1" 


	ADD OBJECT label1 AS label WITH ;
		AutoSize = .T., ;
		FontBold = .T., ;
		FontSize = 26, ;
		Alignment = 1, ;
		BackStyle = 0, ;
		Caption = "0", ;
		Height = 42, ;
		Left = 20, ;
		Top = 3, ;
		Width = 22, ;
		ForeColor = RGB(255,0,0), ;
		Name = "Label1"


	ADD OBJECT label2 AS label WITH ;
		AutoSize = .T., ;
		Caption = "秒剩余...", ;
		Height = 16, ;
		Left = 51, ;
		Top = 23, ;
		Width = 56, ;
		Name = "Label2"


	PROCEDURE Init
		para lnTotalTime
		this.lnTotalSecs	= lnTotalTime
		this.tStartSecond = second()

		if lnTotalTime = 0
			this.timer1.enabled = .f.
		endif
		thisform.label1.caption = allt(str(lnTotalTime))
	ENDPROC

	PROCEDURE QueryUnload
		if thisform.timer1.enabled = .F.
			KEYBOARD '{ENTER}' PLAIN
			thisform.release
		endif
	ENDPROC
	
	PROCEDURE timer1.Timer
		n = thisform.lnTotalSecs
		lnTimer = n - (second() - thisform.tStartSecond)
		
		if lnTimer <= 0
			this.enabled = .f.
			thisform.QueryUnload
		else
			thisform.label1.caption = allt(str(lnTimer))
*			showwait ("将在 "+allt(str(lnTimer)) + " 秒后自动确认...")
		endif


	ENDPROC


ENDDEFINE
*
*-- ===============================================================


*-- ===============================================================
*-- 程序文件：EdtShort.prg
*-- 程序功能：在文本可编辑区域内弹出编辑快捷菜单，实现快速编辑操作
*-- 一般使用方法：在可文本编辑的控件内的RightClick事件中写入代码;
*               do EdtShort.prg with this
*-- 增强使用方法：新建类，派生于可编辑的控件，如TextBox、EditBox等，再在其控件内的RightClick事件中写入代码：do EdtShort.prg with this，保存以便后用。
*-- 功能不足：不能对“密码框、只读框”进行识别操作，不能对“撤消”进行检测，希望能在以后进行升级，并欢迎大家能给出好的建议和意见！ 
*-- ===============================================================
proc EdtShort
para oREF
DEFINE POPUP EdtShort SHORTCUT RELATIVE FROM MROW(),MCOL()
DEFINE BAR _med_undo OF EdtShort PROMPT "撤消(\<U)" ;
    MESSAGE "撤消上一次命令或操作" ;
	PICTRES _med_undo
DEFINE BAR 3 OF EdtShort PROMPT "\-"
DEFINE BAR _med_cut OF EdtShort PROMPT "剪切(\<T)" ;
    SKIP FOR oREF.sellength = 0 ;
    MESSAGE "移去选定内容并将其放入剪贴板" ;
    PICTRES _med_cut
DEFINE BAR _med_copy OF EdtShort PROMPT "复制(\<C)" ;
    SKIP FOR oREF.sellength = 0 ;
    MESSAGE "将选定内容复制到剪贴板上" ;
    PICTRES _med_copy
DEFINE BAR _med_paste OF EdtShort PROMPT "粘贴(\<P)" ;
    SKIP FOR empty(_cliptext) ;
    MESSAGE "粘贴剪贴板上的内容" ;
	PICTRES _med_paste
DEFINE BAR _med_clear OF EdtShort PROMPT "删除(\<D)" ;
    SKIP FOR oREF.sellength = 0 ;
    MESSAGE "移去选定内容，并且不将其放到剪贴板上" ;
    PICTURE "delete.bmp"
DEFINE BAR 8 OF EdtShort PROMPT "\-"
DEFINE BAR _med_slcta OF EdtShort PROMPT "全选(\<A)" ;
    MESSAGE "选定当前窗口中的所有文本或数据项" ;
    PICTRES _med_slcta
ACTIVATE POPUP EdtShort 
retu
*-- ===============================================================


*-- ===============================================================
*-- 显示 wait 信息
*-- ===============================================================
Func ShowWait
para wait_info,wait_second
local lcWaitMode
if empty(wait_info)
	wait clear
	SET MESSAGE TO "就绪"
	retu
endif
if type("wait_info") <> "C"
	wait_info = "请等待..."
endif
if type("wait_second") <> "N"
	lcWaitMode = "nowait"
else
	lcWaitMode = "timeout "+allt(str(wait_second))
endif
set message to wait_info
*-- wait window wait_info &lcWaitMode
*-- 使提示的信息居中
lcInfoCaption = "          === 提示信息 ===          "
lnInfoLen	= len(lcInfoCaption)
lnWaitInfo	= len(wait_info)
if	lnInfoLen	>	lnWaitInfo
	lcAddCaption	= ""
	lcAddWaitInfo	= repl(" ",(lnInfoLen-lnWaitInfo)/2)
else
	lcAddCaption	= repl(" ",(lnWaitInfo-lnInfoLen)/2)
	lcAddWaitInfo	= ""
endif

wait window lcAddCaption + lcInfoCaption ;
	+chr(13)+chr(13)+ ;
	lcAddWaitInfo + wait_info ;
	at ;
	SYSMETRIC(2)/17/2 - 4 ,;
	SYSMETRIC(1)/6.4/2-iif(lnWaitInfo>lnInfoLen,lnWaitInfo,lnInfoLen)/2 ;
	&lcWaitMode
retu
*-- ===============================================================


*-- ===============================================================
Func ErrorHand
*-- 错误处理程序
*	调用方法：
*	on error do errorhand with ;
*		error(),;
*		message(),;
*		message(2),;
*		program(),;
*		program(1),;
*		lineno(2)

*	程 序 员：红虎
*	编写日期：2001-1-18
*-- ===============================================================
para nErrCode,cErrMsg,cErrMsg1,cErrPrg,cErrPrg1,nErrLine
Local lnErrCode,lcErrMsg,lcErrMsg1,lcErrPrg,lcErrPrg1,lnErrLine
lnErrCode	= nErrCode
lcErrMsg	= cErrMsg
lcErrMsg1	= cErrMsg1
lcErrPrg	= cErrPrg
lcErrPrg1	= cErrPrg1
lnErrLine	= nErrLine

#Define	EnterBack	chr(13) + chr(13)

if	inlist(nErrCode,1958,165,39)	&& 当满足这些错误时。。。
	*-- 1958	装载打印机错误
	*-- 165		菜单定义错误
	*-- 39		数据上溢
	messagebox(cErrMsg + chr(13)+chr(13)+"所需执行任务已被忽略！",48,"系统警告")
	retu
endif

if lcErrPrg # lcErrPrg1
	lcErrPrg = lcErrPrg1 + " -> " + lcErrPrg
endif

ans = 0
MsgInfo = 				"错误代码: " + str(lnErrCode)	+ 	EnterBack
MsgInfo	=	MsgInfo	+	"程序行号: "	+	str(lnErrLine)+	EnterBack
MsgInfo	=	MsgInfo	+	"错误指令: "	+	lcErrMsg1	+ 	EnterBack
MsgInfo	=	MsgInfo	+	"错误信息: "	+	lcErrMsg		+	EnterBack
MsgInfo	=	MsgInfo	+	"调用过程: "	+	lcErrPrg		+	EnterBack
MsgInfo	=	MsgInfo	+	repl("-",50)	+	EnterBack
MsgInfo	=	MsgInfo	+	"一旦发生类似意外错误，请务必联系系统维护员，谢谢！"

ANS	=	messagebox(MsgInfo,2+16+256,"系统程序意外错误")

lcOldAlias	= alias()

DO CASE
	CASE ANS = 3
	*-- 终止
	on shutdown quit
	_screen.hide
	cancel
	clea events
	RETU to master
	CASE ANS = 4
	*-- 重试
		RETRY
	CASE ANS = 5
	*-- 忽略
ENDCASE	
retu
*-- ===============================================================


*-- ===============================================================
*-- 密文解密和加密
*-- 解密：unPassword(密文)  => 密码
*-- 加密：Password(密码)    => 密文
*-- ===============================================================

*-- 解密
FUNCTION unPassword
lPARAMETERS tcPassChar
LOCAL lcAllPassword,lcOnePassword,lnPassLen,lnOnePassword,lcAllPasswordNew
LOCAL lcOldPass
lcOldPass	= ""
FOR i=1 TO LEN(tcPassChar) / 3
	lcOldPass	= lcOldPass + CHR(VAL(SUBSTR(tcPassChar,i*3-2,3)))
ENDFOR
tcPassChar	= lcOldPass
*-- 将得到的一串不可见字符字符经由asc()函数转换
lnPassLen = len(tcPassChar)
lcAllPasswordNew = ""
For i = 1 to lnPassLen
	lcOnePassword = substr(tcPassChar,i,1)
	if	lcOnePassword # ' '
		lcOnePassword = allt(str(asc(lcOnePassword)))
	endif
	lcAllPasswordNew = lcAllPasswordNew + lcOnePassword
Endfor
tcPassChar = lcAllPasswordNew
lnPassLen = len(tcPassChar)/5
lcAllPassword = ""
lcOnePassword = ""
lnOnePassword = 0

For i = 1 to lnPassLen    
	lcOnePassword = subst( tcPassChar,5 * i - 4 , 3)
	if	empty(lcOnePassword)
		lcOnePassword = " "
	else
		lnOnePassword = val(lcOnePassword) - i
		if	between(lnOnePassword,0,255)
			lcOnePassword = chr(lnOnePassword)
		else
			lcOnePassword = chr( rand() * 100 )&& 密码里不应该出现有空字符，所以错误
		endif
	endif
	lcAllPassword = lcAllPassword + lcOnePassword
Endfor

Retu lcAllPassword

*-- 加密
FUNCTION  Password
lPARAMETERS tcPassChar
LOCAL lcAllPassword,lcOnePassword,lnPassLen,lcReturnPass
*!*	clea
*!*	?"原文：",tcpasschar
lcAllPassword = ""
lcOnePassword = ""

lnPassLen = len(tcPassChar)
For i = 1 to lnPassLen
	*-- 密码的每五位只有前三位有用，后二位随机
	lcOnePassword = str(asc(subs( tcPassChar,i,1)) + i,3)
	lcAllPassword = lcAllPassword + lcOnePassword + str(rand()*100,2)
Endfor
*!*	?'一次加密后：',lcAllPassword + '|'
*-- 将得到的一串字符经由chr()函数转换不可见字符
lnPassLen = len(lcAllPassword)
lcAllPasswordNew = ""
For i = 1 to lnPassLen
	lcOnePassword = substr(lcAllPassword,i,1)
	if	lcOnePassword # ' '
		lcOnePassword = chr(val(lcOnePassword))
	endif
	lcAllPasswordNew = lcAllPasswordNew + lcOnePassword
Endfor
*!*	?'二次加密后：',lcAllPasswordNew + '|'
lcReturnPass	= ""
FOR i=1 TO LEN(lcAllPasswordNew)
	lcReturnPass	= lcReturnPass	+ STR(ASC(SUBSTR(lcAllPasswordNew,i,1)),3)
ENDFOR
lcReturnPass	= STRTRAN(lcReturnPass," ","0")
RETURN lcReturnPass && lcAllPasswordNew
*-- ===============================================================


*-- ===============================================================
*-- 获取颜色
FUNCTION GetMyColor
*-- ===============================================================
LPARAMETERS toControl,tcProperty
LOCAL lnNewColor

IF TYPE("tcProperty") # "C"
	tcProperty = "ForeColor"
ENDIF

lnNewColor = GETCOLOR()
IF lnNewColor >= 0
	toControl.&tcProperty = lnNewColor
ENDIF

RETURN lnNewColor
*-- ===============================================================

*-- ===============================================================
FUNCTION CloseTableLike
PARAMETER tcLike
LOCAL laAlias[1],i,lcOldExact
IF AUSED(laAlias)=0
	RETURN
ENDIF
FOR i=1 TO ALEN(laAlias,1)
	IF ATC(tcLike, laAlias[i,1])=1
		USE IN (laAlias[i,1])
	ENDIF
ENDFOR
RETURN
*-- ===============================================================

*-- ===============================================================
*-- ===============================================================
*-- ===============================================================

*-- ===============================================================
*-- ===============================================================
*-- ===============================================================