在好例子网，分享、交流、成长！
您当前所在位置：首页 → Others 开发实例 → 一般编程问题 → DBF程序(VFP)

DBF程序(VFP)

一般编程问题

下载此实例
  • 开发语言：Others
  • 实例大小：0.01M
  • 下载次数：9
  • 浏览次数：352
  • 发布时间：2017-11-02
  • 实例类别：一般编程问题
  • 发 布 人：Deadzlq
  • 文件格式：.prg
  • 所需积分：2
 相关标签： d
网友评论 举报投诉 收藏该页

实例介绍

【实例简介】

【实例截图】

from clipboard

【核心代码】 

*----------MyDBF--------2017.04.25 By Mr.White
Clear
Close All
Clear All
Set Ansi Off	&& 短字符匹配
Set Date Ansi
Set Century On
SET SAFETY OFF
SET DELETED ON
SET HOURS TO 24
SET EXCLUSIVE ON
Set StrictDate To 0
On Error Do ErrMsg With Error( ), Message( ), Message(1), Program( ), Lineno( )
On Key Label Alt E MyFrm.Mycontainer.MyShape2.Click
On Key Label Alt Q MyFrm.Mycontainer.MyShape1.Click
On Key Label Ctrl O MyFrm.OpenDBF
MyFrm=CreateObject("oMyForm")
MyFrm.Show
Read Events
ON KEY
On Error
*!*	Return
QUIT

Procedure ErrMsg
	Parameter merror, cmess, cmess1, mprog, mlineno
	=Messagebox( "IF Need to help,Give this screenshot to Email [767915365@qq.com],THS!"   Chr(13);
		  Chr(13)   'Error number: ' 			  Ltrim(Str(merror))	 Chr(13);
		  Chr(13)   'Error message: ' 			  cmess					 Chr(13);
		  Chr(13)   'Line of code with error: '   cmess1				 Chr(13);
		  Chr(13)   'Line number of error: ' 	  Ltrim(Str(mlineno))	 Chr(13);
		  Chr(13)   'Program with error: ' 		  mprog,0 64,"Caution Tips")
*!*		suspend
	RETURN 1
Endproc

Define Class oMyForm As Form
	Name			= "MyFrm"
	Caption 		= "MyDBF Prgram"
	Width			= 656
	Height			= 347
	Left			= 0
	Top				= 0
	AutoCenter		= .T.
	MaxButton		= .F.
	MinButton		= .F.
	ControlBox		= .T.
	BorderStyle		= 1
	ShowWindow		= 2
	Visible 		= .T.
	ShowTips		= .T.
	nExeTime		= 0
	DefaultPath		= "D:\MyDBF"
	nTipsSeconds	= 20
	tRunTime		= DATETIME()
	nRandSelect		= -1
	Icon			= 'F:\MyPic\Sleep.ico'
	Procedure Load
		Declare Long ShowWindow		in "user32.dll"	Long hwnd,Long nCmdShow
		Declare Long EnableWindow	in "user32.dll" Long hwnd,Long fEnable
*!*			Declare Long FindWindow	in "user32"		String lpClassName,String lpWindowName
*!*			Declare Long FindWindowEx	in "user32" 		Long hWnd1,Long hWnd2,String lpsz1,String lpsz2
		Declare Long SendMessage	in "user32"		Long hwnd,Long wMsg,Long wParam,Long lParam
		Declare Long PostMessage	in "user32"		Long hwnd,Long wMsg,Long wParam,Long lParam
*!*			Declare Long WinExec 		in "kernel32.dll" 	String lpCmdLine,Long nCmdShow
*!*	*		Declare Long SetWindowText In "user32.dll"	Long hwnd,String lpString		&&改变标题
*!*			Declare Long GetClassName	in "user32"		Long hwnd,String ByVal,Long nMaxCount
*!*			Declare Long mouse_event	in "user32.dll"  	Long dwFlags,Long dx,Long dy,Long cButtons,Long dwExtraInfo
*!*	*		Declare Long keybd_event 	in "user32.dll" 	Long bVk,Long bScan,Long dwFlags,Long dwExtraInfo
*!*			Declare Long SetForegroundWindow	in "user32.dll" Long hwnd
*!*			Declare Long GetPrivateProfileString	In "kernel32.dll" String lpApplicationName,String lpKeyName,String lpDefault,String lpReturnedString,Long nSize,String lpFileName
*!*			Declare Long WritePrivateProfileString	In "kernel32.dll" String lpApplicationName,String lpKeyName,String lpString,String lpFileName
	Endproc
	Procedure Init
		LOCAL cPath
		cPath= this.DefaultPath
		This.TitleBar=0
		NumLock(.T.)
		If !Directory(cPath)
			Md(cPath)
		Endif
		Set Default TO &cPath
*!*			IF BETWEEN(RIGHT(DTOC(DATE()),5),"04.01","09.30")
*!*				this.cLimitTime="18:00:00"
*!*			ELSE
*!*				this.cLimitTime="17:30:00"
*!*			ENDIF
		RELEASE cPath
		This.AddObject("MyContainer","oMyContainer")
	Endproc
	Procedure Unload
		Clear Dlls
		Clear Events
	ENDPROC
	PROCEDURE MoveFrmWindow
		WAIT "[Tips:可按键盘方向键后移动]" WINDOW TIMEOUT 2
		#define WM_SYSCOMMAND 0x112
		#define SC_MOVE 0xF010
		=SendMessage(this.HWnd,WM_SYSCOMMAND,SC_MOVE,0)
	ENDPROC
	PROCEDURE EnableShowW
		This.MyContainer.MyTextbox.visible=.T.
		This.MyContainer.MyTextbox.setfocus()
	ENDPROC
	PROCEDURE CliptextToDbf
		LOCAL ctext,nMaxtxt
		IF MESSAGEBOX("请先复制[Ctrl C]要转换为DBF的文本" CHR(13) CHR(13) "是否已复制(Y/N)",4   64   256,"温馨提示")=6
			ctext=_Cliptext
			nMaxtxt= MEMLINES(ctext)
			IF !EMPTY(ctext)
				CREATE Table curTmpText(cTxtField C(50))&& 数据表	&&表格多栏复制，默认以TAB分隔	_Mline决定长度
				FOR i=1 TO nMaxtxt
					WAIT ALLTRIM(STR(nMaxtxt-i)) WINDOW nowait
					IF !EMPTY(MLINE(ctext,i))
						INSERT INTO curTmpText(cTxtField) VALUES(MLINE(ctext,i))
					ENDIF
				ENDFOR
				SELECT curTmpText
			ELSE
				=MESSAGEBOX("复制的文本内容为空!" CHR(13) CHR(13) "请重新再来,THS!",0 64,"Caution Tips")
			ENDIF
		ENDIF
	ENDPROC
	PROCEDURE OpenDBF
		LOCAL cOpenFilePath
		STORE "" TO cOpenFilePath
		cOpenFilePath=GETFILE("DBF","","确定",0,"请选择要打开的DBF文件")
		IF !EMPTY(cOpenFilePath)
			USE (cOpenFilePath) IN 0
			cOpenFilePath=SUBSTR(cOpenFilePath,RAT("\",cOpenFilePath) 1)
			cOpenFilePath=LEFT(cOpenFilePath,AT(".",cOpenFilePath)-1)
			SELECT (cOpenFilePath)
			WAIT "数据表已打开!" CHR(13) CHR(13) "TIPS1:[Brow]指令可以查看对应记录" CHR(13) CHR(13) "TIPS2:[modi stru]指令可查看表结构" windows TIMEOUT 8
		ELSE
			=MESSAGEBOX("选择的文件为空" CHR(13) CHR(13) "若要重新打开请按组合键[Ctrl O],THS!",0 64,"Caution Tips")	
		ENDIF
	ENDPROC
	PROCEDURE GetSystemInfo
		WAIT "正在读取系统信息,请稍后.." windows NOWAIT
		owsh=CREATEOBJECT("Wscript.shell")
		owsh.run("cmd /c systeminfo /fo csv>>" this.DefaultPath "\SystemInfo.csv",0,.T.)
		RELEASE owsh
		oExcel=CREATEOBJECT("Excel.Application")
		oExcel.visible=.F.
		oExcel.DisplayAlerts=.F.
		oExcel.workbooks.open(this.DefaultPath "\SystemInfo.csv")
		&&---因systeminfo命令每次都会在后面追加，故改
    	oExcel.Range(oExcel.Range("A1").End(-4121).offset(-1,0), oExcel.Range("A1").SpecialCells(11)).Select
    	oExcel.Selection.Copy
	    oExcel.Workbooks.Add
	    oExcel.Selection.PasteSpecial(-4163,-4142,.F.,.T.)
	    oExcel.Application.CutCopyMode = .F.
	    oExcel.Workbooks("SystemInfo.csv").Close
	    oExcel.Cells.Select
    	oExcel.Cells.EntireColumn.AutoFit
    	oExcel.Range("A2").Select
    	oExcel.ActiveWindow.FreezePanes = .T.
		oExcel.Columns("B:B").ColumnWidth = 75
	    With oExcel.Range("A11:B11").Interior
	        .Pattern = 1
	        .PatternColorIndex = -4105
	        .Color = 65535
	        .TintAndShade = 0
	        .PatternTintAndShade = 0
	    EndWith
    	oExcel.Range("B11").Select
    	oExcel.WindowState =-4137
    	oExcel.visible=.T.
    	RELEASE oExcel
	ENDPROC
Enddefine

Define Class oMyContainer As Container
	Top 	= 0
	Left 	= 0
	Height 	= 347
	Width	= 656
	Picture	='F:\mypic\mydbf.jpg'
	Visible	=.T.
	Procedure Init
		this.AddObject('MyShape1','oMyShape1')
		this.AddObject('MyShape2','oMyShape2')
		this.AddObject('MyLabel1','oMyLabel1')
		this.AddObject('MyLabel2','oMyLabel2')
		this.AddObject('MyEditbox1','oMyEditbox1')
		this.AddObject('MyEditbox2','oMyEditbox2')
		this.AddObject("MyTextBox","oMyTextBox")
		this.AddObject('MyTimer','oMyTimer')
	Endproc
Enddefine

Define Class oMyShape1 As Shape
	Top 	= 10
	Left 	= 622
	Height	= 25
	Width 	= 25
	BackStyle	= 0
	BorderStyle	= 0
	MousePointer= 15
	Visible	= .T.
	ToolTipText	= "退出程序(Q)"
	Procedure Click
		Thisform.Unload()
	Endproc
Enddefine

Define Class oMyShape2 As Shape
	Top 	= 302
	Left 	= 602
	Height 	= 40
	Width 	= 51
	BackStyle	= 0
	BorderStyle	= 0
	MousePointer= 15
	Visible	= .T.
	ToolTipText = "执行(E)"
	Procedure Click
		Local cEditInput
		cEditInput=STRTRAN(STRTRAN(STRCONV(ALLTRIM(ThisForm.MyContainer.MyEditBox1.value),2),CHR(13)),CHR(10))
		IF !EMPTY(cEditInput)
			thisform.nExeTime=thisform.nExeTime 1
			ThisForm.MyContainer.MyEditBox2.value="[" ALLTRIM(STR(thisform.nExeTime)) "]:" cEditInput CHR(13) ThisForm.MyContainer.MyEditBox2.value
			&cEditInput
		ELSE
			=MESSAGEBOX("所输入的内容为空" CHR(13) CHR(13) "请输入对应执行指令",0 64,"Caution Tips")
			this.Refresh()
		ENDIF
	Endproc
Enddefine

Define Class oMyLabel1 As Label
	Caption	= "系统:"
	Top 	= 21
	Left 	= 232
	Height 	= 17
	Width 	= 375
	BackStyle = 0
	Visible	= .T.
	Procedure Init
		This.Caption="系统:" Strtran(Sys(0)," # ",",")
	Endproc
Enddefine

Define Class oMyLabel2 As Label
	Caption	= "Tips:"
	Top		= 316
	Left	= 43
	Height	= 17
	Width	= 557
	BackStyle = 0
	Visible	= .T.
	Procedure Init
		This.Caption="Tips:现在系统时间:" Ttoc(Datetime()) "," Cdow(Date())
	Endproc
Enddefine

Define CLASS oMyEditBox1 As EditBox
	Top		= 65
	Left 	= 10
	Height 	= 141
	Width 	= 638
*	BackStyle = 0
	SpecialEffect	= 1
	ToolTipText		= '请输入您的FoxPro指令' CHR(13) '组合键[ALT E]或点Go执行' CHR(13) '此版本暂不支持分号";"断行及多句执行'
	Value			= ""
	SelectOnEntry	= .T.
	Visible			= .T.
	PROCEDURE RightClick
		*------------右击快捷菜单
		DEFINE POPUP MyEditScPopup SHORTCUT Relative FROM MROW(0),MCOL(0)
		DEFINE BAR 1  OF MyEditScPopup PROMPT '清空输入指令(\<C)'
		DEFINE BAR 2  OF MyEditScPopup PROMPT '打开DBF(\<O)'
		DEFINE BAR 3  OF MyEditScPopup PROMPT '粘贴板文本转DBF(\<P)'
		DEFINE BAR 4  OF MyEditScPopup PROMPT '指定句柄使其生效并显示(\<E)'
		DEFINE BAR 5  OF MyEditScPopup PROMPT '关闭所有数据(\<A)'
		DEFINE BAR 6  OF MyEditScPopup PROMPT '移动窗口(\<M)'
		DEFINE BAR 7  OF MyEditScPopup PROMPT '查询系统信息(\<C)'
		ON SELECTION BAR 1 OF MyEditScPopup MyFrm.MyContainer.MyEditBox1.value=""
		ON SELECTION BAR 2 OF MyEditScPopup MyFrm.OpenDBF
		ON SELECTION BAR 3 OF MyEditScPopup MyFrm.CliptextToDbf
		ON SELECTION BAR 4 OF MyEditScPopup MyFrm.EnableShowW	&&MESSAGEBOX("该功能还在开发中..." CHR(13) CHR(13) "敬请期待,THS!",0 64,"Caution Tips")
		ON SELECTION BAR 5 OF MyEditScPopup Close ALL
		ON SELECTION BAR 6 OF MyEditScPopup MyFrm.MoveFrmWindow
		ON SELECTION BAR 7 OF MyEditScPopup MyFrm.GetSystemInfo
		ACTIVATE POPUP MyEditScPopup
	ENDPROC
Enddefine

Define CLASS oMyEditBox2 As EditBox
	Top		= 209
	Left 	= 10
	Height 	= 91
	Width 	= 638
*	BackStyle = 0
	SpecialEffect	= 1
	TabStop			= .F.
	Value			= ""
	ToolTipText		= "已执行Go的[历史记录]"
	SelectOnEntry 	= .T.
	ReadOnly		= .T.
	Visible			= .T.
Enddefine

Define Class oMyTimer As Timer
	Interval = 1000
	Enabled=.T.
	Procedure Timer
		LOCAL nSelect
		IF (INT((DATETIME()-thisform.tRunTime)/thisform.nTipsSeconds)%thisform.nTipsSeconds)%2=0
			ThisForm.MyContainer.MyLabel2.Caption="Tips:现在系统时间:" Ttoc(Datetime()) "," ALLTRIM(Cdow(Date()))
			ThisForm.nRandSelect=-1
		ELSE
			IF ThisForm.nRandSelect=-1
				nSelect=INT(RAND()*20)
			ELSE
				nSelect=ThisForm.nRandSelect
			ENDIF
			DO CASE
				CASE nSelect=1
					ThisForm.MyContainer.MyLabel2.Caption="Tips:{Use [TableName]}指令可以打开指定路径数据表,不加表名则为关闭"
					ThisForm.nRandSelect=nSelect
				CASE nSelect=2
					ThisForm.MyContainer.MyLabel2.Caption="Tips:{Brow}命令可以查看当前工作区的数据表记录"
					ThisForm.nRandSelect=nSelect
				CASE nSelect=3
					ThisForm.MyContainer.MyLabel2.Caption="Tips:组合键[Ctrl 0] 可以选择打开对应DBF表"
					ThisForm.nRandSelect=nSelect
				CASE nSelect=4
					ThisForm.MyContainer.MyLabel2.Caption="Tips:{Select [TableName]}可将当前工作区打开的为可选定数据表"
					ThisForm.nRandSelect=nSelect
				CASE nSelect=5
					ThisForm.MyContainer.MyLabel2.Caption="Tips:[Select/Update/Delete/Insert]SQL语句可参阅对应帮助文档"
					ThisForm.nRandSelect=nSelect
				CASE nSelect=6
					ThisForm.MyContainer.MyLabel2.Caption="Tips:{MESSAGEBOX(_cliptext)}可查看对应粘贴板上复制文本"
					ThisForm.nRandSelect=nSelect
				CASE nSelect=7
					ThisForm.MyContainer.MyLabel2.Caption="格言:真理惟一可靠的标准就是永远自相符合--欧文"
					ThisForm.nRandSelect=nSelect
				CASE nSelect=8
					ThisForm.MyContainer.MyLabel2.Caption="格言:时间是一切财富中最宝贵的财富--德奥弗拉斯多"
					ThisForm.nRandSelect=nSelect
				CASE nSelect=9
					ThisForm.MyContainer.MyLabel2.Caption="格言:世界上一成不变的东西，只有“任何事物都是在不断变化的”这条真理--斯里兰卡"
					ThisForm.nRandSelect=nSelect
				CASE nSelect=10
					ThisForm.MyContainer.MyLabel2.Caption="格言:友谊是一棵可以庇荫的树--柯尔律治"
					ThisForm.nRandSelect=nSelect
				CASE nSelect=11
					ThisForm.MyContainer.MyLabel2.Caption="格言:理想是人生的太阳--德莱赛"
					ThisForm.nRandSelect=nSelect
				CASE nSelect=12
					ThisForm.MyContainer.MyLabel2.Caption="格言:笨蛋自以为聪明，聪明人才知道自己是笨蛋--莎士比亚"
					ThisForm.nRandSelect=nSelect
				CASE nSelect=13
					ThisForm.MyContainer.MyLabel2.Caption="诗歌:时光不老,可我们,终将要散别离--棕橙"
					ThisForm.nRandSelect=nSelect
				CASE nSelect=14
					ThisForm.MyContainer.MyLabel2.Caption="诗歌:晚风凄和楚,离歌悲与情,他乡念千里,唯有爱无际--思夜"
					ThisForm.nRandSelect=nSelect
				CASE nSelect=15
					ThisForm.MyContainer.MyLabel2.Caption="诗歌:曾无数次怀疑过活着的意义,直到遇到你,我一直在你身后,只差一个回头--等你"
					ThisForm.nRandSelect=nSelect
				CASE nSelect=16
					ThisForm.MyContainer.MyLabel2.Caption="诗歌:云雨繁华世,开门天戏尘,雾过普光辉，散聚口沸题--云开雾散"
					ThisForm.nRandSelect=nSelect
				CASE nSelect=17
					ThisForm.MyContainer.MyLabel2.Caption="诗歌:三三渡冷山,两两塔下寒,云深何出处,九九艳阳天--出处"
					ThisForm.nRandSelect=nSelect
				CASE nSelect=18
					ThisForm.MyContainer.MyLabel2.Caption="诗歌:皑如山上雪,皎若云间月,闻君有两意，故来相决绝--卓文君《白头吟》"
					ThisForm.nRandSelect=nSelect
				CASE nSelect=19
					ThisForm.MyContainer.MyLabel2.Caption="TIPS:世间没有不劳而获的结果,世界铁则的主旋律还是等价的交换,有因才有果--By Mr.White"
					ThisForm.nRandSelect=nSelect
				OTHERWISE
					ThisForm.MyContainer.MyLabel2.Caption="TIPS:0和1的关系,反映的不单单是无和有的状况,而是这个过程来之不易--By Mr.White"
					ThisForm.nRandSelect=nSelect
			ENDCASE
		ENDIF
		IF !EMPTY(DBF())
			thisform.Caption="Tips:当前打开的数据表:[" DBF() "],最大记录数:[" ALLTRIM(STR(RECCOUNT())) "]"
		ENDIF
	Endproc
ENDDEFINE

DEFINE CLASS oMyTextBox as TextBox
	Top=36
	Left=478
	Height=25
	Width=169
	SpecialEffect=1
	SelectOnEntry=.T.
	Visible=.F.
	Value="请输入对应的句柄值"
	Tooltiptext="十六进制请以0x开头[默认为十进制]"
	PROCEDURE KeyPress
		LPARAMETERS nKeyCode, nShiftAltCtrl
		LOCAL cInPutHandle
		IF nKeyCode=13
			cInPutHandle=STRCONV(ALLTRIM(this.Value),2)
			IF !EMPTY(cInPutHandle) AND (LEFT(cInPutHandle,2)="0x" OR ISDIGIT(cInPutHandle))
				oReg = CreateObject("VBScript.RegExp")
				oReg.Pattern = "[^0-9A-Fa-fXx]"
				oReg.IgnoreCase = .F.
				cInPutHandle=oReg.Replace(cInPutHandle,"")
				RELEASE oReg
				=EnableWindow(EVALUATE(cInPutHandle),1)
				=ShowWindow(EVALUATE(cInPutHandle),1)
				this.Value="请输入对应的句柄值"
				this.Visible=.F.
				thisform.Mycontainer.MyEditBox1.setfocus()
				=MESSAGEBOX("Done! This Handle is Enabled and Visible.",0 64,"Tips")
			ELSE
				=MESSAGEBOX("输入Handle有误!" CHR(13) CHR(13) "请重新输入!",0 64,"Caution Tips")
				this.Value="请输入对应的句柄值"
				this.Refresh
			ENDIF
		ENDIF
	ENDPROC
ENDDefine

标签： d

实例下载地址

DBF程序(VFP)

不能下载？内容有错？ 点击这里报错 + 投诉 + 提问

好例子网口号：伸出你的我的手 — 分享！

相关软件

相关文章

网友评论

我要评论

发表评论

(您的评论需要经过审核才能显示)

查看所有0条评论>>

小贴士

感谢您为本站写下的评论，您的评论对其它用户来说具有重要的参考价值，所以请认真填写。

  • 类似“顶”、“沙发”之类没有营养的文字，对勤劳贡献的楼主来说是令人沮丧的反馈信息。
  • 相信您也不想看到一排文字/表情墙，所以请不要反馈意义不大的重复字符，也请尽量不要纯表情的回复。
  • 提问之前请再仔细看一遍楼主的说明，或许是您遗漏了。
  • 请勿到处挖坑绊人、招贴广告。既占空间让人厌烦，又没人会搭理，于人于己都无利。

关于好例子网

本站旨在为广大IT学习爱好者提供一个非营利性互相学习交流分享平台。本站所有资源都可以被免费获取学习研究。本站资源来自网友分享，对搜索内容的合法性不具有预见性、识别性、控制性，仅供学习研究，请务必在下载后24小时内给予删除，不得用于其他任何用途，否则后果自负。基于互联网的特殊性，平台无法对用户传输的作品、信息、内容的权属或合法性、安全性、合规性、真实性、科学性、完整权、有效性等进行实质审查；无论平台是否已进行审查，用户均应自行承担因其传输的作品、信息、内容而可能或已经产生的侵权或权属纠纷等法律责任。本站所有资源不代表本站的观点或立场，基于网友分享，根据中国法律《信息网络传播权保护条例》第二十二与二十三条之规定，若资源存在侵权或相关问题请联系本站客服人员，点此联系我们。关于更多版权及免责申明参见 版权及免责申明

;
报警