神马文学网vfp 全面总结（精华）（上）
来源：百度文库 编辑：神马文学网 时间：2024/04/28 14:55:22
设置该控件dragmode自动模式 ***************************应用程序环境配置文件config.fpw
应用程序环境配置文件config.fpw在程序连编时是可选的,也就是可要可不要,它保存的是一些vfp系统设置.如果存在,VFP启动时会去读取;如果没有,系统会设定默认值. 代码中建-----默认存入格式.prg ------文件夹中修改后缀为：config.fpw********************************* 表单设置背景图片pictrue属性 stretch属性值=2 ********************************* 一种加密和解密算法 JM.PRG (C)Copyright 2006-2006
* 加密: ?JM("文件名.DBF",88) &&返回.T.为成功
* 解密: ?JM("文件名.DBF",-88) &&返回.T.为成功
* 作者: Tiger5392
* 时间: 2006.06.11
PARAMETERS cFileName,nNumber
PRIVATE cFileName,nNumber,A,B,D
nHandle=FOPEN(cFileName,2)
IF nHandle<>-1
DIMENSION D(1)
ADIR(D,cFileName)
FOR I=1 TO D(1,2)
A=FREAD(nHandle,1)
B=CHR(MOD(ASC(a)+nNumber,256))
FSEEK(nHandle,I)
FWRITE(nHandle,B)
ENDFOR
FCLOSE(nHandle)
RETURN .T.
ELSE
RETURN .F.
ENDIF**************************************************
* 查找问题
seek for locatefor *用found() 测试结果 联合使用if found()=.t............****************************************************** 测试文件值类型Case Vartype(ThisForm.Text1.Value)='' && c、n。。。***************************************************** 分级设置权限方法*主菜单都是执行一些具体功能的子表单，不想让普通用户组使用的命令，就用skip for屏蔽 就是我上面说的那种
*有些子表单，普通用户也可以用，但上面有些按钮，只能管理员才能用的，就在子表单的init中判断
*将不能让普通用户点的，enabled=.f.或直接visible=.f.
*就这些。。。。 set exact on
thisform.i=thisform.i+1 &&这句是今天新学到的，用于标识试图登录的次数
select user &&当然是打开数据环境对应的账号信息表
locate for alltrim(账号)=alltrim(thisform.txt账号.value)
if found() and alltrim(密码)=alltrim(thisform.txt密码.value) &&说明找到了用户名，并且密码与名对应
if 级别="管理员"
bsadmin="sysadmin"
else
bsadmin="" &&仍然等到空，可以根据此扩充为二级权限管理员，三级权限。。
endif
do form 主表单
thisform.release
else
if thisform.i<3 &&试图登录三次以内
重输账号、密码
else
三次都错，clear events，quit
endif
endif
set exact off
************************************************ 设置该控件dragmode自动模式 *************************** 应用程序环境配置文件config.fpw 应用程序环境配置文件config.fpw在程序连编时是可选的,也就是可要可不要,它保存的是一些vfp系统设置.如果存在,VFP启动时会去读取;如果没有,系统会设定默认值. 代码中建-----默认存入格式.prg ------文件夹中修改后缀为：config.fpw ******************************** * 表单设置背景图片 pictrue属性 stretch属性值=2 ******************************** * 一种加密和解密算法 JM.PRG (C)Copyright 2006-2006 * 加密: ?JM("文件名.DBF",88) &&返回.T.为成功 * 解密: ?JM("文件名.DBF",-88) &&返回.T.为成功 * 作者: Tiger5392 * 时间: 2006.06.11 PARAMETERS cFileName,nNumber PRIVATE cFileName,nNumber,A,B,D nHandle=FOPEN(cFileName,2) IF nHandle<>-1 DIMENSION D(1) ADIR(D,cFileName) FOR I=1 TO D(1,2) A=FREAD(nHandle,1) B=CHR(MOD(ASC(a)+nNumber,256)) FSEEK(nHandle,I) FWRITE(nHandle,B) ENDFOR FCLOSE(nHandle) RETURN .T. ELSE RETURN .F. ENDIF ************************************************** * 查找问题 seek for locatefor *用found() 测试结果 联合使用 if found()=.t. ........... ***************************************************** * 测试文件值类型 Case Vartype(ThisForm.Text1.Value)='' && c、n。。。 **************************************************** * 分级设置权限方法 *主菜单都是执行一些具体功能的子表单，不想让普通用户组使用的命令，就用skip for屏蔽 就是我上面说的那种 *有些子表单，普通用户也可以用，但上面有些按钮，只能管理员才能用的，就在子表单的init中判断 *将不能让普通用户点的，enabled=.f.或直接visible=.f. *就这些。。。。 set exact on thisform.i=thisform.i+1 &&这句是今天新学到的，用于标识试图登录的次数 select user &&当然是打开数据环境对应的账号信息表 locate for alltrim(账号)=alltrim(thisform.txt账号.value) if found() and alltrim(密码)=alltrim(thisform.txt密码.value) &&说明找到了用户名，并且密码与名对应 if 级别="管理员" bsadmin="sysadmin" else bsadmin="" &&仍然等到空，可以根据此扩充为二级权限管理员，三级权限。。 endif do form 主表单 thisform.release else if thisform.i<3 &&试图登录三次以内 重输账号、密码 else 三次都错，clear events，quit endif endif set exact off ************************************************ *检验断断续续出现的错误的原因. 用以下代码创建一个叫做 *Errutil.prg 和程序. ON ERROR DO errhand IN errutil ; WITH SYS(0), ERROR(), MESSAGE(), MESSAGE(1), ; PROGRAM(), LINENO(1), DBF(), DATE(), TIME() * 错误捕捉设置结束. PROCEDURE errhand PARAMETER m.machine, m.messgnum, m.messg, m.linecode, ; m.callprog, m.inline, m.OPENTABL, m.errdate, ; m.errtime m.errspace=SELECT() && 保存当前工作区. m.errorder=ORDER() && 保存当前排序. IF LEN(ALLTRIM(m.callprog))=0 m.callprog="Command Line" STORE SPACE(0) TO m.linecode ENDIF outmsgline="错误 ; "+m.messg+CHR(13)+"行号 "+STR(m.inline)+ ; CHR(13)+ ; "程序名 = "+m.callprog+CHR(13)+"语法 :"+m.linecode * Visual FoxPro 用户使用 =MESSAGEBOX(outmsgline,32+0) * FoxPro For Windows 用户使用 Foxtools.fll 中的 MsgBox() 函数 WAIT WINDOW outmsgline TIMEOUT 5 && 所有版本均可使用该语法. IF !USED("ERRORLOG") IF FILE("ERRORLOG.DBF") SELECT 0 USE errorlog ELSE SELECT 0 thisversion=VERSION() IF LEFT(ALLTRIM(thisversion),6)="Visual" * 为 Visual FoxPro 版本创建一个自由表 CREATE TABLE errorlog FREE (machine c(20), messgnum N(4,0), ; messg c(70), linecode c(70), callprog c(40), ; inline N(6,0), OPENTABL c(25), errdate d, errtime c(8)) ELSE CREATE TABLE errorlog (machine c(20), messgnum N(4,0), ; messg c(70), linecode c(70), callprog c(40), ; inline N(6,0), OPENTABL c(25), errdate d, errtime c(8)) ENDIF ENDIF ENDIF INSERT INTO errorlog FROM MEMVAR SELECT errorlog && 选择 errorlog 表. USE && 关闭 errorlog 表. SELECT (m.errspace) && 返回到保存的工作区. IF !EMPTY(ALIAS()) SET ORDER TO (m.errorder) ENDIF RELEASE ALL LIKE m.messgnum, m.messg, m.linecode, m.callprog, ; m.inline RETURN 用以下代码创建一个名为 Ztest.prg 的程序: DO errutil && 激活 Errutil.prg 中的 ON ERROR 例程. USE c:\noexist.dbf && 因为该文件尚不存在因此会发生错误 DO C:\noexist.prg ON ERROR && 关闭活动的 ON ERROR 例程. 在 Visual FoxPro 命令窗口中打入以下命令: Do ZTest.prg. 两个 Wait 窗口显示出不愉快的错误代码行. 这些信息被放入 Errorlog.dbf 文件中. 5 秒钟后窗口消失. 激活命令窗口, 然后打开并浏览 Errorlog 表.
************************************************ * set path to 和 set default to 区别1. set default to 是设置系统默认路径的命令,如:当前程序执行时所在的路径是c:\\temp,但是系统运行后向把系统的默认路径改为d:\\temp时,就执行set defautl to d:\\temp.
2. set path to 是设置系统的文件搜索路径,如:当前程序执行时所在的路径是c:\\temp,但是系统运行后需要某些操作文件(已知这些文件所在的路径,如:d:\\temp.d:\\temp1...),而又不能改变系统运行的默认路径时,就执行set path to d:\\temp,set path to d:\\temp1 ....********************************************* Modal窗口和Modeless窗口有什么区别？
*********************************************** 如何把表单的标题栏移掉
*************************************************** 表单启动后的事件执行顺序DataEnvironment.BeforeOpenTables()
Form.Load()
DataEnvironment.Init()
Form.Container1.Contol1.Init()
Form.Container1.Control2.Init()
Form.Container1.Init()
******************************************************* 程序自动设定路径？
*-- If we are running MAIN.PRG directly, then
*-- CD up to the parent directory
IF RIGHT(lcProgram, 3) = "FXP"
CD ..
ENDIF
SET PATH TO PROGS, FORMS, LIBS, ;
MENU, DATA, ;
REPORTS, INCLUDE, HELP, ;
BITMAPS
SET CLASSLIB TO MAIN ,vfptool
ENDFUNC
******************************************************--锁定数据库do while !rlock() && 锁定数据库
wait window '正在锁定数据库请稍候！' Timeout 0.05
enddo
repl kcl with kcl-sp.sl && 更新数据
unlock in mjsm_temp && 解锁数据库 *****************************************************
* -- 取得卷（磁盘）信息
DECLARE INTEGER GetVolumeInformation IN WIN32API STRING @cRooDirectory ,STRING @cVolume, INTEGER nVolumeSize, ;
INTEGER @nSerialNo, INTEGER @nMaxFileNameLen, INTEGER @nFileSystemFlags, STRING @cFileSystemName, ;
INTEGER nFileSystemNameSize******************************************************
* --- 设置卷标
DECLARE INTEGER SetVolumeLabel IN WIN32API STRING cRootPathName, STRING cVolumeNamecRooDirectory = "C:\"
cVolume = SPACE(255)
nVolumeSize = 255
nSerialNo = 0
nMaxFileNameLen = 0
nFileSystemFlags = 0
cFileSystemName = SPACE(255)
nFileSystemNameSize = 255nOk = GetVolumeInformation(@cRooDirectory , @cVolume, nVolumeSize,@nSerialNo, @nMaxFileNameLen, @nFileSystemFlags, ;
@cFileSystemName,nFileSystemNameSize)
*IF nOk > 0
"cVolume =", cVolume
"nSerialNo =", LEFT(SUBSTR(TRANSFORM(nSerialNo, "@0X"), 3), 4) + "-" +RIGHT(SUBSTR(TRANSFORM(nSerialNo, "@0X"), 3), 4)
"nMaxFileNameLen = ", nMaxFileNameLen
"nFileSystemFlags = ", nFileSystemFlags
"cFileSystemName =",cFileSystemName
*ELSE
"Read Error=", nOk
*ENDIF
*? SetVolumeLabel("C:\", "WINDOWS_98")
*? SetVolumeLabel("A:\", "WINDOWS_98")
or(1).dir>xxx.txt
(2)
handle = fopen("xxx.txt",2)
s = fget(handle,10) ****************************************************** **--- 如何在一个表单上戳一个（或几个平行）的透明窟窿？--* Program Name : MakeTransparentHole.Prg
* Article No. : [Win API] - 001
* Illustrate : 如何在一个表单上戳一个（或几个平行）的透明窟窿？
* Date / Time : 2001.09.09 / 16:00
* Writer :
* 1st Post :
********************************************************
PUBLIC frm
frm = CreateObject ("Tform")
frm.Visible = .T.
* end of mainDEFINE CLASS Tform As Form
Width = 500
Height = 300
AutoCenter = .T.
BackColor = Rgb(192,224,192)
Caption = "如何在一个表单上戳一个（或几个平行）的透明窟窿" ADD OBJECT lbl1 As Tlabel WITH Caption="她初看是一个 Form 上的 Shapes，...", Left=10, Top=10
ADD OBJECT lbl2 As Tlabel WITH Caption="...但它们确实是一个洞，在背后可以放置东西。", Left=20, Top=150 PROCEDURE Load
THIS.decl
ENDPROC PROCEDURE Resize
*THIS.RemoveRegions && does not make any difference
ThisForm.ApplyRegions
ENDPROC PROCEDURE Activate
ThisForm.ApplyRegions
ENDPROC PROCEDURE RemoveRegions
= SetWindowRgn (GetFocus(), 0, 1)
ENDPROC PROCEDURE ApplyRegions
#DEFINE RGN_AND 1
#DEFINE RGN_OR 2
#DEFINE RGN_XOR 3
#DEFINE RGN_DIFF 4
#DEFINE RGN_COPY 5
#DEFINE radius 84
#DEFINE interspace 12 LOCAL hRgnBase, hRgn, hwnd, x0,y0,x1,y1
DIMEN hRgnExclude [5] && an array to store elliptical regions * create a rectangle region
* and set it by the rectangle of the form
hRgn = CreateRectRgn (0,0,1,1)
hwnd = GetFocus() && get window handle for the form
THIS.GetRect (hwnd, @x0,@y0,@x1,@y1)
hRgnBase = CreateRectRgn (0,0,x1-x0,y1-y0) x0 = 20
y0 = 70
y1 = y0 + radius
* create several elliptical regions
FOR ii=1 TO 5
hRgnExclude[ii] = CreateEllipticRgn (x0,y0, x0+radius,y1)
x0 = x0 + radius + interspace
ENDFOR
* combine elliptical regions into one region
= CombineRgn (hRgn, hRgnExclude[1], hRgnExclude [2], RGN_OR)
= CombineRgn (hRgn, hRgn, hRgnExclude [3], RGN_OR)
= CombineRgn (hRgn, hRgn, hRgnExclude [4], RGN_OR)
= CombineRgn (hRgn, hRgn, hRgnExclude [5], RGN_OR)
* subtract the resulting region
* from the region defined by the rectangle of the form
= CombineRgn (hRgn, hRgnBase, hRgn, RGN_XOR)
* apply final region to the form
= SetWindowRgn (hwnd, hRgn, 1)
* free system resources
= DeleteObject (hRgn)
FOR ii=1 TO 5
= DeleteObject (hRgnExclude[ii])
ENDFOR
= DeleteObject (hRgnBase)
ENDPROC PROCEDURE GetRect (hwnd, x0,y0,x1,y1)
LOCAL lpRect
lpRect = SPACE (16) = GetWindowRect (hwnd, @lpRect)
x0 = THIS.buf2dword (SUBSTR(lpRect, 1,4))
y0 = THIS.buf2dword (SUBSTR(lpRect, 5,4))
x1 = THIS.buf2dword (SUBSTR(lpRect, 9,4))
y1 = THIS.buf2dword (SUBSTR(lpRect, 13,4))
ENDPROC FUNCTION buf2dword (lcBuffer)
RETURN Asc(SUBSTR(lcBuffer, 1,1)) + Asc(SUBSTR(lcBuffer, 2,1)) * 256 + Asc(SUBSTR(lcBuffer, 3,1)) * 65536 + Asc(SUBSTR(lcBuffer, 4,1)) * 16777216
ENDFUNC PROCEDURE decl
DECLARE INTEGER CreateEllipticRgn IN gdi32 INTEGER nLeftRect, INTEGER nTopRect, INTEGER nRightRect, INTEGER nBottomRect
DECLARE INTEGER CreateRectRgn IN gdi32 INTEGER nLeftRect, INTEGER nTopRect, INTEGER nRightRect, INTEGER nBottomRect
DECLARE INTEGER CombineRgn IN gdi32 INTEGER hrgnDest, INTEGER hrgnSrc1, INTEGER hrgnSrc2, INTEGER fnCombineMode
DECLARE SetWindowRgn IN user32 INTEGER hWnd, INTEGER hRgn, SHORT bRedraw
DECLARE SHORT GetWindowRect IN user32 INTEGER hwnd, STRING @ lpRect
DECLARE INTEGER DeleteObject IN gdi32 INTEGER hObject
DECLARE INTEGER GetFocus IN user32
ENDPROC
ENDDEFINEDEFINE CLASS Tlabel As Label
FontName="System"
FontSize=18
AutoSize=.T.
BackStyle=0
ENDDEFINE
************************************************************************---- 如何生成世界上唯一的 64 位 ID？--* Program Name : OnlyID.Prg
* Article No. : [Win API] - 003
* Illustrate : 如何生成世界上唯一的 64 位 ID？
* Date / Time : 2001.09.09 / 18:00
* Writer :
* 1st Post :
***********************************************************************
LOCAL lcRetval, lcStruc_GUID, lcGUID, lnSize
DECLARE INTEGER CoCreateGuid IN "ole32.dll" STRING @lcGUIDStruc
DECLARE INTEGER StringFromGUID2 IN "ole32.dll" STRING cGUIDStruc, STRING @cGUID, LONG nSize* Create a GUID-structure
lcStruc_GUID = REPLICATE(" ", 16)
lcGUID = REPLICATE(" ", 80)
lnSize = LEN(lcGUID) / 2
* Pass the structure to the API function so that it creates a new ID
IF CoCreateGuid(@lcStruc_GUID) <> 0
RETURN ""
ENDIF
* Convert the structure to a string that we can use in VFP
IF StringFromGUID2(lcStruc_GUID, @lcGuid, lnSize) = 0
RETURN ""
ENDIF
STRCONV(LEFT(lcGUID, 76), 6)
RETURN STRCONV(LEFT(lcGUID, 76), 6)
**---- 如何使用和调用 Win32 的 GetUserName API？--* Program Name : GetUserID.Prg
* Article No. : [Win API] - 002
* Illustrate : 如何使用和调用 Win32 的 GetUserName API？
* Date / Time : 2001.09.09 / 17:00
* Writer :
* 1st Post :
*
Public lpUserIDBuffer, nBufferSize, RetVal
RetVal = 0
lpUserIDBuffer = SPACE(25) && Return buffer for user ID string
nBufferSize = 25 && Size of user ID return bufferDeclare INTEGER GetUserName IN Win32API AS GetName STRING @lpUserIDBuffer, INTEGER @nBufferSize
RetVal=GetName(@lpUserIDBuffer, @nBufferSize)
Define WINDOW ShowInfo FROM 0,0 TO 5,70 FLOAT CLOSE TITLES "User ID Information" FONT "System",12
Activate WINDOW ShowInfo
Move WINDOW ShowInfo CENTER
@ 0,1 SAY "User ID : " + LEFT(lpUserIDBuffer,nBufferSize-1)*******************************************************************
** -- Parameters: lcWindCaption - 应用程序窗口标题--
*******************************************************************Function TestAppRun
LPARAMETER lcWindCaption
IF TYPE('lcWindCaption') # 'C' OR EMPTY(lcWindCaption)
RETURN .F.
ENDIF
LOCAL GetWind, wclass, apphand
SET LIBRARY TO foxtools.fll ADDITIVE
GetWind = RegFn("FindWindow", "CC", "I")
wclass=0
apphand=CallFn(GetWind,wclass ,lcWindCaption)IF apphand # 0
RETURN .F.
ENDIF
RETURN .T.*******************************************************************
**--数值转换成人民币大写格式--
*Programmer:Craftsman
*2001.10.18cUnit="仟佰拾万仟佰拾圆角分"
cChar=""
If Vartype(This.Input)<>"N"
Messagebox("请确认数据类型",48,"警告")
Else
cInput=Chrtran((Ltrim(Str(This.Input,20,2))),".","")
If This.Input<=0 or Len(cInput)>10
Messagebox("您输入的数值可能存在以下问题："+Chr(13);
+"1、输入的数值太大(最大处理值：99999999.99)"+Chr(13);
+"2、输入的数值小于或等于零",48,"警告")
Else
For N=1 to Len(cInput)
If Val(Substr(Right(cInput,N),1,1))>0
cChar=Stuffc(cUnit,11-N,0,Substr("0零1壹2贰3叁4肆5伍6陆7柒8
捌9玖",At(Substr(Right(cInput,N),1,1),"0零1壹2贰3叁4肆5伍6陆7柒8捌9玖
")+1,2))
Else
Do Case
Case N=1
cChar=Stuffc(cUnit,11-N,1,"整")
Case N=2cChar=Iif(Val(Substr(Right(cInput,N-1),1,1))>0,Stuffc(cUnit,11-N,1,"零
"),Stuffc(cUnit,11-N,1,""))
Case N=3 or N=7
Loop
OtherwisecChar=Iif(Val(Substr(Right(cInput,N+1),1,1))=0,Stuffc(cUnit,11-N,1,""),Stuff
c(cUnit,11-N,1,"零"))
Endcase
Endif
cUnit=cChar
Endfor
cChar=Substrc(cChar,11-Len(cInput))
cChar=Iif("零万"$cChar,Stuffc(cChar,At_c("零万",cChar),2,"万"),cChar)
cChar=Iif(Substr(Right(cInput,6),1,1)="0" And
Substr(Right(cInput,7),1,1)="0",Stuffc(cChar,At_c("万",cChar)+1,0,"零
"),cChar)
cChar=Iif("零圆"$cChar,Stuffc(cChar,At_c("零圆",cChar),2,"圆"),cChar)
This.Output=cChar
Endif
Endiforprocedure Camount
parameter Mamount
MyAmount=alltrim(str(abs(Mamount)*100,11,0))
temp=len(alltrim(MyAmount))
chr_amount=''
For i = 1 TO temp
MYmemo=val(subs(MyAmount, temp-i+1, 1))
chr_amount =subs("零壹贰叁肆伍陆柒捌玖", MYmemo*2+1, 2)+subs("分角圆拾佰仟
万拾佰仟亿", i*2-1, 2)+ chr_amount
EndFor
chr_amount=iif(Mamount<0,'负'＋chr_amount,chr_amount)
chr_amount
return chr_amount*******************************************************************--这个Prncode.zap程序全部使用Visual Foxpro编写，用于VFP表单文件(SCX)或类库文件(VCX)过程源码查看及打印。运行于VFP环境或安装了VFP6运行时刻系统中。 说明：
1.在"打开"窗口中，选择打开表单(SCX)或类库(VCX)类型，打开文件。
2.选择"按对象"查看方式时，可把同一对象的过程显示在文本框中；选择"按过程"查看方式时，仅显示一个指定过程。
3.选择组合框内容，随查看方式不同，列表出打开文件的中包含的对象集或所有过程。
4.通过"保存"或"另存为"功能按钮，可以将文本框内容保存为文本文件。
5.通过"预览"或"打印"功能按钮，可以将文本框内容打印到屏幕或打印机中。
6.已打开源文件名称显示窗口标题中，底部标签中显示是保存文本文件名称。
7.运行于VFP环境时，执行"startapp.app"可把本程序加入工具菜单中，如果在选项窗口中，把"startapp.app"设置为启动程序，那它真的就是一个系统工具了。
8.这个小程序意在为初学者，提供一编程示例，也是VFP爱好者的一个实用小工具。您可以根据需要进行修改完善。
* Program Name : VolumeInformation.Prg
* Article No. : [Win API] - 029
* Illustrate : 常用卷标信息
* Date / Time : 2001.09.27
* Writer :
* 1st Post :
* My Comment : 需要 Win32VFP.Dll 库支持，见附件。*****************************************************************#Define FILE_CASE_SENSITIVE_SEARCH 1
#Define FILE_CASE_PRESERVED_NAMES 2
#Define FILE_UNICODE_ON_DISK 4
#Define FILE_PERSISTENT_ACLS 8
#Define FILE_FILE_COMPRESSION 16
#Define FILE_VOLUME_IS_COMPRESSED 32768 && &H8000Declare INTEGER GetLastError IN kernel32
Declare INTEGER intAnd IN win32vfp INTEGER nInt0, INTEGER nInt1Declare SHORT GetVolumeInformation IN kernel32;
STRING lpRootPathName,;
STRING @ lpVolumeNameBuffer,;
INTEGER nVolumeNameSize,;
INTEGER @ lpVolumeSerialNumber,;
INTEGER @ lpMaximumComponentLength,;
INTEGER @ lpFlags,;
STRING @ lpFileSystemNameBuffer,;
INTEGER nFileSystemNameSizelpRootPathName = "C:\" && check the slash, or "D:\", "E:\"....nVolumeNameSize = 250
lpVolumeNameBuffer = SPACE (nVolumeNameSize)
lpVolumeSerialNumber = 0
lpMaximumComponentLength = 0
lpFlags = 0
nFileSystemNameSize = 250
lpFileSystemNameBuffer = SPACE(nFileSystemNameSize)lnResult = GetVolumeInformation (lpRootPathName, @lpVolumeNameBuffer,;
nVolumeNameSize, @lpVolumeSerialNumber,;
@lpMaximumComponentLength, @lpFlags,;
@lpFileSystemNameBuffer,nFileSystemNameSize )If lnResult = 1
* display parameters returned
lpVolumeNameBuffer = LEFT(lpVolumeNameBuffer,;
AT(Chr(0),lpVolumeNameBuffer)-1)
"Volume Name: [", lpVolumeNameBuffer, "]" "Volume Serial Number: ", lpVolumeSerialNumber
"Max Filename Length: ", lpMaximumComponentLength "File System Flags: ", lpFlags
= displayFlag (lpFlags, FILE_CASE_SENSITIVE_SEARCH,;
"Case-sensitive file names support: ") = displayFlag (lpFlags, FILE_CASE_PRESERVED_NAMES,;
"The file system preserves the case of file names: ") = displayFlag (lpFlags, FILE_UNICODE_ON_DISK,;
"Unicode in file names support: ") = displayFlag (lpFlags, FILE_PERSISTENT_ACLS,;
"ACLs support: ") = displayFlag (lpFlags, FILE_FILE_COMPRESSION,;
"File-based compression support: ") = displayFlag (lpFlags, FILE_VOLUME_IS_COMPRESSED,;
"The specified volume is a compressed volume: ") lpFileSystemNameBuffer = LEFT(lpFileSystemNameBuffer,;
AT(Chr(0),lpFileSystemNameBuffer)-1)
"File System Name: [", lpFileSystemNameBuffer, "]"
Else
* 3 - The system cannot find the path specified = ERROR_PATH_NOT_FOUND
* 21 - The device is not ready = ERROR_NOT_READY
"Error code: ", GetLastError()
EndifProcedure displayFlag (lnFlags, lnMask, lcCaption)
lcResult = IIF (intAnd(lnFlags, lnMask) = lnMask, "Yes", "No")
" - ", lcCaption, lcResult
Return* Program Name : EllipticalForm.Prg
* Article No. : [Win API] - 028
* Illustrate : 椭圆型表单
* Date / Time : 2001.09.27
* Writer : Tuberose zyg8108@21cn.com
* 1st Post : News://news.newsfan.net/计算机.软件.数据库.VfpPublic frm
frm = CreateObject ("Tform")
frm.Visible = .T.
ReturnDefine CLASS Tform As Form
#Define horizDiameter 400
#Define vertDiameter 260 Caption = "椭圆型表单"
Width = 600
Height = 350
AutoCenter = .T.
MaxButton = .F.
MinButton = .F.
hRgn = 0
hwind = 0 Add OBJECT cmd As CommandButton WITH;
Width=80, Height=25, FontName='System', Caption="执行" Procedure Load
This.decl
Endproc Procedure Init
With THIS.cmd
.Top = THIS.Height - .Height - 15
.Left = (THIS.Width - .Width)/2
Endwith
Endproc Procedure cmd.Click
Thisform.TimeConsumingProc
Endproc Procedure TimeConsumingProc
* this is an emulation of a time consuming process
* while it is running the form is limited to an ellipse
Clear* limit the form to an ellipse
* defined by a region
This.regionOn
Local ii, jj
For ii=1 TO 10
Create CURSOR cs (id N(6), dt decl) "Inserting records to cursor... " For jj=1 TO 100
Insert INTO cs VALUES (jj, DATE()-jj)
DATE()-jj, ", "
Endfor
* DOEVENTS "Indexing cursor... " Index ON id TAG id
Index ON dt TAG dt
* DOEVENTS Use IN cs
"Ok | "
Endfor This.regionOff && restore the form to its original state
This.cmd.Visible = .T.
Endproc Procedure regionOn
* create an elliptical region and apply it to the form
Local x0,y0,x1,y1
x0 = (THIS.Width - horizDiameter)/2
y0 = (THIS.Height - vertDiameter)/2
x1 = x0 + horizDiameter
y1 = y0 + vertDiameter This.hwind = GetFocus()
This.hRgn = CreateEllipticRgn (x0,y0,x1,y1)
= SetWindowRgn (THIS.hwind, THIS.hRgn, 1)
Endproc Procedure regionOff
* release a region for this form
= SetWindowRgn (THIS.hwind, 0, 1)
Endproc Procedure decl
Declare INTEGER CreateEllipticRgn IN gdi32;
INTEGER nLeftRect,;
INTEGER nTopRect,;
INTEGER nRightRect,;
INTEGER nBottomRect Declare SetWindowRgn IN user32;
INTEGER hWnd,;
INTEGER hRgn,;
SHORT bRedraw Declare INTEGER GetFocus IN user32
Endproc
Enddefine **************************************************************** Program Name : WinCalc.Prg
* Article No. : [Win API] - 027
* Illustrate : 计算器
* Date / Time : 2001.09.27
* Writer :
* 1st Post : ***************************************************************Private frm
frm = CreateObject ("Tform")
frm.Show (1)Define CLASS Tform As Form
Width = 400
Height = 200
AutoCenter = .T.
Caption = "Accessing WinCalc Window" Add OBJECT cmdShow As Tbutton
Add OBJECT cmdHide As Tbutton Procedure Init
This.cmdShow.caption = "Show Calc"
This.cmdHide.caption = "Hide Calc"
This._resize
This.decl
Endproc Procedure cmdShow.click
Thisform._show
Endproc Procedure cmdHide.click
Thisform._hide
Endproc Procedure _resize
With THIS.cmdHide
.top = THIS.height - .height - 10
.left = THIS.width - .width - 10
Endwith
With THIS.cmdShow
.top = THIS.cmdHide.top
.left = THIS.cmdHide.left - .width - .3
Endwith
Endproc Protected PROCEDURE decl
Declare INTEGER SetForegroundWindow IN "user32" INTEGER hwnd Declare INTEGER FindWindow IN user32;
STRING lpClassName,;
STRING lpWindowName Declare INTEGER WinExec IN kernel32;
STRING lpCmdLine, INTEGER nCmdShow Declare SHORT PostMessage IN user32;
INTEGER hWnd,;
INTEGER Msg,;
STRING @ wParam,;
INTEGER lParam
Endproc Procedure _show
#Define SW_SHOWNORMAL 1
Local hwnd
HWnd = FindWindow (.NULL., "Calculator")
If hwnd = 0
= WinExec ("calc.exe", SW_SHOWNORMAL)
Else
= SetForegroundWindow (hwnd)
Endif
Endproc Procedure _hide
#Define WM_QUIT 18
Local hwnd
HWnd = FindWindow (.NULL., "Calculator")
If hwnd <> 0
= PostMessage (hwnd, WM_QUIT, 0,0)
Endif
Endproc
EnddefineDefine CLASS Tbutton As CommandButton
FontName = 'System'
Height = 24
Width = 100
Enddefine***************************************************************** Program Name : LocaleRecord.Prg
* Article No. : [Win API] - 026
* Illustrate : 获得系统中的所有国家/地区信息
* Date / Time : 2001.09.25
* Writer :
* 1st Post :
* My Comment :* some LCTYPE constants
#DEFINE LOCALE_ILANGUAGE 1 && language id
#DEFINE LOCALE_SLANGUAGE 2 && localized name of language
#DEFINE LOCALE_SENGLANGUAGE 4097 && English name of language
#DEFINE LOCALE_SABBREVLANGNAME 3 && abbreviated language name
#DEFINE LOCALE_SNATIVELANGNAME 4 && native name of language
#DEFINE LOCALE_ICOUNTRY 5 && country code
#DEFINE LOCALE_SCOUNTRY 6 && localized name of country
#DEFINE LOCALE_SENGCOUNTRY 4098 && English name of country
#DEFINE LOCALE_SABBREVCTRYNAME 7 && abbreviated country name
#DEFINE LOCALE_SNATIVECTRYNAME 8 && native name of country
#DEFINE LOCALE_IDEFAULTLANGUAGE 9 && default language id
#DEFINE LOCALE_IDEFAULTCOUNTRY 10 && default country code
#DEFINE LOCALE_IDEFAULTCODEPAGE 11 && default oem code page
#DEFINE LOCALE_IDEFAULTANSICODEPAGE 4100 && default ansi code page
#DEFINE LOCALE_IDEFAULTMACCODEPAGE 4113 && default mac code page#DEFINE LOCALE_ILDATE 34 && long date format ordering
#DEFINE LOCALE_ILZERO 18 && leading zeros for decimal
#DEFINE LOCALE_IMEASURE 13 && 0 = metric, 1 = US
#DEFINE LOCALE_IMONLZERO 39 && leading zeros in month field
#DEFINE LOCALE_INEGCURR 28 && negative currency mode
#DEFINE LOCALE_INEGSEPBYSPACE 87 && mon sym sep by space from neg
amt
#DEFINE LOCALE_INEGSIGNPOSN 83 && negative sign position
* more constants exist... DECLARE INTEGER GetLocaleInfo IN kernel32;
INTEGER Locale,;
INTEGER LCType,;
STRING @ lpLCData,;
INTEGER cchData CREATE CURSOR cs (;
locale N(6),;
langid C( 4),;
llnagname C(30),;
elangname C(30),;
alangname C( 3),;
nlangname C(30),;
ccode C( 3),;
lcname C(30),;
ecname C(30),;
acname C( 3),;
ncname C(30),;
dlangid C( 4),;
dccode C( 3),;
doemcp C( 5),;
dansicp C( 5),;
dmaccp C( 5),;
ldtfmt C( 2),;
ldzeros C( 2),;
metrics C( 2),;
monzero C( 2),;
necurr C( 2),;
negsep C( 2),;
negsign C( 2);
) * scan top &H10000 codes
* under WinNT 4.0 it returns 138 records
* WinMe -- 164 records
FOR ii=0 TO 65535
= saveLInfo (ii)
ENDFOR SELECT cs
GO TOP
BROW NORMAL NOWAIT
RETURN && mainPROCEDURE saveLInfo (lnLocale)
* saves one local record for the locale
IF Len (getLInfo (lnLocale, LOCALE_ILANGUAGE)) = 0
* exit if no information exists for this locale id
RETURN
ENDIF INSERT INTO cs VALUES (;
lnLocale,;
getLInfo (lnLocale, LOCALE_ILANGUAGE),;
getLInfo (lnLocale, LOCALE_SLANGUAGE),;
getLInfo (lnLocale, LOCALE_SENGLANGUAGE),;
getLInfo (lnLocale, LOCALE_SABBREVLANGNAME),;
getLInfo (lnLocale, LOCALE_SNATIVELANGNAME),;
getLInfo (lnLocale, LOCALE_ICOUNTRY),;
getLInfo (lnLocale, LOCALE_SCOUNTRY),;
getLInfo (lnLocale, LOCALE_SENGCOUNTRY),;
getLInfo (lnLocale, LOCALE_SABBREVCTRYNAME),;
getLInfo (lnLocale, LOCALE_SNATIVECTRYNAME),;
getLInfo (lnLocale, LOCALE_IDEFAULTLANGUAGE),;
getLInfo (lnLocale, LOCALE_IDEFAULTCOUNTRY),;
getLInfo (lnLocale, LOCALE_IDEFAULTCODEPAGE),;
getLInfo (lnLocale, LOCALE_IDEFAULTANSICODEPAGE),;
getLInfo (lnLocale, LOCALE_IDEFAULTMACCODEPAGE),;
getLInfo (lnLocale, LOCALE_ILDATE),;
getLInfo (lnLocale, LOCALE_ILZERO),;
getLInfo (lnLocale, LOCALE_IMEASURE),;
getLInfo (lnLocale, LOCALE_IMONLZERO),;
getLInfo (lnLocale, LOCALE_INEGCURR),;
getLInfo (lnLocale, LOCALE_INEGSEPBYSPACE),;
getLInfo (lnLocale, LOCALE_INEGSIGNPOSN);
)
RETURNPROCEDURE getLInfo (lnLocale, lnType)
***************************************************************** retrieves a value for the parameter of lnType for the locale lnLocale
lcBuffer = SPACE(250)
lnLength = GetLocaleInfo (lnLocale, lnType, @lcBuffer, Len(lcBuffer))
RETURN Iif (lnLength > 0, STRTRAN(LEFT(lcBuffer, lnLength-1), Chr(0)), "") ***************************************************************** Program Name : RemoveHistory.Prg
* Article No. : [Win API] - 025
* Illustrate : 清理[开始] -> [文档] 中的 [历史记录]
* Date / Time : 2001.09.25
* Writer :
* 1st Post :
* My Comment : 在 Windows 中运行或打开某些文件时，在[开始] -> [文
* : 档]中会留下[历史记录]，比如你打开了 Readme.Txt or
* : mumu.bmp，因此用该函数可以清楚历史记录。提高安全性。***************************************************************#Define SHARD_PATHA 2
#Define SHARD_PATHW 3
#Define SHARD_PIDL 1Declare SHAddToRecentDocs IN shell32;
INTEGER uFlags,;
STRING @ lpNameDo _clear
= _add ("c:Readme.Txt")
= _add ("c:mumu.bmp")Procedure _clear
* clears Documents list in the Windows Start menu
= SHAddToRecentDocs (SHARD_PATHA, .null.)
ReturnProcedure _add (lpName)*****************************************************************
* adds new item to the Documents list
* it does not check whether this file really exists
= SHAddToRecentDocs (SHARD_PATHA, @lpName)
Return******************************************************************* Program Name : ElapsedTime.Prg
* Article No. : [Win API] - 024
* Illustrate : 计算开机时间
* Date / Time : 2001.09.25
* Writer :
* 1st Post :
* My Comment : 用 Win API 的函数比用 VFP 的计时器控件计算时间
* : 要少开销资源。******************************************************************Declare LONG GetTickCount IN WIN32API
Local lnAPIRetVal, lnHour, lnMin
lnAPIRetVal = GetTickCount()
lnHour = ((lnAPIRetVal / 1000) / 60) / 60
lnMin = MOD(((lnAPIRetVal / 1000) / 60), 60)
Messagebox("你的电脑已运行了: " + ALLTRIM(STR(lnHour)) + " 小时, " + ;
ALLTRIM(STR(lnMin)) + " 分.")******************************************************************* Program Name : TaskBar.Prg
* Article No. : [Win API] - 023
* Illustrate : 隐藏或显示任务条 [TaskBar] 和 [开始] 按钮
* Date / Time : 2001.09.25
* Writer :
* 1st Post :
* My Comment :******************************************************************Messagebox("点击 [确认] 隐藏任务条 [TaskBar]")
HideTaskBar()
Messagebox("点击 [确认] 显示任务条 [TaskBar]")
ShowTaskBar()
If MESSAGEBOX("是否隐藏 '开始' [Start] 按钮? 如果要恢复 '开始' ;
[Start] 按钮，必须重新热启动 [Reboot] !", 36) = 6
RemoveStartButton()
EndifFunction HideTaskBar
Declare LONG FindWindow IN "user32" STRING lpClassName, STRING
lpWindowName
Declare LONG SetWindowPos IN "user32" LONG hWnd, LONG hWndInsertAfter, ;
LONG x, LONG Y, LONG cx, LONG cy, LONG wFlags
#Define WINDOWHIDE 0x80
#Define WINDOWSHOW 0x40
Local lnHandle
lnHandle = FindWindow("Shell_TrayWnd", "")
SetWindowPos(lnHandle, 0, 0, 0, 0, 0, WINDOWHIDE)
EndfuncFunction ShowTaskBar
Declare LONG FindWindow IN "user32" STRING lpClassName, STRING
lpWindowName
Declare LONG SetWindowPos IN "user32" LONG hWnd, LONG hWndInsertAfter, ;
LONG x, LONG Y, LONG cx, LONG cy, LONG wFlags
#Define WINDOWHIDE 0x80
#Define WINDOWSHOW 0x40
Local lnHandle
lnHandle = FindWindow("Shell_TrayWnd", "")
SetWindowPos(lnHandle, 0, 0, 0, 0, 0, WINDOWSHOW)
EndfuncFunction RemoveStartButton
Declare LONG FindWindow IN "user32" STRING lpClassName, STRING
lpWindowName
Declare LONG SendMessage IN "user32" LONG hWnd, LONG wMsg, ;
LONG wParam, LONG lParam
Declare LONG FindWindowEx IN "user32" LONG hWnd1, LONG hWnd2, ;
STRING lpsz1, STRING lpsz2
#Define WM_CLOSE 0x10
SendMessage(FindWindowEx(FindWindow("Shell_TrayWnd", ""), 0x0, ;
"Button", .NULL.), WM_CLOSE, 0, 0)
Endfunc
*************************************************************** [转帖]获取windows版本 * Program....: GETWINVER.PRG
* Author.....: ** Richard G Bean **
* Date.......: April 3, 2000
* Changed on 01/31/02 - Extended for XP+
****************************************************************
&& Don't currently use all these DEFINEs, but could if want to explore Server Versions
#DEFINE VER_PLATFORM_WIN32S 0
#DEFINE VER_PLATFORM_WIN32_WINDOWS 1
#DEFINE VER_PLATFORM_WIN32_NT 2
#DEFINE VER_SERVER_NT 0x80000000
#DEFINE VER_WORKSTATION_NT 0x40000000
#DEFINE VER_NT_WORKSTATION 0x00000001
#DEFINE VER_NT_DOMAIN_CONTROLLER 0x00000002
#DEFINE VER_NT_SERVER 0x00000003
#DEFINE VER_SUITE_SMALLBUSINESS 0x00000001
#DEFINE VER_SUITE_ENTERPRISE 0x00000002
#DEFINE VER_SUITE_BACKOFFICE 0x00000004
#DEFINE VER_SUITE_COMMUNICATIONS 0x00000008
#DEFINE VER_SUITE_TERMINAL 0x00000010
#DEFINE VER_SUITE_SMALLBUSINESS_RESTRICTED 0x00000020
#DEFINE VER_SUITE_EMBEDDEDNT 0x00000040
#DEFINE VER_SUITE_DATACENTER 0x00000080
#DEFINE VER_SUITE_SINGLEUSERTS 0x00000100
#DEFINE VER_SUITE_PERSONAL 0x00000200
#DEFINE VER_SUITE_BLADE 0x00000400
#DEFINE FFFF 0x0000FFFF && 65535
Declare LONG GetVersionEx in WIN32API STRING
STORE 0 to;
dwOSVersionInfoSize,;
dwMajorVersion,;
dwMinorVersion,;
dwBuildNumber,;
dwPlatformId,;
wServicePackMajor,;
wServicePackMinor,;
wSuiteMask,;
wProductType,;
wReserved
szCSDVersion = ""
PId = "(Unknown)"
lczStructure = chr(5*4+127+1+3*2+2*1)+replicate(chr(0), 5*4-1)+space(127)+chr(0);
+replicate(chr(0), 3*2+2*1)
lcReturn = ""
lnResult = GetVersionEx( @lczStructure )
IF lnResult <> 0 && No Error
dwOSVersionInfoSize = asc2BEint(lczStructure, 1, 4)
dwMajorVersion = asc2BEint(lczStructure, 5, 4)
dwMinorVersion = asc2BEint(lczStructure, 9, 4)
dwBuildNumber = BITAND(asc2BEint(lczStructure, 13, 4), FFFF)
dwPlatformId = asc2BEint(lczStructure, 17, 4)
szCSDVersion = ALLTRIM(CHRTRAN(SUBSTR(lczStructure, 21, 128),CHR(0)+CHR(1),""))
IF dwOSVersionInfoSize > 148
wServicePackMajor = asc2BEint(lczStructure, 149, 2)
wServicePackMinor = asc2BEint(lczStructure, 151, 2)
wSuiteMask = asc2BEint(lczStructure, 153, 2)
wProductType = ASC(SUBSTR(lczStructure, 155, 1))
wReserved = ASC(SUBSTR(lczStructure, 156, 1))
ENDIF
DO Case
Case dwPlatformId = VER_PLATFORM_WIN32S
PId = "32s " && "Windows 32s "
Case dwPlatformId = VER_PLATFORM_WIN32_WINDOWS
PId = "95/98 " && "Windows 95/98 "
DO CASE
CASE dwMajorVersion = 4 and dwMinorVersion = 0
PId = "95 " && "Windows 95 "
lcSubVer = SUBSTR(szCSDVersion, 1, 1)
IF INLIST(lcSubVer, "B", "C")
PId = PId + "OSR2 "
ENDIF
CASE dwMajorVersion = 4 and dwMinorVersion = 10
PId = "98 " && "Windows 98 "
lcSubVer = SUBSTR(szCSDVersion, 1, 1)
IF lcSubVer = "A"
PId = PId + "SE "
ENDIF
CASE dwMajorVersion = 4 and dwMinorVersion = 90
PId = "ME " && "Windows ME "
ENDCASE
Case dwPlatformId = VER_PLATFORM_WIN32_NT
PId = "NT " && "Windows NT "
DO CASE
CASE dwMajorVersion <= 4
PId = "NT " && "Windows NT "
CASE dwMajorVersion = 5 and dwMinorVersion = 0
PId = "2000 " && "Windows 2000 "
CASE dwMajorVersion = 5 and dwMinorVersion = 1
PId = "XP " && "Windows XP "
IF BITAND(wSuiteMask, VER_SUITE_PERSONAL) <> 0
PId = PId + "Home "
ELSE
PId = PId + "Pro "
ENDIF
ENDCASE
ENDCASE
lcReturn = PId ;
+ ALLTRIM(transform(dwMajorVersion,"99999"));
+ "." + ALLTRIM(transform(dwMinorVersion,"99999"));
+ " (Build "+ ALLTRIM(transform(dwBuildNumber,"99999"));
+ ":"+ IIF(EMPTY(szCSDVersion),"No SP", szCSDVersion);
+ ")"
ENDIF
RETURN lcReturn
******************************************************************
**!* EOP: GETWINVER.PRG
* Program....: ASC2BEINT.PRG
* Author.....: ** Richard G Bean **
* Date.......: April 3, 2000
* Abstract...: Ascii String to BigEndian Integer (i.e. Most significant byte on right)
* (use asc2int() for LittleEndian)
* Doesn't return negative numbers
* RETURN -1 if any error
* Changes....:
*******************************************************************
*FUNCTION asc2BEint
LPARAMETERS p_cString, p_nStart, p_nLength
IF PCOUNT() < 1 OR VARTYPE(p_cString) <> "C"
RETURN -1
ENDIF
IF PCOUNT() < 2 OR VARTYPE(p_nStart) <> "N"
p_nStart = 1
ENDIF
IF PCOUNT() < 3 OR VARTYPE(p_nLength) <> "N"
p_nLength = LEN(p_cString)
ENDIF
LOCAL lnRet_val
DO CASE
CASE p_nLength = 1
lnRet_val = asc(SUBSTR(p_cString, p_nStart, 1))
CASE p_nLength = 2
lnRet_val = asc(SUBSTR(p_cString, p_nStart, 1));
+ asc(SUBSTR(p_cString, p_nStart+1, 1))*256
CASE p_nLength = 3
lnRet_val = asc(SUBSTR(p_cString, p_nStart, 1));
+ asc(SUBSTR(p_cString, p_nStart+1, 1))*256;
+ asc(SUBSTR(p_cString, p_nStart+2, 1))*256^2
CASE p_nLength = 4
lnRet_val = asc(SUBSTR(p_cString, p_nStart, 1));
+ asc(SUBSTR(p_cString, p_nStart+1, 1))*256;
+ asc(SUBSTR(p_cString, p_nStart+2, 1))*256^2;
+ asc(SUBSTR(p_cString, p_nStart+3, 1))*256^3
OTHERWISE
lnRet_val = -1
ENDCASE
RETURN INT(lnRet_val)
*!* EOP: ASC2BEINT.PRG*************************************************************** 解决grid空格问题*************************************************************grid 中一个令人烦恼的问题是,当不能找到它的 RecordSource 时发生混乱. 例如, 你用一个 sql-SELECT 结果游标关联到一个 grid 时, 某一次运行相同的 SELECT 时, 你可能看到的是一个空的 grid. VFP 在准备创建一个新的记录集时删除旧的记录集, 并在那一瞬间 grid 丢失了与它的 RecordSource 的联接及所有有关设置. 在重运行 SELECT 后, 有一个相同别名的新的游标, 但是它所基于的临时表有一个新的名字, 而且 grid 没有自动的聪明办法来使用它的新的 RecordSource.
一个方案是在重新运行 sql-SELECT前设置 Grid.RecordSource 为一个空的串 (""), 并在运行 SQL-SELECT后重新设置它到游标的别名. 这种处理方法在许多情况下,grid 列是按它们在游标中的顺序显示的. 在任何 ControlSources 偏离默认的游标时会发生问题. 在那种情况下, 需要重置各列的 ControlSource .
胜于令人讨厌地硬编码各 ControlSource 和危险的潜在的同步问题, 我使用更间接和方法. 在 Grid.Init() 中, 我用各列的细节填充一个自定义数组属性, 然后在稍后用该数组来重建 grid.
首先设置一个自定义数组属性. 它可以是一个表单属性或最好是在 grid 类自身中. 在 Grid.Init() 中, DIMENSION 数组,因此它拥有与 grid 列相同的行, 并且有着你想保存的属性个数的列数. 至少, 你可能要保存 ControlSource, CurrentControl, 控件的类, 列头的标题, 列宽及列顺序. 然后用 grid 信息填充该数组, 如下所示:
FOR lnColumnCounter = 1 TO This.ColumnCount
This.aRestore[lnColumnCounter, ] = <要保存的第一个属性>
This.aRestore[lnColumnCounter,2] = <要保存的第二个属性>
This.aRestore[lnColumnCounter,3] = <要保存的第三个属性>
等...
ENDFOR
任何时候你为 grid重建 RecordSource 时, 你可以遍历数组, 从数组中恢复各列. 你也可能想用一个自定义方法来处理, 这样当你需要时调用该方法即可.
应用程序环境配置文件config.fpw在程序连编时是可选的,也就是可要可不要,它保存的是一些vfp系统设置.如果存在,VFP启动时会去读取;如果没有,系统会设定默认值. 代码中建-----默认存入格式.prg ------文件夹中修改后缀为：config.fpw********************************* 表单设置背景图片pictrue属性 stretch属性值=2 ********************************* 一种加密和解密算法 JM.PRG (C)Copyright 2006-2006
* 加密: ?JM("文件名.DBF",88) &&返回.T.为成功
* 解密: ?JM("文件名.DBF",-88) &&返回.T.为成功
* 作者: Tiger5392
* 时间: 2006.06.11
PARAMETERS cFileName,nNumber
PRIVATE cFileName,nNumber,A,B,D
nHandle=FOPEN(cFileName,2)
IF nHandle<>-1
DIMENSION D(1)
ADIR(D,cFileName)
FOR I=1 TO D(1,2)
A=FREAD(nHandle,1)
B=CHR(MOD(ASC(a)+nNumber,256))
FSEEK(nHandle,I)
FWRITE(nHandle,B)
ENDFOR
FCLOSE(nHandle)
RETURN .T.
ELSE
RETURN .F.
ENDIF**************************************************
* 查找问题
seek for locatefor *用found() 测试结果 联合使用if found()=.t............****************************************************** 测试文件值类型Case Vartype(ThisForm.Text1.Value)='' && c、n。。。***************************************************** 分级设置权限方法*主菜单都是执行一些具体功能的子表单，不想让普通用户组使用的命令，就用skip for屏蔽 就是我上面说的那种
*有些子表单，普通用户也可以用，但上面有些按钮，只能管理员才能用的，就在子表单的init中判断
*将不能让普通用户点的，enabled=.f.或直接visible=.f.
*就这些。。。。 set exact on
thisform.i=thisform.i+1 &&这句是今天新学到的，用于标识试图登录的次数
select user &&当然是打开数据环境对应的账号信息表
locate for alltrim(账号)=alltrim(thisform.txt账号.value)
if found() and alltrim(密码)=alltrim(thisform.txt密码.value) &&说明找到了用户名，并且密码与名对应
if 级别="管理员"
bsadmin="sysadmin"
else
bsadmin="" &&仍然等到空，可以根据此扩充为二级权限管理员，三级权限。。
endif
do form 主表单
thisform.release
else
if thisform.i<3 &&试图登录三次以内
重输账号、密码
else
三次都错，clear events，quit
endif
endif
set exact off
************************************************ 设置该控件dragmode自动模式 *************************** 应用程序环境配置文件config.fpw 应用程序环境配置文件config.fpw在程序连编时是可选的,也就是可要可不要,它保存的是一些vfp系统设置.如果存在,VFP启动时会去读取;如果没有,系统会设定默认值. 代码中建-----默认存入格式.prg ------文件夹中修改后缀为：config.fpw ******************************** * 表单设置背景图片 pictrue属性 stretch属性值=2 ******************************** * 一种加密和解密算法 JM.PRG (C)Copyright 2006-2006 * 加密: ?JM("文件名.DBF",88) &&返回.T.为成功 * 解密: ?JM("文件名.DBF",-88) &&返回.T.为成功 * 作者: Tiger5392 * 时间: 2006.06.11 PARAMETERS cFileName,nNumber PRIVATE cFileName,nNumber,A,B,D nHandle=FOPEN(cFileName,2) IF nHandle<>-1 DIMENSION D(1) ADIR(D,cFileName) FOR I=1 TO D(1,2) A=FREAD(nHandle,1) B=CHR(MOD(ASC(a)+nNumber,256)) FSEEK(nHandle,I) FWRITE(nHandle,B) ENDFOR FCLOSE(nHandle) RETURN .T. ELSE RETURN .F. ENDIF ************************************************** * 查找问题 seek for locatefor *用found() 测试结果 联合使用 if found()=.t. ........... ***************************************************** * 测试文件值类型 Case Vartype(ThisForm.Text1.Value)='' && c、n。。。 **************************************************** * 分级设置权限方法 *主菜单都是执行一些具体功能的子表单，不想让普通用户组使用的命令，就用skip for屏蔽 就是我上面说的那种 *有些子表单，普通用户也可以用，但上面有些按钮，只能管理员才能用的，就在子表单的init中判断 *将不能让普通用户点的，enabled=.f.或直接visible=.f. *就这些。。。。 set exact on thisform.i=thisform.i+1 &&这句是今天新学到的，用于标识试图登录的次数 select user &&当然是打开数据环境对应的账号信息表 locate for alltrim(账号)=alltrim(thisform.txt账号.value) if found() and alltrim(密码)=alltrim(thisform.txt密码.value) &&说明找到了用户名，并且密码与名对应 if 级别="管理员" bsadmin="sysadmin" else bsadmin="" &&仍然等到空，可以根据此扩充为二级权限管理员，三级权限。。 endif do form 主表单 thisform.release else if thisform.i<3 &&试图登录三次以内 重输账号、密码 else 三次都错，clear events，quit endif endif set exact off ************************************************ *检验断断续续出现的错误的原因. 用以下代码创建一个叫做 *Errutil.prg 和程序. ON ERROR DO errhand IN errutil ; WITH SYS(0), ERROR(), MESSAGE(), MESSAGE(1), ; PROGRAM(), LINENO(1), DBF(), DATE(), TIME() * 错误捕捉设置结束. PROCEDURE errhand PARAMETER m.machine, m.messgnum, m.messg, m.linecode, ; m.callprog, m.inline, m.OPENTABL, m.errdate, ; m.errtime m.errspace=SELECT() && 保存当前工作区. m.errorder=ORDER() && 保存当前排序. IF LEN(ALLTRIM(m.callprog))=0 m.callprog="Command Line" STORE SPACE(0) TO m.linecode ENDIF outmsgline="错误 ; "+m.messg+CHR(13)+"行号 "+STR(m.inline)+ ; CHR(13)+ ; "程序名 = "+m.callprog+CHR(13)+"语法 :"+m.linecode * Visual FoxPro 用户使用 =MESSAGEBOX(outmsgline,32+0) * FoxPro For Windows 用户使用 Foxtools.fll 中的 MsgBox() 函数 WAIT WINDOW outmsgline TIMEOUT 5 && 所有版本均可使用该语法. IF !USED("ERRORLOG") IF FILE("ERRORLOG.DBF") SELECT 0 USE errorlog ELSE SELECT 0 thisversion=VERSION() IF LEFT(ALLTRIM(thisversion),6)="Visual" * 为 Visual FoxPro 版本创建一个自由表 CREATE TABLE errorlog FREE (machine c(20), messgnum N(4,0), ; messg c(70), linecode c(70), callprog c(40), ; inline N(6,0), OPENTABL c(25), errdate d, errtime c(8)) ELSE CREATE TABLE errorlog (machine c(20), messgnum N(4,0), ; messg c(70), linecode c(70), callprog c(40), ; inline N(6,0), OPENTABL c(25), errdate d, errtime c(8)) ENDIF ENDIF ENDIF INSERT INTO errorlog FROM MEMVAR SELECT errorlog && 选择 errorlog 表. USE && 关闭 errorlog 表. SELECT (m.errspace) && 返回到保存的工作区. IF !EMPTY(ALIAS()) SET ORDER TO (m.errorder) ENDIF RELEASE ALL LIKE m.messgnum, m.messg, m.linecode, m.callprog, ; m.inline RETURN 用以下代码创建一个名为 Ztest.prg 的程序: DO errutil && 激活 Errutil.prg 中的 ON ERROR 例程. USE c:\noexist.dbf && 因为该文件尚不存在因此会发生错误 DO C:\noexist.prg ON ERROR && 关闭活动的 ON ERROR 例程. 在 Visual FoxPro 命令窗口中打入以下命令: Do ZTest.prg. 两个 Wait 窗口显示出不愉快的错误代码行. 这些信息被放入 Errorlog.dbf 文件中. 5 秒钟后窗口消失. 激活命令窗口, 然后打开并浏览 Errorlog 表.
************************************************ * set path to 和 set default to 区别1. set default to 是设置系统默认路径的命令,如:当前程序执行时所在的路径是c:\\temp,但是系统运行后向把系统的默认路径改为d:\\temp时,就执行set defautl to d:\\temp.
2. set path to 是设置系统的文件搜索路径,如:当前程序执行时所在的路径是c:\\temp,但是系统运行后需要某些操作文件(已知这些文件所在的路径,如:d:\\temp.d:\\temp1...),而又不能改变系统运行的默认路径时,就执行set path to d:\\temp,set path to d:\\temp1 ....********************************************* Modal窗口和Modeless窗口有什么区别？
答： Modeless 窗口可以在窗口运行后，但是并没有退出窗口时，仍然运行DO Form 后的代码。
Modal 窗口必须在退出窗口后，才能继续运行DO Form 后的代码。*********************************************** 如何把表单的标题栏移掉
答：其实，这很容易制作。只要您把表单的下面几个属性
Closable ,ControlBox , Minbutton , Maxbutton , Movable
设为 False,再把Caption设为空(caption=""),就可以达到要求。*************************************************** 表单启动后的事件执行顺序DataEnvironment.BeforeOpenTables()
Form.Load()
DataEnvironment.Init()
Form.Container1.Contol1.Init()
Form.Container1.Control2.Init()
Form.Container1.Init()
******************************************************* 程序自动设定路径？
答：一般运行程序的目录并非固定不变，因此一般在程序启动时
都要查询当前运行程序的目录。下面这段程序给出当前路径的查询
方法：
Function SetPath()
LOCAL lcSys16, lcProgram
lcSys16 = SYS(16) &&查询当前运行程序名
lcProgram = SUBSTR(lcSys16, AT(":", lcSys16) - 1)
*-- If we are running MAIN.PRG directly, then
*-- CD up to the parent directory
IF RIGHT(lcProgram, 3) = "FXP"
CD ..
ENDIF
SET PATH TO PROGS, FORMS, LIBS, ;
MENU, DATA, ;
REPORTS, INCLUDE, HELP, ;
BITMAPS
SET CLASSLIB TO MAIN ,vfptool
ENDFUNC
******************************************************--锁定数据库do while !rlock() && 锁定数据库
wait window '正在锁定数据库请稍候！' Timeout 0.05
enddo
repl kcl with kcl-sp.sl && 更新数据
unlock in mjsm_temp && 解锁数据库 *****************************************************
* -- 取得卷（磁盘）信息
DECLARE INTEGER GetVolumeInformation IN WIN32API STRING @cRooDirectory ,STRING @cVolume, INTEGER nVolumeSize, ;
INTEGER @nSerialNo, INTEGER @nMaxFileNameLen, INTEGER @nFileSystemFlags, STRING @cFileSystemName, ;
INTEGER nFileSystemNameSize******************************************************
* --- 设置卷标
DECLARE INTEGER SetVolumeLabel IN WIN32API STRING cRootPathName, STRING cVolumeNamecRooDirectory = "C:\"
cVolume = SPACE(255)
nVolumeSize = 255
nSerialNo = 0
nMaxFileNameLen = 0
nFileSystemFlags = 0
cFileSystemName = SPACE(255)
nFileSystemNameSize = 255nOk = GetVolumeInformation(@cRooDirectory , @cVolume, nVolumeSize,@nSerialNo, @nMaxFileNameLen, @nFileSystemFlags, ;
@cFileSystemName,nFileSystemNameSize)
*IF nOk > 0
"cVolume =", cVolume
"nSerialNo =", LEFT(SUBSTR(TRANSFORM(nSerialNo, "@0X"), 3), 4) + "-" +RIGHT(SUBSTR(TRANSFORM(nSerialNo, "@0X"), 3), 4)
"nMaxFileNameLen = ", nMaxFileNameLen
"nFileSystemFlags = ", nFileSystemFlags
"cFileSystemName =",cFileSystemName
*ELSE
"Read Error=", nOk
*ENDIF
*? SetVolumeLabel("C:\", "WINDOWS_98")
*? SetVolumeLabel("A:\", "WINDOWS_98")
or(1).dir>xxx.txt
(2)
handle = fopen("xxx.txt",2)
s = fget(handle,10) ****************************************************** **--- 如何在一个表单上戳一个（或几个平行）的透明窟窿？--* Program Name : MakeTransparentHole.Prg
* Article No. : [Win API] - 001
* Illustrate : 如何在一个表单上戳一个（或几个平行）的透明窟窿？
* Date / Time : 2001.09.09 / 16:00
* Writer :
* 1st Post :
********************************************************
PUBLIC frm
frm = CreateObject ("Tform")
frm.Visible = .T.
* end of mainDEFINE CLASS Tform As Form
Width = 500
Height = 300
AutoCenter = .T.
BackColor = Rgb(192,224,192)
Caption = "如何在一个表单上戳一个（或几个平行）的透明窟窿" ADD OBJECT lbl1 As Tlabel WITH Caption="她初看是一个 Form 上的 Shapes，...", Left=10, Top=10
ADD OBJECT lbl2 As Tlabel WITH Caption="...但它们确实是一个洞，在背后可以放置东西。", Left=20, Top=150 PROCEDURE Load
THIS.decl
ENDPROC PROCEDURE Resize
*THIS.RemoveRegions && does not make any difference
ThisForm.ApplyRegions
ENDPROC PROCEDURE Activate
ThisForm.ApplyRegions
ENDPROC PROCEDURE RemoveRegions
= SetWindowRgn (GetFocus(), 0, 1)
ENDPROC PROCEDURE ApplyRegions
#DEFINE RGN_AND 1
#DEFINE RGN_OR 2
#DEFINE RGN_XOR 3
#DEFINE RGN_DIFF 4
#DEFINE RGN_COPY 5
#DEFINE radius 84
#DEFINE interspace 12 LOCAL hRgnBase, hRgn, hwnd, x0,y0,x1,y1
DIMEN hRgnExclude [5] && an array to store elliptical regions * create a rectangle region
* and set it by the rectangle of the form
hRgn = CreateRectRgn (0,0,1,1)
hwnd = GetFocus() && get window handle for the form
THIS.GetRect (hwnd, @x0,@y0,@x1,@y1)
hRgnBase = CreateRectRgn (0,0,x1-x0,y1-y0) x0 = 20
y0 = 70
y1 = y0 + radius
* create several elliptical regions
FOR ii=1 TO 5
hRgnExclude[ii] = CreateEllipticRgn (x0,y0, x0+radius,y1)
x0 = x0 + radius + interspace
ENDFOR
* combine elliptical regions into one region
= CombineRgn (hRgn, hRgnExclude[1], hRgnExclude [2], RGN_OR)
= CombineRgn (hRgn, hRgn, hRgnExclude [3], RGN_OR)
= CombineRgn (hRgn, hRgn, hRgnExclude [4], RGN_OR)
= CombineRgn (hRgn, hRgn, hRgnExclude [5], RGN_OR)
* subtract the resulting region
* from the region defined by the rectangle of the form
= CombineRgn (hRgn, hRgnBase, hRgn, RGN_XOR)
* apply final region to the form
= SetWindowRgn (hwnd, hRgn, 1)
* free system resources
= DeleteObject (hRgn)
FOR ii=1 TO 5
= DeleteObject (hRgnExclude[ii])
ENDFOR
= DeleteObject (hRgnBase)
ENDPROC PROCEDURE GetRect (hwnd, x0,y0,x1,y1)
LOCAL lpRect
lpRect = SPACE (16) = GetWindowRect (hwnd, @lpRect)
x0 = THIS.buf2dword (SUBSTR(lpRect, 1,4))
y0 = THIS.buf2dword (SUBSTR(lpRect, 5,4))
x1 = THIS.buf2dword (SUBSTR(lpRect, 9,4))
y1 = THIS.buf2dword (SUBSTR(lpRect, 13,4))
ENDPROC FUNCTION buf2dword (lcBuffer)
RETURN Asc(SUBSTR(lcBuffer, 1,1)) + Asc(SUBSTR(lcBuffer, 2,1)) * 256 + Asc(SUBSTR(lcBuffer, 3,1)) * 65536 + Asc(SUBSTR(lcBuffer, 4,1)) * 16777216
ENDFUNC PROCEDURE decl
DECLARE INTEGER CreateEllipticRgn IN gdi32 INTEGER nLeftRect, INTEGER nTopRect, INTEGER nRightRect, INTEGER nBottomRect
DECLARE INTEGER CreateRectRgn IN gdi32 INTEGER nLeftRect, INTEGER nTopRect, INTEGER nRightRect, INTEGER nBottomRect
DECLARE INTEGER CombineRgn IN gdi32 INTEGER hrgnDest, INTEGER hrgnSrc1, INTEGER hrgnSrc2, INTEGER fnCombineMode
DECLARE SetWindowRgn IN user32 INTEGER hWnd, INTEGER hRgn, SHORT bRedraw
DECLARE SHORT GetWindowRect IN user32 INTEGER hwnd, STRING @ lpRect
DECLARE INTEGER DeleteObject IN gdi32 INTEGER hObject
DECLARE INTEGER GetFocus IN user32
ENDPROC
ENDDEFINEDEFINE CLASS Tlabel As Label
FontName="System"
FontSize=18
AutoSize=.T.
BackStyle=0
ENDDEFINE
************************************************************************---- 如何生成世界上唯一的 64 位 ID？--* Program Name : OnlyID.Prg
* Article No. : [Win API] - 003
* Illustrate : 如何生成世界上唯一的 64 位 ID？
* Date / Time : 2001.09.09 / 18:00
* Writer :
* 1st Post :
***********************************************************************
LOCAL lcRetval, lcStruc_GUID, lcGUID, lnSize
DECLARE INTEGER CoCreateGuid IN "ole32.dll" STRING @lcGUIDStruc
DECLARE INTEGER StringFromGUID2 IN "ole32.dll" STRING cGUIDStruc, STRING @cGUID, LONG nSize* Create a GUID-structure
lcStruc_GUID = REPLICATE(" ", 16)
lcGUID = REPLICATE(" ", 80)
lnSize = LEN(lcGUID) / 2
* Pass the structure to the API function so that it creates a new ID
IF CoCreateGuid(@lcStruc_GUID) <> 0
RETURN ""
ENDIF
* Convert the structure to a string that we can use in VFP
IF StringFromGUID2(lcStruc_GUID, @lcGuid, lnSize) = 0
RETURN ""
ENDIF
STRCONV(LEFT(lcGUID, 76), 6)
RETURN STRCONV(LEFT(lcGUID, 76), 6)
**---- 如何使用和调用 Win32 的 GetUserName API？--* Program Name : GetUserID.Prg
* Article No. : [Win API] - 002
* Illustrate : 如何使用和调用 Win32 的 GetUserName API？
* Date / Time : 2001.09.09 / 17:00
* Writer :
* 1st Post :
*
Public lpUserIDBuffer, nBufferSize, RetVal
RetVal = 0
lpUserIDBuffer = SPACE(25) && Return buffer for user ID string
nBufferSize = 25 && Size of user ID return bufferDeclare INTEGER GetUserName IN Win32API AS GetName STRING @lpUserIDBuffer, INTEGER @nBufferSize
RetVal=GetName(@lpUserIDBuffer, @nBufferSize)
Define WINDOW ShowInfo FROM 0,0 TO 5,70 FLOAT CLOSE TITLES "User ID Information" FONT "System",12
Activate WINDOW ShowInfo
Move WINDOW ShowInfo CENTER
@ 0,1 SAY "User ID : " + LEFT(lpUserIDBuffer,nBufferSize-1)*******************************************************************
** -- Parameters: lcWindCaption - 应用程序窗口标题--
*******************************************************************Function TestAppRun
LPARAMETER lcWindCaption
IF TYPE('lcWindCaption') # 'C' OR EMPTY(lcWindCaption)
RETURN .F.
ENDIF
LOCAL GetWind, wclass, apphand
SET LIBRARY TO foxtools.fll ADDITIVE
GetWind = RegFn("FindWindow", "CC", "I")
wclass=0
apphand=CallFn(GetWind,wclass ,lcWindCaption)IF apphand # 0
RETURN .F.
ENDIF
RETURN .T.*******************************************************************
**--数值转换成人民币大写格式--
*Programmer:Craftsman
*2001.10.18cUnit="仟佰拾万仟佰拾圆角分"
cChar=""
If Vartype(This.Input)<>"N"
Messagebox("请确认数据类型",48,"警告")
Else
cInput=Chrtran((Ltrim(Str(This.Input,20,2))),".","")
If This.Input<=0 or Len(cInput)>10
Messagebox("您输入的数值可能存在以下问题："+Chr(13);
+"1、输入的数值太大(最大处理值：99999999.99)"+Chr(13);
+"2、输入的数值小于或等于零",48,"警告")
Else
For N=1 to Len(cInput)
If Val(Substr(Right(cInput,N),1,1))>0
cChar=Stuffc(cUnit,11-N,0,Substr("0零1壹2贰3叁4肆5伍6陆7柒8
捌9玖",At(Substr(Right(cInput,N),1,1),"0零1壹2贰3叁4肆5伍6陆7柒8捌9玖
")+1,2))
Else
Do Case
Case N=1
cChar=Stuffc(cUnit,11-N,1,"整")
Case N=2cChar=Iif(Val(Substr(Right(cInput,N-1),1,1))>0,Stuffc(cUnit,11-N,1,"零
"),Stuffc(cUnit,11-N,1,""))
Case N=3 or N=7
Loop
OtherwisecChar=Iif(Val(Substr(Right(cInput,N+1),1,1))=0,Stuffc(cUnit,11-N,1,""),Stuff
c(cUnit,11-N,1,"零"))
Endcase
Endif
cUnit=cChar
Endfor
cChar=Substrc(cChar,11-Len(cInput))
cChar=Iif("零万"$cChar,Stuffc(cChar,At_c("零万",cChar),2,"万"),cChar)
cChar=Iif(Substr(Right(cInput,6),1,1)="0" And
Substr(Right(cInput,7),1,1)="0",Stuffc(cChar,At_c("万",cChar)+1,0,"零
"),cChar)
cChar=Iif("零圆"$cChar,Stuffc(cChar,At_c("零圆",cChar),2,"圆"),cChar)
This.Output=cChar
Endif
Endiforprocedure Camount
parameter Mamount
MyAmount=alltrim(str(abs(Mamount)*100,11,0))
temp=len(alltrim(MyAmount))
chr_amount=''
For i = 1 TO temp
MYmemo=val(subs(MyAmount, temp-i+1, 1))
chr_amount =subs("零壹贰叁肆伍陆柒捌玖", MYmemo*2+1, 2)+subs("分角圆拾佰仟
万拾佰仟亿", i*2-1, 2)+ chr_amount
EndFor
chr_amount=iif(Mamount<0,'负'＋chr_amount,chr_amount)
chr_amount
return chr_amount*******************************************************************--这个Prncode.zap程序全部使用Visual Foxpro编写，用于VFP表单文件(SCX)或类库文件(VCX)过程源码查看及打印。运行于VFP环境或安装了VFP6运行时刻系统中。 说明：
1.在"打开"窗口中，选择打开表单(SCX)或类库(VCX)类型，打开文件。
2.选择"按对象"查看方式时，可把同一对象的过程显示在文本框中；选择"按过程"查看方式时，仅显示一个指定过程。
3.选择组合框内容，随查看方式不同，列表出打开文件的中包含的对象集或所有过程。
4.通过"保存"或"另存为"功能按钮，可以将文本框内容保存为文本文件。
5.通过"预览"或"打印"功能按钮，可以将文本框内容打印到屏幕或打印机中。
6.已打开源文件名称显示窗口标题中，底部标签中显示是保存文本文件名称。
7.运行于VFP环境时，执行"startapp.app"可把本程序加入工具菜单中，如果在选项窗口中，把"startapp.app"设置为启动程序，那它真的就是一个系统工具了。
8.这个小程序意在为初学者，提供一编程示例，也是VFP爱好者的一个实用小工具。您可以根据需要进行修改完善。
* Program Name : VolumeInformation.Prg
* Article No. : [Win API] - 029
* Illustrate : 常用卷标信息
* Date / Time : 2001.09.27
* Writer :
* 1st Post :
* My Comment : 需要 Win32VFP.Dll 库支持，见附件。*****************************************************************#Define FILE_CASE_SENSITIVE_SEARCH 1
#Define FILE_CASE_PRESERVED_NAMES 2
#Define FILE_UNICODE_ON_DISK 4
#Define FILE_PERSISTENT_ACLS 8
#Define FILE_FILE_COMPRESSION 16
#Define FILE_VOLUME_IS_COMPRESSED 32768 && &H8000Declare INTEGER GetLastError IN kernel32
Declare INTEGER intAnd IN win32vfp INTEGER nInt0, INTEGER nInt1Declare SHORT GetVolumeInformation IN kernel32;
STRING lpRootPathName,;
STRING @ lpVolumeNameBuffer,;
INTEGER nVolumeNameSize,;
INTEGER @ lpVolumeSerialNumber,;
INTEGER @ lpMaximumComponentLength,;
INTEGER @ lpFlags,;
STRING @ lpFileSystemNameBuffer,;
INTEGER nFileSystemNameSizelpRootPathName = "C:\" && check the slash, or "D:\", "E:\"....nVolumeNameSize = 250
lpVolumeNameBuffer = SPACE (nVolumeNameSize)
lpVolumeSerialNumber = 0
lpMaximumComponentLength = 0
lpFlags = 0
nFileSystemNameSize = 250
lpFileSystemNameBuffer = SPACE(nFileSystemNameSize)lnResult = GetVolumeInformation (lpRootPathName, @lpVolumeNameBuffer,;
nVolumeNameSize, @lpVolumeSerialNumber,;
@lpMaximumComponentLength, @lpFlags,;
@lpFileSystemNameBuffer,nFileSystemNameSize )If lnResult = 1
* display parameters returned
lpVolumeNameBuffer = LEFT(lpVolumeNameBuffer,;
AT(Chr(0),lpVolumeNameBuffer)-1)
"Volume Name: [", lpVolumeNameBuffer, "]" "Volume Serial Number: ", lpVolumeSerialNumber
"Max Filename Length: ", lpMaximumComponentLength "File System Flags: ", lpFlags
= displayFlag (lpFlags, FILE_CASE_SENSITIVE_SEARCH,;
"Case-sensitive file names support: ") = displayFlag (lpFlags, FILE_CASE_PRESERVED_NAMES,;
"The file system preserves the case of file names: ") = displayFlag (lpFlags, FILE_UNICODE_ON_DISK,;
"Unicode in file names support: ") = displayFlag (lpFlags, FILE_PERSISTENT_ACLS,;
"ACLs support: ") = displayFlag (lpFlags, FILE_FILE_COMPRESSION,;
"File-based compression support: ") = displayFlag (lpFlags, FILE_VOLUME_IS_COMPRESSED,;
"The specified volume is a compressed volume: ") lpFileSystemNameBuffer = LEFT(lpFileSystemNameBuffer,;
AT(Chr(0),lpFileSystemNameBuffer)-1)
"File System Name: [", lpFileSystemNameBuffer, "]"
Else
* 3 - The system cannot find the path specified = ERROR_PATH_NOT_FOUND
* 21 - The device is not ready = ERROR_NOT_READY
"Error code: ", GetLastError()
EndifProcedure displayFlag (lnFlags, lnMask, lcCaption)
lcResult = IIF (intAnd(lnFlags, lnMask) = lnMask, "Yes", "No")
" - ", lcCaption, lcResult
Return* Program Name : EllipticalForm.Prg
* Article No. : [Win API] - 028
* Illustrate : 椭圆型表单
* Date / Time : 2001.09.27
* Writer : Tuberose zyg8108@21cn.com
* 1st Post : News://news.newsfan.net/计算机.软件.数据库.VfpPublic frm
frm = CreateObject ("Tform")
frm.Visible = .T.
ReturnDefine CLASS Tform As Form
#Define horizDiameter 400
#Define vertDiameter 260 Caption = "椭圆型表单"
Width = 600
Height = 350
AutoCenter = .T.
MaxButton = .F.
MinButton = .F.
hRgn = 0
hwind = 0 Add OBJECT cmd As CommandButton WITH;
Width=80, Height=25, FontName='System', Caption="执行" Procedure Load
This.decl
Endproc Procedure Init
With THIS.cmd
.Top = THIS.Height - .Height - 15
.Left = (THIS.Width - .Width)/2
Endwith
Endproc Procedure cmd.Click
Thisform.TimeConsumingProc
Endproc Procedure TimeConsumingProc
* this is an emulation of a time consuming process
* while it is running the form is limited to an ellipse
Clear* limit the form to an ellipse
* defined by a region
This.regionOn
Local ii, jj
For ii=1 TO 10
Create CURSOR cs (id N(6), dt decl) "Inserting records to cursor... " For jj=1 TO 100
Insert INTO cs VALUES (jj, DATE()-jj)
DATE()-jj, ", "
Endfor
* DOEVENTS "Indexing cursor... " Index ON id TAG id
Index ON dt TAG dt
* DOEVENTS Use IN cs
"Ok | "
Endfor This.regionOff && restore the form to its original state
This.cmd.Visible = .T.
Endproc Procedure regionOn
* create an elliptical region and apply it to the form
Local x0,y0,x1,y1
x0 = (THIS.Width - horizDiameter)/2
y0 = (THIS.Height - vertDiameter)/2
x1 = x0 + horizDiameter
y1 = y0 + vertDiameter This.hwind = GetFocus()
This.hRgn = CreateEllipticRgn (x0,y0,x1,y1)
= SetWindowRgn (THIS.hwind, THIS.hRgn, 1)
Endproc Procedure regionOff
* release a region for this form
= SetWindowRgn (THIS.hwind, 0, 1)
Endproc Procedure decl
Declare INTEGER CreateEllipticRgn IN gdi32;
INTEGER nLeftRect,;
INTEGER nTopRect,;
INTEGER nRightRect,;
INTEGER nBottomRect Declare SetWindowRgn IN user32;
INTEGER hWnd,;
INTEGER hRgn,;
SHORT bRedraw Declare INTEGER GetFocus IN user32
Endproc
Enddefine **************************************************************** Program Name : WinCalc.Prg
* Article No. : [Win API] - 027
* Illustrate : 计算器
* Date / Time : 2001.09.27
* Writer :
* 1st Post : ***************************************************************Private frm
frm = CreateObject ("Tform")
frm.Show (1)Define CLASS Tform As Form
Width = 400
Height = 200
AutoCenter = .T.
Caption = "Accessing WinCalc Window" Add OBJECT cmdShow As Tbutton
Add OBJECT cmdHide As Tbutton Procedure Init
This.cmdShow.caption = "Show Calc"
This.cmdHide.caption = "Hide Calc"
This._resize
This.decl
Endproc Procedure cmdShow.click
Thisform._show
Endproc Procedure cmdHide.click
Thisform._hide
Endproc Procedure _resize
With THIS.cmdHide
.top = THIS.height - .height - 10
.left = THIS.width - .width - 10
Endwith
With THIS.cmdShow
.top = THIS.cmdHide.top
.left = THIS.cmdHide.left - .width - .3
Endwith
Endproc Protected PROCEDURE decl
Declare INTEGER SetForegroundWindow IN "user32" INTEGER hwnd Declare INTEGER FindWindow IN user32;
STRING lpClassName,;
STRING lpWindowName Declare INTEGER WinExec IN kernel32;
STRING lpCmdLine, INTEGER nCmdShow Declare SHORT PostMessage IN user32;
INTEGER hWnd,;
INTEGER Msg,;
STRING @ wParam,;
INTEGER lParam
Endproc Procedure _show
#Define SW_SHOWNORMAL 1
Local hwnd
HWnd = FindWindow (.NULL., "Calculator")
If hwnd = 0
= WinExec ("calc.exe", SW_SHOWNORMAL)
Else
= SetForegroundWindow (hwnd)
Endif
Endproc Procedure _hide
#Define WM_QUIT 18
Local hwnd
HWnd = FindWindow (.NULL., "Calculator")
If hwnd <> 0
= PostMessage (hwnd, WM_QUIT, 0,0)
Endif
Endproc
EnddefineDefine CLASS Tbutton As CommandButton
FontName = 'System'
Height = 24
Width = 100
Enddefine***************************************************************** Program Name : LocaleRecord.Prg
* Article No. : [Win API] - 026
* Illustrate : 获得系统中的所有国家/地区信息
* Date / Time : 2001.09.25
* Writer :
* 1st Post :
* My Comment :* some LCTYPE constants
#DEFINE LOCALE_ILANGUAGE 1 && language id
#DEFINE LOCALE_SLANGUAGE 2 && localized name of language
#DEFINE LOCALE_SENGLANGUAGE 4097 && English name of language
#DEFINE LOCALE_SABBREVLANGNAME 3 && abbreviated language name
#DEFINE LOCALE_SNATIVELANGNAME 4 && native name of language
#DEFINE LOCALE_ICOUNTRY 5 && country code
#DEFINE LOCALE_SCOUNTRY 6 && localized name of country
#DEFINE LOCALE_SENGCOUNTRY 4098 && English name of country
#DEFINE LOCALE_SABBREVCTRYNAME 7 && abbreviated country name
#DEFINE LOCALE_SNATIVECTRYNAME 8 && native name of country
#DEFINE LOCALE_IDEFAULTLANGUAGE 9 && default language id
#DEFINE LOCALE_IDEFAULTCOUNTRY 10 && default country code
#DEFINE LOCALE_IDEFAULTCODEPAGE 11 && default oem code page
#DEFINE LOCALE_IDEFAULTANSICODEPAGE 4100 && default ansi code page
#DEFINE LOCALE_IDEFAULTMACCODEPAGE 4113 && default mac code page#DEFINE LOCALE_ILDATE 34 && long date format ordering
#DEFINE LOCALE_ILZERO 18 && leading zeros for decimal
#DEFINE LOCALE_IMEASURE 13 && 0 = metric, 1 = US
#DEFINE LOCALE_IMONLZERO 39 && leading zeros in month field
#DEFINE LOCALE_INEGCURR 28 && negative currency mode
#DEFINE LOCALE_INEGSEPBYSPACE 87 && mon sym sep by space from neg
amt
#DEFINE LOCALE_INEGSIGNPOSN 83 && negative sign position
* more constants exist... DECLARE INTEGER GetLocaleInfo IN kernel32;
INTEGER Locale,;
INTEGER LCType,;
STRING @ lpLCData,;
INTEGER cchData CREATE CURSOR cs (;
locale N(6),;
langid C( 4),;
llnagname C(30),;
elangname C(30),;
alangname C( 3),;
nlangname C(30),;
ccode C( 3),;
lcname C(30),;
ecname C(30),;
acname C( 3),;
ncname C(30),;
dlangid C( 4),;
dccode C( 3),;
doemcp C( 5),;
dansicp C( 5),;
dmaccp C( 5),;
ldtfmt C( 2),;
ldzeros C( 2),;
metrics C( 2),;
monzero C( 2),;
necurr C( 2),;
negsep C( 2),;
negsign C( 2);
) * scan top &H10000 codes
* under WinNT 4.0 it returns 138 records
* WinMe -- 164 records
FOR ii=0 TO 65535
= saveLInfo (ii)
ENDFOR SELECT cs
GO TOP
BROW NORMAL NOWAIT
RETURN && mainPROCEDURE saveLInfo (lnLocale)
* saves one local record for the locale
IF Len (getLInfo (lnLocale, LOCALE_ILANGUAGE)) = 0
* exit if no information exists for this locale id
RETURN
ENDIF INSERT INTO cs VALUES (;
lnLocale,;
getLInfo (lnLocale, LOCALE_ILANGUAGE),;
getLInfo (lnLocale, LOCALE_SLANGUAGE),;
getLInfo (lnLocale, LOCALE_SENGLANGUAGE),;
getLInfo (lnLocale, LOCALE_SABBREVLANGNAME),;
getLInfo (lnLocale, LOCALE_SNATIVELANGNAME),;
getLInfo (lnLocale, LOCALE_ICOUNTRY),;
getLInfo (lnLocale, LOCALE_SCOUNTRY),;
getLInfo (lnLocale, LOCALE_SENGCOUNTRY),;
getLInfo (lnLocale, LOCALE_SABBREVCTRYNAME),;
getLInfo (lnLocale, LOCALE_SNATIVECTRYNAME),;
getLInfo (lnLocale, LOCALE_IDEFAULTLANGUAGE),;
getLInfo (lnLocale, LOCALE_IDEFAULTCOUNTRY),;
getLInfo (lnLocale, LOCALE_IDEFAULTCODEPAGE),;
getLInfo (lnLocale, LOCALE_IDEFAULTANSICODEPAGE),;
getLInfo (lnLocale, LOCALE_IDEFAULTMACCODEPAGE),;
getLInfo (lnLocale, LOCALE_ILDATE),;
getLInfo (lnLocale, LOCALE_ILZERO),;
getLInfo (lnLocale, LOCALE_IMEASURE),;
getLInfo (lnLocale, LOCALE_IMONLZERO),;
getLInfo (lnLocale, LOCALE_INEGCURR),;
getLInfo (lnLocale, LOCALE_INEGSEPBYSPACE),;
getLInfo (lnLocale, LOCALE_INEGSIGNPOSN);
)
RETURNPROCEDURE getLInfo (lnLocale, lnType)
***************************************************************** retrieves a value for the parameter of lnType for the locale lnLocale
lcBuffer = SPACE(250)
lnLength = GetLocaleInfo (lnLocale, lnType, @lcBuffer, Len(lcBuffer))
RETURN Iif (lnLength > 0, STRTRAN(LEFT(lcBuffer, lnLength-1), Chr(0)), "") ***************************************************************** Program Name : RemoveHistory.Prg
* Article No. : [Win API] - 025
* Illustrate : 清理[开始] -> [文档] 中的 [历史记录]
* Date / Time : 2001.09.25
* Writer :
* 1st Post :
* My Comment : 在 Windows 中运行或打开某些文件时，在[开始] -> [文
* : 档]中会留下[历史记录]，比如你打开了 Readme.Txt or
* : mumu.bmp，因此用该函数可以清楚历史记录。提高安全性。***************************************************************#Define SHARD_PATHA 2
#Define SHARD_PATHW 3
#Define SHARD_PIDL 1Declare SHAddToRecentDocs IN shell32;
INTEGER uFlags,;
STRING @ lpNameDo _clear
= _add ("c:Readme.Txt")
= _add ("c:mumu.bmp")Procedure _clear
* clears Documents list in the Windows Start menu
= SHAddToRecentDocs (SHARD_PATHA, .null.)
ReturnProcedure _add (lpName)*****************************************************************
* adds new item to the Documents list
* it does not check whether this file really exists
= SHAddToRecentDocs (SHARD_PATHA, @lpName)
Return******************************************************************* Program Name : ElapsedTime.Prg
* Article No. : [Win API] - 024
* Illustrate : 计算开机时间
* Date / Time : 2001.09.25
* Writer :
* 1st Post :
* My Comment : 用 Win API 的函数比用 VFP 的计时器控件计算时间
* : 要少开销资源。******************************************************************Declare LONG GetTickCount IN WIN32API
Local lnAPIRetVal, lnHour, lnMin
lnAPIRetVal = GetTickCount()
lnHour = ((lnAPIRetVal / 1000) / 60) / 60
lnMin = MOD(((lnAPIRetVal / 1000) / 60), 60)
Messagebox("你的电脑已运行了: " + ALLTRIM(STR(lnHour)) + " 小时, " + ;
ALLTRIM(STR(lnMin)) + " 分.")******************************************************************* Program Name : TaskBar.Prg
* Article No. : [Win API] - 023
* Illustrate : 隐藏或显示任务条 [TaskBar] 和 [开始] 按钮
* Date / Time : 2001.09.25
* Writer :
* 1st Post :
* My Comment :******************************************************************Messagebox("点击 [确认] 隐藏任务条 [TaskBar]")
HideTaskBar()
Messagebox("点击 [确认] 显示任务条 [TaskBar]")
ShowTaskBar()
If MESSAGEBOX("是否隐藏 '开始' [Start] 按钮? 如果要恢复 '开始' ;
[Start] 按钮，必须重新热启动 [Reboot] !", 36) = 6
RemoveStartButton()
EndifFunction HideTaskBar
Declare LONG FindWindow IN "user32" STRING lpClassName, STRING
lpWindowName
Declare LONG SetWindowPos IN "user32" LONG hWnd, LONG hWndInsertAfter, ;
LONG x, LONG Y, LONG cx, LONG cy, LONG wFlags
#Define WINDOWHIDE 0x80
#Define WINDOWSHOW 0x40
Local lnHandle
lnHandle = FindWindow("Shell_TrayWnd", "")
SetWindowPos(lnHandle, 0, 0, 0, 0, 0, WINDOWHIDE)
EndfuncFunction ShowTaskBar
Declare LONG FindWindow IN "user32" STRING lpClassName, STRING
lpWindowName
Declare LONG SetWindowPos IN "user32" LONG hWnd, LONG hWndInsertAfter, ;
LONG x, LONG Y, LONG cx, LONG cy, LONG wFlags
#Define WINDOWHIDE 0x80
#Define WINDOWSHOW 0x40
Local lnHandle
lnHandle = FindWindow("Shell_TrayWnd", "")
SetWindowPos(lnHandle, 0, 0, 0, 0, 0, WINDOWSHOW)
EndfuncFunction RemoveStartButton
Declare LONG FindWindow IN "user32" STRING lpClassName, STRING
lpWindowName
Declare LONG SendMessage IN "user32" LONG hWnd, LONG wMsg, ;
LONG wParam, LONG lParam
Declare LONG FindWindowEx IN "user32" LONG hWnd1, LONG hWnd2, ;
STRING lpsz1, STRING lpsz2
#Define WM_CLOSE 0x10
SendMessage(FindWindowEx(FindWindow("Shell_TrayWnd", ""), 0x0, ;
"Button", .NULL.), WM_CLOSE, 0, 0)
Endfunc
*************************************************************** [转帖]获取windows版本 * Program....: GETWINVER.PRG
* Author.....: ** Richard G Bean **
* Date.......: April 3, 2000
* Changed on 01/31/02 - Extended for XP+
****************************************************************
&& Don't currently use all these DEFINEs, but could if want to explore Server Versions
#DEFINE VER_PLATFORM_WIN32S 0
#DEFINE VER_PLATFORM_WIN32_WINDOWS 1
#DEFINE VER_PLATFORM_WIN32_NT 2
#DEFINE VER_SERVER_NT 0x80000000
#DEFINE VER_WORKSTATION_NT 0x40000000
#DEFINE VER_NT_WORKSTATION 0x00000001
#DEFINE VER_NT_DOMAIN_CONTROLLER 0x00000002
#DEFINE VER_NT_SERVER 0x00000003
#DEFINE VER_SUITE_SMALLBUSINESS 0x00000001
#DEFINE VER_SUITE_ENTERPRISE 0x00000002
#DEFINE VER_SUITE_BACKOFFICE 0x00000004
#DEFINE VER_SUITE_COMMUNICATIONS 0x00000008
#DEFINE VER_SUITE_TERMINAL 0x00000010
#DEFINE VER_SUITE_SMALLBUSINESS_RESTRICTED 0x00000020
#DEFINE VER_SUITE_EMBEDDEDNT 0x00000040
#DEFINE VER_SUITE_DATACENTER 0x00000080
#DEFINE VER_SUITE_SINGLEUSERTS 0x00000100
#DEFINE VER_SUITE_PERSONAL 0x00000200
#DEFINE VER_SUITE_BLADE 0x00000400
#DEFINE FFFF 0x0000FFFF && 65535
Declare LONG GetVersionEx in WIN32API STRING
STORE 0 to;
dwOSVersionInfoSize,;
dwMajorVersion,;
dwMinorVersion,;
dwBuildNumber,;
dwPlatformId,;
wServicePackMajor,;
wServicePackMinor,;
wSuiteMask,;
wProductType,;
wReserved
szCSDVersion = ""
PId = "(Unknown)"
lczStructure = chr(5*4+127+1+3*2+2*1)+replicate(chr(0), 5*4-1)+space(127)+chr(0);
+replicate(chr(0), 3*2+2*1)
lcReturn = ""
lnResult = GetVersionEx( @lczStructure )
IF lnResult <> 0 && No Error
dwOSVersionInfoSize = asc2BEint(lczStructure, 1, 4)
dwMajorVersion = asc2BEint(lczStructure, 5, 4)
dwMinorVersion = asc2BEint(lczStructure, 9, 4)
dwBuildNumber = BITAND(asc2BEint(lczStructure, 13, 4), FFFF)
dwPlatformId = asc2BEint(lczStructure, 17, 4)
szCSDVersion = ALLTRIM(CHRTRAN(SUBSTR(lczStructure, 21, 128),CHR(0)+CHR(1),""))
IF dwOSVersionInfoSize > 148
wServicePackMajor = asc2BEint(lczStructure, 149, 2)
wServicePackMinor = asc2BEint(lczStructure, 151, 2)
wSuiteMask = asc2BEint(lczStructure, 153, 2)
wProductType = ASC(SUBSTR(lczStructure, 155, 1))
wReserved = ASC(SUBSTR(lczStructure, 156, 1))
ENDIF
DO Case
Case dwPlatformId = VER_PLATFORM_WIN32S
PId = "32s " && "Windows 32s "
Case dwPlatformId = VER_PLATFORM_WIN32_WINDOWS
PId = "95/98 " && "Windows 95/98 "
DO CASE
CASE dwMajorVersion = 4 and dwMinorVersion = 0
PId = "95 " && "Windows 95 "
lcSubVer = SUBSTR(szCSDVersion, 1, 1)
IF INLIST(lcSubVer, "B", "C")
PId = PId + "OSR2 "
ENDIF
CASE dwMajorVersion = 4 and dwMinorVersion = 10
PId = "98 " && "Windows 98 "
lcSubVer = SUBSTR(szCSDVersion, 1, 1)
IF lcSubVer = "A"
PId = PId + "SE "
ENDIF
CASE dwMajorVersion = 4 and dwMinorVersion = 90
PId = "ME " && "Windows ME "
ENDCASE
Case dwPlatformId = VER_PLATFORM_WIN32_NT
PId = "NT " && "Windows NT "
DO CASE
CASE dwMajorVersion <= 4
PId = "NT " && "Windows NT "
CASE dwMajorVersion = 5 and dwMinorVersion = 0
PId = "2000 " && "Windows 2000 "
CASE dwMajorVersion = 5 and dwMinorVersion = 1
PId = "XP " && "Windows XP "
IF BITAND(wSuiteMask, VER_SUITE_PERSONAL) <> 0
PId = PId + "Home "
ELSE
PId = PId + "Pro "
ENDIF
ENDCASE
ENDCASE
lcReturn = PId ;
+ ALLTRIM(transform(dwMajorVersion,"99999"));
+ "." + ALLTRIM(transform(dwMinorVersion,"99999"));
+ " (Build "+ ALLTRIM(transform(dwBuildNumber,"99999"));
+ ":"+ IIF(EMPTY(szCSDVersion),"No SP", szCSDVersion);
+ ")"
ENDIF
RETURN lcReturn
******************************************************************
**!* EOP: GETWINVER.PRG
* Program....: ASC2BEINT.PRG
* Author.....: ** Richard G Bean **
* Date.......: April 3, 2000
* Abstract...: Ascii String to BigEndian Integer (i.e. Most significant byte on right)
* (use asc2int() for LittleEndian)
* Doesn't return negative numbers
* RETURN -1 if any error
* Changes....:
*******************************************************************
*FUNCTION asc2BEint
LPARAMETERS p_cString, p_nStart, p_nLength
IF PCOUNT() < 1 OR VARTYPE(p_cString) <> "C"
RETURN -1
ENDIF
IF PCOUNT() < 2 OR VARTYPE(p_nStart) <> "N"
p_nStart = 1
ENDIF
IF PCOUNT() < 3 OR VARTYPE(p_nLength) <> "N"
p_nLength = LEN(p_cString)
ENDIF
LOCAL lnRet_val
DO CASE
CASE p_nLength = 1
lnRet_val = asc(SUBSTR(p_cString, p_nStart, 1))
CASE p_nLength = 2
lnRet_val = asc(SUBSTR(p_cString, p_nStart, 1));
+ asc(SUBSTR(p_cString, p_nStart+1, 1))*256
CASE p_nLength = 3
lnRet_val = asc(SUBSTR(p_cString, p_nStart, 1));
+ asc(SUBSTR(p_cString, p_nStart+1, 1))*256;
+ asc(SUBSTR(p_cString, p_nStart+2, 1))*256^2
CASE p_nLength = 4
lnRet_val = asc(SUBSTR(p_cString, p_nStart, 1));
+ asc(SUBSTR(p_cString, p_nStart+1, 1))*256;
+ asc(SUBSTR(p_cString, p_nStart+2, 1))*256^2;
+ asc(SUBSTR(p_cString, p_nStart+3, 1))*256^3
OTHERWISE
lnRet_val = -1
ENDCASE
RETURN INT(lnRet_val)
*!* EOP: ASC2BEINT.PRG*************************************************************** 解决grid空格问题*************************************************************grid 中一个令人烦恼的问题是,当不能找到它的 RecordSource 时发生混乱. 例如, 你用一个 sql-SELECT 结果游标关联到一个 grid 时, 某一次运行相同的 SELECT 时, 你可能看到的是一个空的 grid. VFP 在准备创建一个新的记录集时删除旧的记录集, 并在那一瞬间 grid 丢失了与它的 RecordSource 的联接及所有有关设置. 在重运行 SELECT 后, 有一个相同别名的新的游标, 但是它所基于的临时表有一个新的名字, 而且 grid 没有自动的聪明办法来使用它的新的 RecordSource.
一个方案是在重新运行 sql-SELECT前设置 Grid.RecordSource 为一个空的串 (""), 并在运行 SQL-SELECT后重新设置它到游标的别名. 这种处理方法在许多情况下,grid 列是按它们在游标中的顺序显示的. 在任何 ControlSources 偏离默认的游标时会发生问题. 在那种情况下, 需要重置各列的 ControlSource .
胜于令人讨厌地硬编码各 ControlSource 和危险的潜在的同步问题, 我使用更间接和方法. 在 Grid.Init() 中, 我用各列的细节填充一个自定义数组属性, 然后在稍后用该数组来重建 grid.
首先设置一个自定义数组属性. 它可以是一个表单属性或最好是在 grid 类自身中. 在 Grid.Init() 中, DIMENSION 数组,因此它拥有与 grid 列相同的行, 并且有着你想保存的属性个数的列数. 至少, 你可能要保存 ControlSource, CurrentControl, 控件的类, 列头的标题, 列宽及列顺序. 然后用 grid 信息填充该数组, 如下所示:
FOR lnColumnCounter = 1 TO This.ColumnCount
This.aRestore[lnColumnCounter, ] = <要保存的第一个属性>
This.aRestore[lnColumnCounter,2] = <要保存的第二个属性>
This.aRestore[lnColumnCounter,3] = <要保存的第三个属性>
等...
ENDFOR
任何时候你为 grid重建 RecordSource 时, 你可以遍历数组, 从数组中恢复各列. 你也可能想用一个自定义方法来处理, 这样当你需要时调用该方法即可.
vfp 全面总结（精华）（上）
vfp 全面总结（精华）（下）
VFP全面控制EXCEL
VFP数据库（表）的
精华总结，胜读十年书（转）
VFP
VFP
VFP
几乎全面的食品英文总结 （吃遍英文单词）
几乎全面的食品英文总结 （吃遍英文单词）-
几乎全面的食品英文总结 （吃遍英文单词）
几乎全面的食品英文总结 （吃遍英文单词）！
几乎全面的食品英文总结 （吃遍英文单词）
人生大总结，太全面了，字字珠玑!!!（2）
第三章 VFP数据库（表）的概念及操作
Photoshop CS全面通教程（上）
张悟本先生的养生之道（本人总结精华）
精华总结
史上最强的笑话（精华编）
史上最强的笑话（精华编）
史上最强的笑话（精华编）！
人人网 校内 - 浏览日志 - 几乎全面的食品英文总结 （吃遍英文单词）
[转] 几乎全面的食品英文总结 （吃遍英文单词）
转载：几乎全面的食品英文总结 （吃遍英文单词）