2,722
社区成员
发帖
与我相关
我的任务
分享WIN API与其他VFP应用程序(请参考使用)1
** -- VFP和Excel都可以用来进行处理数据库表格，如果巧妙地将二者的优点结合起来，将会大大方便我们的工作。
比如我们可以利用VFP进行处理数据，而利用Excel的预览打印功能进行报表打印。这就需要我们在VFP中直接来控制Excel。下面就在开发VFP应用项目时对Excel的控制作一下介绍：
1．创建Excel对象 eole=CREATEOBJECT(′Excel.application′)
2．添加新工作簿 eole.Workbooks.add
3．设置第3个工作表为激活工作表 eole.Worksheets(″sheet3″).Activate
4．打开指定工作簿 eole.Workbooks.Open(″c:\temp\ll.xls″)
5．显示Excel窗口 eole.visible=.t.
6．更改Excel标题栏 eole.Caption=″VFP应用程序调用Microsoft Excel″
7．给单元格赋值 eole.cells(1,4).value=XM(XM为数据库字段名)
8．设置指定列的宽度(单位：字符个数) eole.ActiveSheet.Columns(1).ColumnWidth=5
9．设置指定行的高度(单位：磅) eole.ActiveSheet.Rows(1).RowHeight=1/0.035 (设定行高为1厘米，1磅=0.035厘米
10．在第18行之前插入分页符 eole.Worksheets(″Sheet1″).Rows(18).PageBreak=1
11．在第4列之前删除分页符 eole.ActiveSheet.Columns(4).PageBreak=0
12．指定边框线宽度(Borders参数如下) ole.ActiveSheet.Range(″b3:d3″).Borders(2).Weight=3
13．设置四个边框线条的类型 eole.ActiveSheet.Range(″b3:d3″).Borders(2).LineStyle=1 (其中Borders参数：1－左、2－右、3－顶、4－底、5－斜、6－斜/；LineStyle值：1与7－细实、2－细虚、4－点虚、9－双细实线)
14．设置页眉 eole.ActiveSheet.PageSetup.CenterHeader=″报表1″
15．设置页脚 eole.ActiveSheet.PageSetup.CenterFooter=″第＆P页″
16．设置页眉到顶端边距为2厘米 eole.ActiveSheet.PageSetup.HeaderMargin=2/0.035
17．设置页脚到底边距为3厘米 eole.ActiveSheet.PageSetup.FooterMargin=3/0.035
18．设置顶边距为2厘米 eole.ActiveSheet.PageSetup.TopMargin=2/0.035
19．设置底边距为4厘米 eole.ActiveSheet.PageSetup.BottomMargin=4/0.035
20．设置左边距为2厘米 eole.ActiveSheet.PageSetup.LeftMargin=2/0.035
21．设置右边距为2厘米 eole.ActiveSheet.PageSetup.RightMargin=2/0.035
22．设置页面水平居中 eole.ActiveSheet.PageSetup.CenterHorizontally=.t.
23．设置页面垂直居中 eole.ActiveSheet.PageSetup.CenterVertically=.t.
24．设置页面纸张大小 eole.ActiveSheet.PageSetup.PaperSize=1 (1－窄行8.511 ,39－宽行1411)
25．打印单元格网线 eole.ActiveSheet.PageSetup.PrintGridlines=.t.
26．拷贝整个工作表 eole.ActiveSheet.UsedRange.Copy
27．拷贝指定区域 eole.ActiveSheet.Range(″A1:E2″).Copy
28．粘贴 eole.WorkSheet(″Sheet2″).Range(″A1″).PasteSpecial
29．在第2行之前插入一行 eole.ActiveSheet.Rows(2).Insert
30．在第2列之前插入一列 eole.ActiveSheet.Columns(2).Insert
31．设置字体 eole.ActiveSheet.Cells(2,1).Font.Name=″黑体″
32．设置字体大小 eole.ActiveSheet.Cells(1,1).Font.Size=25
33．设置字体为斜体 eole.ActiveSheet.Cells(1,1).Font.Italic=.t.
34．设置整列字体为粗体 eole.ActiveSheet.Columns(1).Font.Bold=.t.
35．清除单元格公式 eole.ActiveSheet.Cells(1,4).ClearContents
36．打印预览工作表 eole.ActiveSheet.PrintPreview
37．打印输出工作表 eole.ActiveSheet.PrintOut
38．工作表另为 eole.ActiveWorkbook.SaveAs(″c:\temp\22.xls″)
39．放弃存盘 eole.ActiveWorkbook.saved=.t.
40．关闭工作簿 eole.Workbooks.close
41．退出Excel eole.quit
表头 eole.ActiveSheet.PageSetup.CenterHeader="北京市**公司4月份财务报表"
XLapp.ActiveSheet.rows(1).Font.Name="宋体" && 设置字体
xlapp.ActiveSheet.rows(1).Font.Size=15 设置字体大小
oexcel.activesheet.range("A4:B5").mergecells=.t. && 合并单元格
** -- 以上控制调用语句在中文VFP6.0企业版下运行通过，运行环境为Excel 97及中文Windows 98。
*--锁定数据库
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 cVolumeName
cRooDirectory = "C:\"
cVolume = SPACE(255)
nVolumeSize = 255
nSerialNo = 0
nMaxFileNameLen = 0
nFileSystemFlags = 0
cFileSystemName = SPACE(255)
nFileSystemNameSize = 255
nOk = 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)
比如我们可以利用VFP进行处理数据，而利用Excel的预览打印功能进行报表打印。这就需要我们在VFP中直接来控制Excel。下面就在开发VFP应用项目时对Excel的控制作一下介绍：
1．创建Excel对象 eole=CREATEOBJECT(′Excel.application′)
2．添加新工作簿 eole.Workbooks.add
3．设置第3个工作表为激活工作表 eole.Worksheets(″sheet3″).Activate
4．打开指定工作簿 eole.Workbooks.Open(″c:\temp\ll.xls″)
5．显示Excel窗口 eole.visible=.t.
6．更改Excel标题栏 eole.Caption=″VFP应用程序调用Microsoft Excel″
7．给单元格赋值 eole.cells(1,4).value=XM(XM为数据库字段名)
8．设置指定列的宽度(单位：字符个数) eole.ActiveSheet.Columns(1).ColumnWidth=5
9．设置指定行的高度(单位：磅) eole.ActiveSheet.Rows(1).RowHeight=1/0.035 (设定行高为1厘米，1磅=0.035厘米
10．在第18行之前插入分页符 eole.Worksheets(″Sheet1″).Rows(18).PageBreak=1
11．在第4列之前删除分页符 eole.ActiveSheet.Columns(4).PageBreak=0
12．指定边框线宽度(Borders参数如下) ole.ActiveSheet.Range(″b3:d3″).Borders(2).Weight=3
13．设置四个边框线条的类型 eole.ActiveSheet.Range(″b3:d3″).Borders(2).LineStyle=1 (其中Borders参数：1－左、2－右、3－顶、4－底、5－斜、6－斜/；LineStyle值：1与7－细实、2－细虚、4－点虚、9－双细实线)
14．设置页眉 eole.ActiveSheet.PageSetup.CenterHeader=″报表1″
15．设置页脚 eole.ActiveSheet.PageSetup.CenterFooter=″第＆P页″
16．设置页眉到顶端边距为2厘米 eole.ActiveSheet.PageSetup.HeaderMargin=2/0.035
17．设置页脚到底边距为3厘米 eole.ActiveSheet.PageSetup.FooterMargin=3/0.035
18．设置顶边距为2厘米 eole.ActiveSheet.PageSetup.TopMargin=2/0.035
19．设置底边距为4厘米 eole.ActiveSheet.PageSetup.BottomMargin=4/0.035
20．设置左边距为2厘米 eole.ActiveSheet.PageSetup.LeftMargin=2/0.035
21．设置右边距为2厘米 eole.ActiveSheet.PageSetup.RightMargin=2/0.035
22．设置页面水平居中 eole.ActiveSheet.PageSetup.CenterHorizontally=.t.
23．设置页面垂直居中 eole.ActiveSheet.PageSetup.CenterVertically=.t.
24．设置页面纸张大小 eole.ActiveSheet.PageSetup.PaperSize=1 (1－窄行8.511 ,39－宽行1411)
25．打印单元格网线 eole.ActiveSheet.PageSetup.PrintGridlines=.t.
26．拷贝整个工作表 eole.ActiveSheet.UsedRange.Copy
27．拷贝指定区域 eole.ActiveSheet.Range(″A1:E2″).Copy
28．粘贴 eole.WorkSheet(″Sheet2″).Range(″A1″).PasteSpecial
29．在第2行之前插入一行 eole.ActiveSheet.Rows(2).Insert
30．在第2列之前插入一列 eole.ActiveSheet.Columns(2).Insert
31．设置字体 eole.ActiveSheet.Cells(2,1).Font.Name=″黑体″
32．设置字体大小 eole.ActiveSheet.Cells(1,1).Font.Size=25
33．设置字体为斜体 eole.ActiveSheet.Cells(1,1).Font.Italic=.t.
34．设置整列字体为粗体 eole.ActiveSheet.Columns(1).Font.Bold=.t.
35．清除单元格公式 eole.ActiveSheet.Cells(1,4).ClearContents
36．打印预览工作表 eole.ActiveSheet.PrintPreview
37．打印输出工作表 eole.ActiveSheet.PrintOut
38．工作表另为 eole.ActiveWorkbook.SaveAs(″c:\temp\22.xls″)
39．放弃存盘 eole.ActiveWorkbook.saved=.t.
40．关闭工作簿 eole.Workbooks.close
41．退出Excel eole.quit
表头 eole.ActiveSheet.PageSetup.CenterHeader="北京市**公司4月份财务报表"
XLapp.ActiveSheet.rows(1).Font.Name="宋体" && 设置字体
xlapp.ActiveSheet.rows(1).Font.Size=15 设置字体大小
oexcel.activesheet.range("A4:B5").mergecells=.t. && 合并单元格
** -- 以上控制调用语句在中文VFP6.0企业版下运行通过，运行环境为Excel 97及中文Windows 98。
*--锁定数据库
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 cVolumeName
cRooDirectory = "C:\"
cVolume = SPACE(255)
nVolumeSize = 255
nSerialNo = 0
nMaxFileNameLen = 0
nFileSystemFlags = 0
cFileSystemName = SPACE(255)
nFileSystemNameSize = 255
nOk = 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)
...全文
请发表友善的回复…
发表回复
yzf911 2006-01-26
- 打赏
- 举报
只能参考，不能学习。（因为太多了)
llin_9461 2005-08-04
- 打赏
- 举报
DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD
十豆三 2005-08-02
- 打赏
- 举报
* Program Name : PrinterDrivers.Prg
* Article No. : [Win API] - 007
* Illustrate : 如何显示所安装的打印机驱动程序？
* Date / Time : 2001.09.10
* Writer :
* 1st Post :
*
Do decl
* put existing print server name; if there is one available
lcServer = "PRNSRV001"
? "*** 打印服务器上的打印机驱动程序是：" + lcServer + ":"
= displayPrinterDrivers (lcServer) && print server
?
? "*** 本地打印机驱动程序是："
= displayPrinterDrivers ("") && local drivers
Function displayPrinterDrivers (lcServer)
Local cdBuf, pDriverInfo, pcbNeeded, pcReturned
* the first call retrieves number of bytes needed to store the return
pDriverInfo = Chr(0)
Store 0 TO pcbNeeded, pcReturned
= EnumPrinterDrivers (lcServer, "Windows NT x86", 1,;
@pDriverInfo, 0, @pcbNeeded, @pcReturned)
* main call
pDriverInfo = REPLI(Chr(0), pcbNeeded)
lnResult = EnumPrinterDrivers (lcServer, Chr(0), 1,;
@pDriverInfo, pcbNeeded, @pcbNeeded, @pcReturned)
If pcReturned = 0
? "No drivers found"
? "Error code returned:", GetLastError()
Return
Else
? "pcReturned:", pcReturned
? "pcDriverInfo:", pDriverInfo
Endif
* array for storing addr-offs info
Dimen adr [pcReturned, 4]
* save 4-byte address values for returned blocks
For ii=1 TO pcReturned
ss = SUBSTR (pDriverInfo, (ii-1)*4+1, 4)
adr [ii, 1] = buf2dword(ss)
Endfor
* calculate offsets and lengths
dd = 0
For ii=pcReturned TO 2 STEP -1
adr[ii, 2] = adr[ii-1, 1] - adr[ii, 1] && substr length
dd = dd + adr[ii, 2]
adr[ii-1, 3] = dd + 1 && offset
Endfor
adr[pcReturned, 3] = 1
adr[1, 2] = Len(pDriverInfo) - pcReturned*4+1 - adr[1, 3]
* remove the leading address part from the buffer
pDriverInfo = SUBSTR(pDriverInfo, pcReturned*4+1)
* extract and display substrings -- driver names
For ii=1 TO pcReturned
adr[ii,4] = STRTRAN(SUBSTR (pDriverInfo, adr[ii,3], adr[ii,2]),
Chr(0), "")
? adr[ii,4]
Endfor
Return
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
Procedure decl
Declare INTEGER GetLastError IN kernel32
Declare INTEGER EnumPrinterDrivers IN winspool.drv;
STRING pName,;
STRING pEnvironment,;
INTEGER Level,;
STRING @ pDriverInfo,;
INTEGER cdBuf,;
INTEGER @ pcbNeeded,;
INTEGER @ pcReturned
* Program Name : ClipMouseCursor.Prg
* Article No. : [Win API] - 006
* Illustrate : 如何局限鼠标的光标活动区域？
* Date / Time : 2001.09.10
* Writer :
* 1st Post :
* My Comment : 个别用户喜欢做与本工作无关的事情，用此法 Try......
*
PUBLIC frm
frm = CreateObject("TForm")
frm.Visible = .T.
DEFINE CLASS TForm As Form
PROTECTED mClip
ADD OBJECT cmdClip As TCommand
ADD OBJECT cmdRestore As TCommand
PROCEDURE Load
THIS.decl && declare external functions
ENDPROC
PROCEDURE Init
STORE .F. TO THIS.MaxButton, THIS.MinButton
STORE 300 TO THIS.Width, THIS.Height
THIS.Caption = "Clipping Mouse Cursor Area"
THIS.BorderStyle = 2
THIS.AutoCenter = .T.
THIS.cmdClip.Caption = "Clip"
THIS.cmdRestore.Caption = "Restore"
* saving initial clipping area
lpRect = REPLI (Chr(0), 16)
= GetClipCursor (@lpRect)
THIS.mClip = lpRect
THIS.Resize
ENDPROC
PROCEDURE Destroy
THIS.restoreInitStatus
ENDPROC
PROCEDURE Resize
lnTop = MAX(5, THIS.Height - THIS.cmdClip.Height - 5)
STORE lnTop TO THIS.cmdClip.Top, THIS.cmdRestore.Top
THIS.cmdRestore.Left = THIS.Width - THIS.cmdRestore.Width - 10
THIS.cmdClip.Left = THIS.cmdRestore.Left - THIS.cmdClip.Width - 2
ENDPROC
PROCEDURE clip
* lock the mouse cursor within the form area
MOUSE AT THIS.top, THIS.left PIXELS && put cursor inside the form
* give VFP a moment to update mouse position in its internal data
= INKEY (0.1)
lpPoint = REPLI (Chr(0), 8) && buffer for a POINT structure
= GetCursorPos (@lpPoint) && retrieve absolute mouse position
LOCAL absX, absY, lcCaptionHeight, lcFrameWidth,;
lcFrameHeight, lcRect
absX = ThisForm.buf2dword (SUBSTR(lpPoint, 1,4))
absY = ThisForm.buf2dword (SUBSTR(lpPoint, 5,4))
* retrieve some sizes to be used in calculating the area
lcCaptionHeight = GetSystemMetrics ( 4) && size of normal caption area
lcFrameWidth = GetSystemMetrics (32) && resiz.window frame width
lcFrameHeight = GetSystemMetrics (33) && resiz.window frame height
lcRect = REPLI (Chr(0), 16) && buffer for RECT structure
* set the RECT by the form position, and size
THIS.num2rect (absX, absY,;
absX + THIS.Width + lcFrameWidth,;
absY + THIS.Height + lcCaptionHeight + lcFrameHeight,;
@lcRect)
= ClipCursor (lcRect) && locked!
ENDPROC
PROCEDURE restoreInitStatus
= ClipCursor (THIS.mClip)
ENDPROC
PROCEDURE cmdClip.Click
ThisForm.clip
ENDPROC
PROCEDURE cmdRestore.Click
ThisForm.restoreInitStatus
ENDPROC
FUNCTION buf2dword (lcBuffer)
#DEFINE m0 256
#DEFINE m1 65536
#DEFINE m2 16777216
RETURN;
Asc(SUBSTR(lcBuffer, 1,1)) + ;
Asc(SUBSTR(lcBuffer, 2,1)) * m0 +;
Asc(SUBSTR(lcBuffer, 3,1)) * m1 +;
Asc(SUBSTR(lcBuffer, 4,1)) * m2
ENDFUNC
FUNCTION num2buf
PARAMETERS lnValue
#DEFINE m0 256
#DEFINE m1 65536
#DEFINE m2 16777216
LOCAL b0, b1, b2, b3
b3 = Int(lnValue/m2)
b2 = Int((lnValue - b3 * m2)/m1)
b1 = Int((lnValue - b3*m2 - b2*m1)/m0)
b0 = Mod(lnValue, m0)
RETURN Chr(b0)+Chr(b1)+Chr(b2)+Chr(b3)
PROCEDURE num2rect (lnLeft, lnTop, lnRight, lnBottom, lcBuffer)
lcBuffer = THIS.num2buf(lnLeft) + THIS.num2buf(lnTop)+;
THIS.num2buf(lnRight) + THIS.num2buf(lnBottom)
ENDFUNC
PROCEDURE decl
DECLARE INTEGER ClipCursor IN user32 STRING lpRect
DECLARE INTEGER GetCursorPos IN user32 STRING @ lpPoint
DECLARE INTEGER GetClipCursor IN user32 STRING @ lpRect
DECLARE INTEGER GetSystemMetrics IN user32 INTEGER nIndex
ENDPROC
ENDDEFINE
DEFINE CLASS TCommand As CommandButton
Width = 60
Height = 25
FontName = 'System'
ENDDEFINE
十豆三 2005-08-02
- 打赏
- 举报
* Program Name : ViewIcons.Prg
* Article No. : [Win API] - 004
* Illustrate : 如何显示应用程序文件的图标？
* Date / Time : 2001.09.10
* Writer :
* 1st Post :
*
PUBLIC frm
frm = CreateObject ("Tform")
frm.Visible = .T.
DEFINE CLASS Tform As Form
Width=600
Height=400
AutoCenter = .T.
Caption = "Display Application Icons"
ADD OBJECT lbl As Label WITH;
Caption="App:", Left=15, Top=10
ADD OBJECT txt As TextBox WITH;
Left=60, Top=8, Height=24, Width=450
ADD OBJECT cmdFile As CommandButton WITH;
Caption="...", Top=8, Left=512,;
Width=30, Height=24
ADD OBJECT cmd As CommandButton WITH;
Caption="Refresh", Width=80, Height=24,;
Default=.T.
PROCEDURE Load
THIS.decl
ENDPROC
PROCEDURE Init
THIS.txt.Value = THIS.getVFPmodule()
THIS.Resize
THIS.cmd.SetFocus
THIS.drawIcons
ENDPROC
PROCEDURE Resize
WITH THIS.cmd
.Left = Int((ThisForm.Width - .Width)/2)
.Top = THIS.Height - .Height - 10
ENDWITH
ENDPROC
PROCEDURE drawIcons
* clear form
THIS.visible = .F.
THIS.visible = .T.
= INKEY (0.1) && give a break
LOCAL lcExe, hApp, lnIndex, hIcon, X,Y, dX,dY
lcExe = ALLTRIM(THIS.txt.Value)
IF Not FILE (lcExe)
WAIT WINDOW "File " + lcExe + " not found" NOWAIT
ENDIF
hApp = GetModuleHandle(0)
STORE 40 TO dX,dY
Y = 56
X = dX
lnIndex = 0
DO WHILE .T.
hIcon = ExtractIcon (hApp, lcExe, lnIndex)
IF hIcon = 0
EXIT
ENDIF
THIS._draw (hIcon, X,Y)
= DestroyIcon (hIcon)
lnIndex = lnIndex + 1
X = X + dX
IF X > THIS.Width-dX*2
X = dX
Y = Y + dY
ENDIF
ENDDO
ENDPROC
PROTECTED PROCEDURE _draw (hIcon, X,Y)
LOCAL hwnd, hdc
hwnd = GetFocus()
hdc = GetDC(hwnd) && this form
= DrawIcon (hdc, X,Y, hIcon)
= ReleaseDC (hwnd, hdc)
ENDPROC
PROCEDURE selectFile
LOCAL lcFile
lcFile = THIS.getFile()
IF Len(lcFile) <> 0
THIS.txt.Value = lcFile
THIS.drawIcons
ENDIF
ENDPROC
PROTECTED FUNCTION getFile
LOCAL lcResult, lcPath, lcStoredPath
lcPath = SYS(5) + SYS(2003)
lcStoredPath = FULLPATH (THIS.txt.Value)
lcStoredPath = SUBSTR (lcStoredPath, 1, RAT(Chr(92),lcStoredPath)-1)
SET DEFAULT TO (lcStoredPath)
lcResult = GETFILE("EXE", "Get Executable:", "Open",0)
SET DEFAULT TO (lcPath)
RETURN LOWER(lcResult)
ENDFUNC
PROCEDURE decl
DECLARE INTEGER GetFocus IN user32
DECLARE INTEGER GetDC IN user32 INTEGER hwnd
DECLARE INTEGER GetModuleHandle IN kernel32 INTEGER lpModuleName
DECLARE INTEGER ReleaseDC IN user32;
INTEGER hwnd, INTEGER hdc
DECLARE INTEGER LoadIcon IN user32;
INTEGER hInstance,;
INTEGER lpIconName
DECLARE INTEGER ExtractIcon IN shell32;
INTEGER hInst,;
STRING lpszExeFileName,;
INTEGER lpiIcon
DECLARE SHORT DrawIcon IN user32;
INTEGER hDC,;
INTEGER X,;
INTEGER Y,;
INTEGER hIcon
DECLARE INTEGER GetModuleFileName IN kernel32;
INTEGER hModule,;
STRING @ lpFilename,;
INTEGER nSize
DECLARE SHORT DestroyIcon IN user32 INTEGER hIcon
ENDPROC
PROTECTED FUNCTION getVFPmodule
LOCAL lpFilename
lpFilename = SPACE(250)
lnLen = GetModuleFileName (0, @lpFilename, Len(lpFilename))
RETURN Left (lpFilename, lnLen)
ENDFUNC
PROCEDURE cmd.Click
ThisForm.drawIcons
ENDPROC
PROCEDURE cmdFile.Click
ThisForm.selectFile
ENDPROC
ENDDEFINE
十豆三 2005-08-02
- 打赏
- 举报
* Program Name : ChangeSystemColor.Prg
* Article No. : [Win API] - 011
* Illustrate : 几个显示目录的函数
* Date / Time : 2001.09.10
* Writer :
* 1st Post :
* 1. Defining VFP executable running
Declare INTEGER GetModuleFileName IN kernel32;
INTEGER hModule,;
STRING @ lpFilename,;
INTEGER nSize
hModule = 0 && means current process
lpFilename = SPACE(250)
lnLen = GetModuleFileName (hModule, @lpFilename, Len(lpFilename))
? Left (lpFilename, lnLen)
* 2. Displaying the System directory
Declare INTEGER GetSystemDirectory IN kernel32;
STRING @ lpBuffer,;
INTEGER nSize
lpBuffer = SPACE (250)
nSizeRet = GetSystemDirectory (@lpBuffer, Len(lpBuffer))
If nSizeRet <> 0
lpBuffer = SUBSTR (lpBuffer, 1, nSizeRet)
? lpBuffer
Endif
* 3. Displaying the Windows directory
DECLARE INTEGER GetWindowsDirectory IN kernel32;
STRING @lpBuffer,;
INTEGER nSize
lpBuffer = SPACE (250)
nSizeRet = GetWindowsDirectory (@lpBuffer, Len(lpBuffer))
IF nSizeRet <> 0
lpBuffer = SUBSTR (lpBuffer, 1, nSizeRet)
? lpBuffer
ENDIF
* Program Name : ChangeSystemColor.Prg
* Article No. : [Win API] - 010
* Illustrate : 如何更改系统颜色？
* Date / Time : 2001.09.10
* Writer :
* 1st Post :
#Define COLOR_SCROLLBAR 0
#Define COLOR_ACTIVECAPTION 2
#Define COLOR_WINDOW 5
#Define COLOR_WINDOWFRAME 6
#Define COLOR_MENUTEXT 7
#Define COLOR_WINDOWTEXT 8
Declare INTEGER GetSysColor IN "user32" INTEGER nIndex
Declare INTEGER SetSysColors IN "user32";
INTEGER nChanges,;
INTEGER @ lpSysColor,;
INTEGER @ lpColorValues
* save old color
lnSavedColor = GetSysColor (COLOR_WINDOWFRAME)
* change the color
nChanges = 1
lpSysColor = COLOR_WINDOWFRAME
lpColorValues = RGB (0, 0, 255) && bright blue
? SetSysColors (nChanges, @lpSysColor, @lpColorValues)
= MESSAGEB ("窗口的边框颜色已更改，", 64, "Win32 SetSysColor")
* restore the old value
? SetSysColors (nChanges, @lpSysColor, @lnSavedColor)
= MESSAGEB ("窗口的边框颜色已回原。", 64, "Win32 SetSysColor")
* Program Name : SuspendExecution.Prg
* Article No. : [Win API] - 009
* Illustrate : 如何迟延程序的执行？
* Date / Time : 2001.09.10
* Writer :
* 1st Post :
* My Comment : 如果 INFINITE = DWORD(&Hffffffff)，将引起无限等待，
* : 我不敢用，慎用。
DECLARE Sleep IN kernel32 INTEGER dwMilliseconds
= Sleep (3000) && 迟延 3 秒
* Program Name : PrintingText.Prg
* Article No. : [Win API] - 008
* Illustrate : 如何把字符窜直接发送到 VFP 主窗口上？
* Date / Time : 2001.09.10
* Writer :
* 1st Post :
*
Do decl
HWnd = GetActiveWindow()
hDC = GetWindowDC (hwnd)
lpString = "Printing Text with TextOut"
= TextOut (hDC, 50,80, lpString, Len(lpString)) &&
= ReleaseDC (hwnd, hDC)
Procedure decl
Declare INTEGER GetWindowDC IN user32 INTEGER hwnd
Declare INTEGER ReleaseDC IN user32;
INTEGER hwnd, INTEGER hdc
Declare INTEGER GetActiveWindow IN user32
Declare INTEGER TextOut IN gdi32;
INTEGER hdc,;
INTEGER x,;
INTEGER y,;
STRING lpString,;
INTEGER nCount
* Program Name : ShellFiles.Prg
* Article No. : [Win API] - 021
* Illustrate : 使用 Shell 的文件操作与运行
* Date / Time : 2001.09.10
* Writer :
* 1st Post :
* My Comment : 在测试该程序之前，需要正确的文件名和路径，以及所关联 API，
* : 的可执行文件。
#Define SW_SHOWNORMAL 1
#Define SW_SHOWMINIMIZED 2
#Define SW_SHOWMAXIMIZED 3
Declare INTEGER GetSystemDirectory IN kernel32;
STRING @ lpBuffer, INTEGER nSize
Declare INTEGER ShellExecute IN shell32;
INTEGER hwnd, STRING lpOperation,;
STRING lpFile, STRING lpParameters,;
STRING lpDirectory, INTEGER nShowCmd
* 举例：
* 1.使用所关联的可执行文件打开对应的数据文件：
* = ShellExecute (0, "open", "c:\aa\index.mdb", "", "", SW_SHOWMAXIMIZED)
* = ShellExecute (0, "open", "c:\aa\aa.bmp", "", "", SW_SHOWMAXIMIZED)
* = ShellExecute (0, "open", "c:\aa\lacrymosa.mp3", "", "",
SW_SHOWMAXIMIZED)
* = ShellExecute (0, "open", "c:\aa\mkart.doc", "", "", SW_SHOWMAXIMIZED)
* = ShellExecute (0, "open", "c:\aa\aa.txt", "", "", SW_SHOWMAXIMIZED)
* 2.打开文件夹：
* = ShellExecute (0, "explore", "c:\Temp", "", "", SW_SHOWMAXIMIZED)
* 3.打开查找窗口：
* = ShellExecute (0, "find", "", "", getSysDir(), SW_SHOWMAXIMIZED)
* 4.打印文件：
* = ShellExecute (0, "print", "c:\aa\index.txt", "", "",
SW_SHOWMAXIMIZED)
* 5.访问互连网：
= ShellExecute(0,"open", "http://www.microsoft.com/",;
"", "", SW_SHOWMAXIMIZED)
Function getSysDir
lpBuffer = SPACE (250)
nSizeRet = GetSystemDirectory (@lpBuffer, Len(lpBuffer))
Return SUBSTR (lpBuffer, 1, nSizeRet)
* Program Name : UsingFrameRgn.Prg
* Article No. : [Win API] - 012
* Illustrate : 使用 FrameRgn 显示系统颜色
* Date / Time : 2001.09.10
* Writer :
* 1st Post :
#Define sqTop 120
#Define sqLeft 30
#Define sqHeight 64
#Define sqWidth 64
#Define stroke 32
#Define sqInterval 10
#Define dsHeight 600
#Define dsWidth 600
Do decl
X = sqLeft
Y = sqTop
lnColorIndex = 0
Do WHILE .T.
If Not _display (lnColorIndex, X,Y, sqWidth,sqHeight)
Exit
Endif
lnColorIndex = lnColorIndex + 1
X = X + sqWidth + sqInterval
If X > dsWidth
X = sqLeft
Y = Y + sqHeight + sqInterval
Endif
Enddo
Function _display (lnColorIndex, X,Y, width, height)
* draw a frame using system color
Local hwnd, hDc, hBrush, hRgn
hBrush = GetSysColorBrush (lnColorIndex)
If hBrush <> 0
HWnd = GetFocus()
hDc = GetWindowDC(hwnd)
hRgn = CreateRectRgn (X, Y, X+width, Y+height)
* draw a bold frame
= FrameRgn (hDc, hRgn, hBrush, stroke, stroke)
* set text color
= SetTextColor (hDc, Rgb (128,128,128))
* print color index value
lcColorIndex = STR(lnColorIndex, 3) + " "
= TextOut (hDc, X+4,Y+4,;
lcColorIndex, Len(lcColorIndex))
* draw a thin frame with system color 1
hBrush = GetSysColorBrush (1)
= FrameRgn (hDc, hRgn, hBrush, 1, 1)
= DeleteObject (hRgn)
= ReleaseDC (hwnd, hDc)
Return .T.
Endif
Return .F.
Procedure decl
Declare INTEGER GetFocus IN user32
Declare INTEGER GetWindowDC IN user32 INTEGER hwnd
Declare INTEGER ReleaseDC IN user32;
INTEGER hwnd, INTEGER hdc
Declare INTEGER DeleteObject IN gdi32 INTEGER hObject
Declare INTEGER GetSysColorBrush IN user32 INTEGER nIndex
Declare INTEGER CreateRectRgn IN gdi32;
INTEGER nLeftRect, INTEGER nTopRect,;
INTEGER nRightRect,INTEGER nBottomRect
Declare SHORT FrameRgn IN gdi32;
INTEGER hdc,;
INTEGER hrgn, INTEGER hbr,;
INTEGER nWidth, INTEGER nHeight
Declare INTEGER TextOut IN gdi32;
INTEGER hdc,;
INTEGER x, INTEGER y,;
STRING lpString, INTEGER nCount
Declare INTEGER SetTextColor IN gdi32;
INTEGER hdc, INTEGER crColor
十豆三 2005-08-02
- 打赏
- 举报
* Program Name : UsingShellAbout.Prg
* Article No. : [Win API] - 015
* Illustrate : 显示 Windows About 对话窗
* Date / Time : 2001.09.10
* Writer :
* 1st Post :
* My Comment : 该程序使用的人恐怕不多：字型不能调，又有免费为 MS 做广
* : 告的嫌疑。
Declare INTEGER ShellAbout IN shell32;
INTEGER hwnd,;
STRING szApp,;
STRING szOtherStuff,;
INTEGER hIcon
HWnd = 0
szApp = ">>> 显示 About 对话窗 # >>> 夜来香大酒店"
szOtherStuff = ">>> The ShellAbout Function ..."
hIcon = 0
? ShellAbout (hwnd, szApp, szOtherStuff, hIcon)
* Program Name : ReadingOptions.Prg
* Article No. : [Win API] - 014
* Illustrate : 读取注册表中 VFP 6.0 的选项
* Date / Time : 2001.09.10
* Writer :
* 1st Post :
* My Comment : 这些是有关我经常使用的函数。
#Define ERROR_SUCCESS 0
#Define KEY_READ 131097
#Define KEY_ALL_ACCESS 983103
#Define HKEY_CURRENT_USER 2147483649 && 0x80000001
Do decl
hBaseKey = 0
* lcBaseKey = "Software\Microsoft\VisualFoxPro\3.0\Options"
* lcBaseKey = "Software\Microsoft\VisualFoxPro\5.0\Options"
lcBaseKey = "Software\Microsoft\VisualFoxPro\6.0\Options"
* lcBaseKey = "Software\Microsoft\VisualFoxPro\7.0\Options"
* try this option too
* lcBaseKey = "Software\ODBC\ODBC.INI\ODBC Data Sources"
If RegOpenKeyEx (HKEY_CURRENT_USER, lcBaseKey,;
0, KEY_ALL_ACCESS, @hBaseKey) <> ERROR_SUCCESS
? "Error opening registry key"
Return
Endif
Create CURSOR cs (valuename cs(50), valuevalue cs(200))
dwIndex = 0
Do WHILE .T.
lnValueLen = 250
lcValueName = Repli(Chr(0), lnValueLen)
lnType = 0
lnDataLen = 250
lcData = Repli(Chr(0), lnDataLen)
lnResult = RegEnumValue (hBaseKey, dwIndex,;
@lcValueName, @lnValueLen, 0,;
@lnType, @lcData, @lnDataLen)
* for this case on return the type of data (lnType)
* is always equal to 1 (REG_SZ)
* that means null-terminated string
If lnResult <> ERROR_SUCCESS
Exit
Endif
lcValueName = Left (lcValueName, lnValueLen)
lcData = Left (lcData, lnDataLen-1)
Insert INTO cs VALUES (lcValueName, lcData)
dwIndex = dwIndex + 1
Enddo
= RegCloseKey (hBaseKey)
Select cs
Index ON valuename TAG valuename
Go TOP
Brow NORMAL NOWAIT
Procedure decl
Declare INTEGER RegCloseKey IN advapi32 INTEGER hKey
Declare INTEGER RegOpenKeyEx IN advapi32;
INTEGER hKey,;
STRING lpSubKey,;
INTEGER ulOptions,;
INTEGER samDesired,;
INTEGER @ phkResult
Declare INTEGER RegEnumValue IN advapi32;
INTEGER hKey,;
INTEGER dwIndex,;
STRING @ lpValueName,;
INTEGER @ lpcValueName,;
INTEGER lpReserved,;
INTEGER @ lpType,;
STRING @ lpData,;
INTEGER @ lpcbData
* Program Name : ClosingWindows.Prg
* Article No. : [Win API] - 013
* Illustrate : 关闭计算机
* Date / Time : 2001.09.10
* Writer :
* 1st Post :
* My Comment : 这些是有关 Win 9.x 快速开机/关机的函数，第二个程序只能
* : 是 Win NT。
* Note : 测试之前，务必先保存你的文件，万万！！！
#Define EWX_LOGOFF 0
#Define EWX_SHUTDOWN 1
#Define EWX_REBOOT 2
#Define EWX_FORCE 4
#Define EWX_POWEROFF 8
#Define EWX_FORCEIFHUNG 16
Declare INTEGER ExitWindows IN "user32" As "ExitWindows";
INTEGER dwReserved,;
INTEGER uReturnCode
Declare INTEGER ExitWindowsEx IN "user32" As "ExitWindowsEx";
INTEGER uFlags,;
INTEGER dwReserved
* 注销用户
* = ExitWindowsEx (EWX_LOGOFF, 0)
* 关闭计算机
* = ExitWindowsEx (EWX_SHUTDOWN, 0)
* 重新启动计算机
= ExitWindowsEx (EWX_REBOOT, 0)
* WinNT 应该用下列代码：
Declare INTEGER GetLastError IN kernel32
Declare SHORT InitiateSystemShutdown IN advapi32;
STRING lpMachineName,;
STRING lpMessage,;
INTEGER dwTimeout,;
SHORT bForceAppsClosed,;
SHORT bRebootAfterShutdown
If InitiateSystemShutdown ("", "Your time is out", 10, 0, 1) <> 1
* Common reasons for failure include an invalid
* or inaccessible computer name or insufficient privilege.
* 5 = ERROR_ACCESS_DENIED
* 120 = ERROR_CALL_NOT_IMPLEMENTED -- not supported in Win9*
? "Error code:", GetLastError()
Endif
十豆三 2005-08-02
- 打赏
- 举报
* Program Name : SetWinRegion.Prg
* Article No. : [Win API] - 020
* Illustrate : 设置表单的窗口区域
* Date / Time : 2001.09.10
* Writer :
* 1st Post :
* My Comment : 类似于‘在一个表单上戳一个（或几个平行）的透明窟窿’的
* : API，它把单进行部分透明，其表单并没有宿小，可以看见背后
* : 的东西，在 VFP 7.0 下运行，效果更佳。
Public frm
frm = CreateObject ("Tform")
frm.Visible = .T.
Return
Define CLASS Tform As Form
Caption = "Setting the Window Region"
Width = 600
Height = 350
AutoCenter = .T.
MaxButton = .F.
MinButton = .F.
Add OBJECT CmdOn As CommandButton WITH;
Left=15, Top=7, Width=120, Height=25, FontName = 'System',;
Caption="Set Region On"
Add OBJECT CmdOff As CommandButton WITH;
Left=15, Top=35, Width=120, Height=25, FontName = 'System',;
Caption="Set Region Off"
Procedure Load
This.decl
Endproc
Procedure CmdOn.Click
Thisform.regionOn
Endproc
Procedure CmdOff.Click
Thisform.regionOff
Endproc
Procedure regionOn
Local hRgn
hRgn = CreateRectRgn (0, 0, 200, 100)
= SetWindowRgn (GetFocus(), hRgn, 1)
Endproc
Procedure regionOff
= SetWindowRgn (GetFocus(), 0, 1)
Endproc
Procedure decl
Declare INTEGER GetFocus IN user32
Declare INTEGER CreateRectRgn IN gdi32;
INTEGER nLeftRect,;
INTEGER nTopRect,;
INTEGER nRightRect,;
INTEGER nBottomRect
Declare SetWindowRgn IN user32;
INTEGER hWnd,;
INTEGER hRgn,;
SHORT bRedraw
Endproc
Enddefine
* Program Name : Long2Short.Prg
* Article No. : [Win API] - 019
* Illustrate : 转换长路径/文件名为短路径/文件名
* Date / Time : 2001.09.10
* Writer :
* 1st Post :
* My Comment : FoxPro 的许多命令/函数只能处理 8/3 格式的短路径/文件名，
* : 有了 GetShortPathName API 函数，吃饭蹦蹦香......
* Usage : ? ShortPath("C:\Program Files\Microsoft Visual
* : Studio\Vfp98")
************************************************************************
Function ShortPath
******************
*** Function: Converts a Long Windows filename into a short
*** 8.3 compliant path/filename
*** Pass: lcPath - Path to check
*** Return: lcShortFileName
*************************************************************************
Lparameter lcPath
Declare INTEGER GetShortPathName IN "kernel32";
STRING @ lpszLongPath,;
STRING @ lpszShortPath,;
INTEGER cchBuffer
lcPath = lcPath
lcShortName = SPACE(260)
lnLength = LEN(lcShortName)
lnResult = GetShortPathName(@lcPath, @lcShortName, lnLength)
If lnResult = 0
Return ""
Endif
Return LEFT(lcShortName,lnResult)
* Program Name : NationalLanguage.Prg
* Article No. : [Win API] - 018
* Illustrate : 获取国家语言代码设置
* Date / Time : 2001.09.10
* Writer :
* 1st Post :
* My Comment : 系统缺省 LangID = 2052 为中文（简体），其他代码请查找
* : 手册。我在做一套双语版的‘餐饮管理软件’的时候，启动时
* : 用该函数判别是中文版还是英文版的 Windows，然后再启动相
* : 对应语言界面的软件。
DECLARE SHORT GetSystemDefaultLangID IN kernel32
DECLARE SHORT GetUserDefaultLangID IN kernel32
DECLARE SHORT GetSystemDefaultLCID IN kernel32
DECLARE SHORT GetUserDefaultLCID IN kernel32
DECLARE SHORT GetThreadLocale IN kernel32
DECLARE INTEGER GetOEMCP IN kernel32
DECLARE INTEGER GetACP IN kernel32
DECLARE INTEGER GetKBCodePage IN user32
? "系统缺省 LangID : ", GetSystemDefaultLangID()
? "用户缺省 LangID : ", GetUserDefaultLangID()
? "系统缺省局部字符集标识符 LCID : ", GetSystemDefaultLCID()
? "用户缺省局部字符集标识符 LCID : ", GetUserDefaultLCID()
? "Current Thread Locale : ", GetThreadLocale()
? "OEM 代码页标识符 : ", GetOEMCP()
? "ANSI 代码页标识符 : ", GetACP()
? "Current code page (should be the same as GetOEMCP): ", GetKBCodePage()
* Program Name : Upper2Lower.Prg
* Article No. : [Win API] - 017
* Illustrate : 字符串字母的大小写转换
* Date / Time : 2001.09.10
* Writer :
* 1st Post :
* My Comment : 一般不用该函数，因为速度要比 VFP 内含的字符串字母的大小
* : 写转换函数要慢，但可以在字符串转换量不是太大、并且是在
* : 函数群中使用，或者对某些 Unicode 串转换，或者要对字符串
* : 加密，而大多数人对 Win API 不熟，蒙一下。
DECLARE INTEGER CharLower IN user32 STRING @ lpsz
DECLARE INTEGER CharUpper IN user32 STRING @ lpsz
lcText = "I Love Tuberose, Please Kiss Me......"
? CharLower (@lcText)
? lcText
? CharUpper (@lcText)
? lcText
* Program Name : ClosingVFP.Prg
* Article No. : [Win API] - 016
* Illustrate : 强行退出 VFP
* Date / Time : 2001.09.10
* Writer :
* 1st Post :
* My Comment : 可以直接退出 VFP 的应用程序，避免按右上角的 'X'，提示
* :‘不能退出 VFP 应用程序’的烦恼，如果要直接退出 VFP 的
* : 某一子应用程序，可以用 GetExitCodeProcess 仿照使用。
Declare ExitProcess IN kernel32 INTEGER uExitCode
? ExitProcess (54) && 任意值
* Program Name : UsingShellAbout.Prg
十豆三 2005-08-02
- 打赏
- 举报
* 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 1
Declare SHAddToRecentDocs IN shell32;
INTEGER uFlags,;
STRING @ lpName
Do _clear
= _add ("c:Readme.Txt")
= _add ("c:mumu.bmp")
Procedure _clear
* clears Documents list in the Windows Start menu
= SHAddToRecentDocs (SHARD_PATHA, .null.)
Return
Procedure _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()
Endif
Function 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)
Endfunc
Function 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)
Endfunc
Function 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
十豆三 2005-08-02
- 打赏
- 举报
* 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
Enddefine
Define 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 && main
PROCEDURE 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);
)
RETURN
PROCEDURE 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)), "")
十豆三 2005-08-02
- 打赏
- 举报
* 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 && &H8000
Declare INTEGER GetLastError IN kernel32
Declare INTEGER intAnd IN win32vfp INTEGER nInt0, INTEGER nInt1
Declare SHORT GetVolumeInformation IN kernel32;
STRING lpRootPathName,;
STRING @ lpVolumeNameBuffer,;
INTEGER nVolumeNameSize,;
INTEGER @ lpVolumeSerialNumber,;
INTEGER @ lpMaximumComponentLength,;
INTEGER @ lpFlags,;
STRING @ lpFileSystemNameBuffer,;
INTEGER nFileSystemNameSize
lpRootPathName = "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()
Endif
Procedure 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/计算机.软件.数据库.Vfp
Public frm
frm = CreateObject ("Tform")
frm.Visible = .T.
Return
Define 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
* 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 && &H8000
Declare INTEGER GetLastError IN kernel32
Declare INTEGER intAnd IN win32vfp INTEGER nInt0, INTEGER nInt1
Declare SHORT GetVolumeInformation IN kernel32;
STRING lpRootPathName,;
STRING @ lpVolumeNameBuffer,;
INTEGER nVolumeNameSize,;
INTEGER @ lpVolumeSerialNumber,;
INTEGER @ lpMaximumComponentLength,;
INTEGER @ lpFlags,;
STRING @ lpFileSystemNameBuffer,;
INTEGER nFileSystemNameSize
lpRootPathName = "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()
Endif
Procedure 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/计算机.软件.数据库.Vfp
Public frm
frm = CreateObject ("Tform")
frm.Visible = .T.
Return
Define 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
十豆三 2005-08-02
- 打赏
- 举报
**---- 如何生成世界上唯一的 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 buffer
Declare 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.18
cUnit="仟佰拾万仟佰拾圆角分"
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=2
cChar=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
Otherwise
cChar=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
Endif
or
procedure 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 : 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 buffer
Declare 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.18
cUnit="仟佰拾万仟佰拾圆角分"
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=2
cChar=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
Otherwise
cChar=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
Endif
or
procedure 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爱好者的一个实用小工具。您可以根据需要进行修改完善。
十豆三 2005-08-02
- 打赏
- 举报
**--- 如何在一个表单上戳一个（或几个平行）的透明窟窿？--
* 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 main
DEFINE 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
ENDDEFINE
DEFINE CLASS Tlabel As Label
FontName="System"
FontSize=18
AutoSize=.T.
BackStyle=0
ENDDEFINE
十豆三 2005-08-02
- 打赏
- 举报
**--- VFP中实现背景音乐的几种方法 ---
一、利用set bell to
VFP5.0的set bell to命令的使用格式不同于FoxPro2.X的格式。在VFP5.0中，它的格式为Set Bell To [cWAVFileName, nDuration]。其中cWAVFileName为一个.WAV文件；nDuration为持续时间（注意该项不可省略，否则会产生语法错误）。这样当在个人程序的初始模块中用set bell to 定向到一.WAV文件后，便可在后面的模块中用？chr（7）来播放该.WAV文件。
示例1：
set bell on ＆＆使bell有效
set bell to′ .WAV′,0 ＆＆使bell定向到一个.WAV 文件。注意有单引号
?chr(7) ＆＆播放该.WAV文件
二、利用OLE容器控件
创建一表单，单击表单控件工具栏中的“OLE容器控件”按钮，然后在表单上适当位置点击或拖动。在出现的“Insert Object”窗口中选“Creat New”或“Creat FromFile”，用“Browse”按钮选取自己的.WAV文件，确定即可。
在当前表单中会出现一“喇叭”图标，设置该图标的属性“ AutoActivate”为1，可使每当表单运行时自动播放该.WAV文件，实现背景音乐；设置Height、Width均为0时，可隐藏“喇叭”图标。
三、利用VFP库Foxtools.fll(要Ddereg.exe文件支持)
用=Regfn（）和=Callfn（）可访问Foxtools.fll中的音频模块，进行播放声音文件。
示例2：
创建一表单，在其Activate事件中输入下列代码：
public ss ＆＆定义一全局变量ss
set library to foxtools.fll ＆＆打开库Foxtools.fll
ss=Regfn(″SndPlaySound″,″CI″,″I″,″mmsystem″) ＆＆取得音频信息
=Callfn(ss,″一.wav文件″,n) ＆＆n=0（1,2,3也可）时只播放一遍，n=9时循环播放
在其Destroy事件中输入下列代码：
=Callfn(ss,″″,10) ＆＆停止播放
set library to ＆＆从内存中释放库foxtools.fll
四、利用Windows的动态链接库(利用Samples.vcx类,要Foxtools.fll文件支持)
在VFP5.0的安装目录samples\classes下，有一类库samples\classes。其中提供有两种控件：视频和音频，音频可以控制播放.WAV和.MID文件，利用它可轻松地实现背景音乐。下面给出它的实例。
示例3：
创建一表单，在表单控件工具栏中选择类按钮，添加VFP5.0中的samples\classes\samples.vbx类库。此时表单控件工具栏中会出现SoundPlayer和VideoFrame两个多媒体控件。选择SoundPlayer，在表单上单击后，设置它的属性如下：
AutoOpen=.t.
AutoPlay=.t.
AutoRepeat=.t.
Class=SoundPlayer
Soundfile=指定一.WAV或.MID文件 ＆＆注意没有引号
Visible=.f. ＆＆不可见
**---- 应用程序实现在浏览器中运行 --
一般情况下，在使用VFP系统开发的应用系统，只要经过编译、发布和安装过程就可以脱离VFP运行环境而在操作系统中直接运行。其实这只是应用系统的一种运行方式，我们完全可以利用活动文档（Active Documents）的功能，实现将单纯操作系统方式下的应用系统向基于HTML的客户界面应用程序的转变。通过活动文档可顺利地将以前编写的应用程序移植到Web页面上，并可将VFP的功能传递到浏览器上。
下面以一个人员情况应用程序实现在浏览器中运行为例，介绍具体的实现过程：
1.新建一个项目命名为new，并在该项目文件管理器添加一个表单BD1到项目中，设定该表单的属性如下：
TitleBar=0 &&&&关闭表单的标题栏
WindowState=2 &&&&设定表单运行时为最大化方式
ScollBar=3 &&&&设定当表格处于非整屏显示时，可以使用垂直和水平滚动条
在表单对象的Destory Events事件中加入如下程序代码：
clear Events &&&&保证当表单关闭时，用户能够退出应用程序的运行
2.在表单中添加数据环境和控件对象。
在表单的数据环境中添加一个数据表作为表单中的数据源，在这里我们增加的是一个人员情况表。
利用鼠标拖动数据环境中的相应字段选项添加到表单中，作为表单的编辑对象，并添加一个对数据记录进行操作的类对象，设置完毕的表单如图1。
3.添加活动文档类到项目，在建立好用户应用程序界面后，就可以向项目中添加活动文档类，其步骤如下：
在项目管理器中选择“类”页面，单击“新建”按钮，创建一个活动文档类，设定其基类为活动文档，将之存储于自定义的类库文件中。
设定好新类后双击对象，打开新类对象的代码窗口，为新类对象的Destory Events事件设定程序代码如下：
DO FORM BD1
READ EVENTS
设定新类对象的属性：
ContainerReleaseType=1 &&&&用户离开活动文档时，VFP将自动退出
4.设定生成的新类为主文件，VFP6中活动文档应用程序的编译方式与其他普通VFP应用程序相同。将活动文档表单连接为应用程序，编译后将生成一个new.app应用程序，这个应用程序可以在VFP环境下或在浏览器中运行。
为了在浏览器中运行活动文档，我们要在系统选单“工具”中选择“运行ActiveDocument”，在文件名编辑框中输入要运行的活动文档的文件名new.app，单击“运行”按钮，系统会提示你对欲运行的文件处理进行选择，这里我们要选择“在文件的当前位置打开”选项，便可在浏览器中运行活动文档.
通过上面的操作步骤，我们就可以很方便地实现把使用VFP系统编写的应用程序移植到浏览器中去运行。
十豆三 2005-08-02
- 打赏
- 举报
首先多谢帖主分享！现将整理为一个帖子，以便加入精华区。
------------------------------------------------------------
** --怎样让编辑框内的文字不自动换行。只到回车后才换行。
编辑框的init:
publi beforwidth,afterwidth,startwidth,formstartleft
beforwidth=thisform.textwidth(this.value)
startwidth=this.width
formstartleft=thisform.left
thisform.text1.value=beforwidth
编辑框的interactivechange:
afterwidth=thisform.textwidth(this.value)+2*THIS.MARGIN*FONTMETRIC(6,THIS.FO
NTNAME,THIS.FONTSIZE)
if afterwidth>=startwidth
this.width=AFTERWIDTH+THIS.MARGIN*FONTMETRIC(6,THIS.FONTNAME,THIS.FONTSIZE)
thisform.width=thisform.width+afterwidth-beforwidth
thisform.left=thisform.left-afterwidth+beforwidth
endi
beforwidth=afterwidth
编辑框的keypress:
if nkeycode=13
thisform.left=formstartleft
afterwidth=0
endi
** --表单上通过一个按钮唤醒一个计算器
在按钮的Click事件加入:
activate window calculator
** --VFP 中的数据压缩与恢复
1. 控件注册
首先将这两个控件连同许可文件addZIP.lic 复制到windows\system 目录下，或是你自己的控件库目录里。然后启动VFP，选择工具/选项/控件/ActiveX 控件，按下添加按钮，将azip32.ocx 和aunzip32.ocx 注册。然后这两个控件就出现在ActiveX 控件列表中了。注意，要将这两个控件名称左边的核选框选中，以确保它们能够被VFP 使用。由于这两个控件需要MFC42.DLL 和MSVCRT.DLL 的支持，因此windows\system 目录下还要有这两个文件。如果你开发的系统里使用了这两个控件，那么在定制安装程序时不要忘记把它们都添加进去。
2. 创建示例表单
新建一个表单a，然后在表单控件工具条上单击查看类按钮， 选择ActiveX。随后出现启用的ActiveX 工具条，其中+Z 图标就是压缩控件，-U 图标就是解压缩控件。
3. 添加一个压缩控件
---- 通常要设置的属性如下：
Abort: 中断压缩过程的过程。
Appearance: 压缩控件的外观设置，0 是平面方式，1 是3D 方式。本例采用默认值。
ArchiveName: 要生成的压缩文件名。本例设为test.zip。
CompressionLevel: 设置压缩速率。0 是不压缩，1 是最小压缩，2 是通常方式压缩，3 是最大方式压缩。 默认值是2。 本例采用默认值。 Exclude: 不压缩的文件。默认值是空，这里填*.bak。可以设置为排斥多种类型的文件：*.ini|*.bat|*.bak 等等。
Include: 要压缩文件的类型。默认值是*.*(当前目录下的所有文件)。可以按照需要设置为*.dbf 等等。本例采用默认值。
IncludeListFile: 要压缩文件的列表文件名，默认值为空。如果该属性设置为filename.txt，则应存在文件filename.txt，并且它的内容应当是要压缩的文件目录列表，每一项单独占一行，例如：
c:\data\*.*
d:\data\data\*.*
d:\data\code\*.*
d:\data\vcx\*.dat
通过这种方法，可以一次压缩多个不同目录下的数据文件。本例设置为空。
name: 控件名称。本例设置为oZip。
Password: 压缩包的保护口令。如果想用口令保护压缩包，则必须填写口令。本例不填写。
QueryDiskChange: 在分盘压缩模式下，需要更换磁盘事件的方法。本例不作使用。
QueryOverwrite: 提示是否覆盖已经存在数据时的事件方法。本例使用控件的默认过程。
recurse: 是否压缩指定目录的子目录。默认值是.f.，本例设置为.T.。
span: 是否要进行分盘压缩。默认值是.f.。本例采用默认值。
structure: 存放数据的目录结构方式。0 是不存放，1 是相对路径，2 是绝对路径。默认值是2，本例采用默认值。
style: 压缩进度的显示风格。0 是标准风格，1 是分段风格，2 是色彩过渡风格。默认值是0。本例设置为1。
segments: 压缩进度条分段数目。默认值是10。本例采用默认值。
ZipError Event: 压缩过程中发生的错误事件，用户可以在此设置自己的错误处理过程。本例使用控件的默认过程。
ZipWarning Event: 压缩过程中发生的警告性事件，用户可以在此设置对警告事件的处理过程。本例使用控件的默认过程。
Zipped Event: 压缩过程结束事件，用户可以在此设置提示压缩完成信息。本例使用控件的默认过程。
Zipping Event: 压缩过程正在进行时的事件，用户可以在此设置提示正在压缩的信息。本例使用控件的默认过程。
Update: 更新压缩数据包。和Zip 方法的作用基本相同，但只压缩已经发生变化的数据。
Version: 返回压缩控件的版本号。
4. 添加一个解压缩控件
---- 通常要设置的属性如下：
Abort: 中断解压缩过程的过程。
Appearance: 解压缩控件的外观设置，0 是平面方式，1 是3D 方式。本例采用默认值。
ArchiveName: 要还原的压缩文件名，默认值为空。本例设为test.zip。
ExtractTo: 将数据恢复到哪个目录下，默认值为空。本例设为c:\。
Exclude: 不恢复的文件，默认值是空。本例使用默认值。
Include: 要恢复文件的类型。默认值是*.*(恢复压缩包中的所有文件)。本例使用默认值。
name: 控件名称。本例设置为oUnZip。
Overwrite: 是否覆盖同名的文件。10 是逐一询问，11 是覆盖所有的同名文件，12 是不覆盖。本例使用默认值。
Password: 压缩包的保护口令。如果压缩包受口令保护，则必须填写相应的口令方可解压缩。本例不填写。
QueryDiskChange: 释放分盘压缩的数据包需要更换磁盘时的事件方法。本例使用控件的默认过程。
QueryOverwrite: 提示是否覆盖时的事件方法。本例使用控件的默认过程。
RestoreStructure: 是否按照数据的目录结构进行恢复。默认值是.F.，本例设置为.T.。
style: 解压缩进度显示风格。0 是标准风格，1 是分段风格，2 是色彩过渡风格，默认值是0。本例设置为2。
segments: 解压缩进度条分段数目。默认值是10。本例采用默认值。
Test: 检测压缩文件是否正常。正常则返回.T.，否则返回.F.。
Unzip: 解压缩数据的方法。
UnzipError Event: 解压缩过程中发生的错误事件，可以在此设置自己的错误处理过程。本例使用控件的默认过程。
UnzipWarning Event: 解压缩过程中发生的警告性事件，可以在此设置对警告事件的处理过程。本例使用控件的默认过程。
Unzipped Event: 解压缩过程结束事件，可以在此设置提示解压缩完成信息。本例使用控件的默认过程。
Unzipping Event: 解压缩过程正在进行时的事件，可以在此设置提示正在解压缩的信息。本例使用控件的默认过程。
Update: 更新被释放的数据。和Unzip 方法的作用基本相同，但只释放已经发生变化的数据。
Version: 返回解压缩控件的版本号。
5. 将这两个控件的外观都调整为进度条样式。
6. 添加按钮，调整属性如下：
caption: 压缩
name: cmdZip
---- 为它的Click Event 方法添加如下代码：
THISFORM.oZip.update && 开始压缩当前目录下所有的数据=MESSAGEBOX(' 压 缩 完 毕 ！')
7. 添加按钮，调整属性如下：
caption: 解压缩
name: cmdUnzip
---- 为它的Click Event 方法添加如下代码：
THISFORM.oUnZip.ExtractTo = "c:\tmp" && 将数据恢复到c 盘的Tmp 目录下。如果想原样恢复到D 盘上，只需将该属性改为"d:\ " 即可。
THISFORM.oUnZip.RestoreStructure = .T. && 按照原来的目录层次恢复数据
THISFORM.oUnzip.update && 开始恢复指定的压缩包数据到当前目录下
=MESSAGEBOX(' 恢 复 完 毕 ！')
8. 运行表单a
---- 通过单击压缩按钮和解压缩按钮，可以看到压缩和解压缩的进度动态显示直到最终完成，并且用资源管理器可以看到test.zip 文件的生成，以及在c:\tmp 目录下恢复出现的当前数据(如果有子目录的话，同样会按原样恢复)。而且，用其他解压缩软件如pkunzip 及zipmagic 等也可以正确地释放test.zip 文件。
------------------------------------------------------------
** --怎样让编辑框内的文字不自动换行。只到回车后才换行。
编辑框的init:
publi beforwidth,afterwidth,startwidth,formstartleft
beforwidth=thisform.textwidth(this.value)
startwidth=this.width
formstartleft=thisform.left
thisform.text1.value=beforwidth
编辑框的interactivechange:
afterwidth=thisform.textwidth(this.value)+2*THIS.MARGIN*FONTMETRIC(6,THIS.FO
NTNAME,THIS.FONTSIZE)
if afterwidth>=startwidth
this.width=AFTERWIDTH+THIS.MARGIN*FONTMETRIC(6,THIS.FONTNAME,THIS.FONTSIZE)
thisform.width=thisform.width+afterwidth-beforwidth
thisform.left=thisform.left-afterwidth+beforwidth
endi
beforwidth=afterwidth
编辑框的keypress:
if nkeycode=13
thisform.left=formstartleft
afterwidth=0
endi
** --表单上通过一个按钮唤醒一个计算器
在按钮的Click事件加入:
activate window calculator
** --VFP 中的数据压缩与恢复
1. 控件注册
首先将这两个控件连同许可文件addZIP.lic 复制到windows\system 目录下，或是你自己的控件库目录里。然后启动VFP，选择工具/选项/控件/ActiveX 控件，按下添加按钮，将azip32.ocx 和aunzip32.ocx 注册。然后这两个控件就出现在ActiveX 控件列表中了。注意，要将这两个控件名称左边的核选框选中，以确保它们能够被VFP 使用。由于这两个控件需要MFC42.DLL 和MSVCRT.DLL 的支持，因此windows\system 目录下还要有这两个文件。如果你开发的系统里使用了这两个控件，那么在定制安装程序时不要忘记把它们都添加进去。
2. 创建示例表单
新建一个表单a，然后在表单控件工具条上单击查看类按钮， 选择ActiveX。随后出现启用的ActiveX 工具条，其中+Z 图标就是压缩控件，-U 图标就是解压缩控件。
3. 添加一个压缩控件
---- 通常要设置的属性如下：
Abort: 中断压缩过程的过程。
Appearance: 压缩控件的外观设置，0 是平面方式，1 是3D 方式。本例采用默认值。
ArchiveName: 要生成的压缩文件名。本例设为test.zip。
CompressionLevel: 设置压缩速率。0 是不压缩，1 是最小压缩，2 是通常方式压缩，3 是最大方式压缩。 默认值是2。 本例采用默认值。 Exclude: 不压缩的文件。默认值是空，这里填*.bak。可以设置为排斥多种类型的文件：*.ini|*.bat|*.bak 等等。
Include: 要压缩文件的类型。默认值是*.*(当前目录下的所有文件)。可以按照需要设置为*.dbf 等等。本例采用默认值。
IncludeListFile: 要压缩文件的列表文件名，默认值为空。如果该属性设置为filename.txt，则应存在文件filename.txt，并且它的内容应当是要压缩的文件目录列表，每一项单独占一行，例如：
c:\data\*.*
d:\data\data\*.*
d:\data\code\*.*
d:\data\vcx\*.dat
通过这种方法，可以一次压缩多个不同目录下的数据文件。本例设置为空。
name: 控件名称。本例设置为oZip。
Password: 压缩包的保护口令。如果想用口令保护压缩包，则必须填写口令。本例不填写。
QueryDiskChange: 在分盘压缩模式下，需要更换磁盘事件的方法。本例不作使用。
QueryOverwrite: 提示是否覆盖已经存在数据时的事件方法。本例使用控件的默认过程。
recurse: 是否压缩指定目录的子目录。默认值是.f.，本例设置为.T.。
span: 是否要进行分盘压缩。默认值是.f.。本例采用默认值。
structure: 存放数据的目录结构方式。0 是不存放，1 是相对路径，2 是绝对路径。默认值是2，本例采用默认值。
style: 压缩进度的显示风格。0 是标准风格，1 是分段风格，2 是色彩过渡风格。默认值是0。本例设置为1。
segments: 压缩进度条分段数目。默认值是10。本例采用默认值。
ZipError Event: 压缩过程中发生的错误事件，用户可以在此设置自己的错误处理过程。本例使用控件的默认过程。
ZipWarning Event: 压缩过程中发生的警告性事件，用户可以在此设置对警告事件的处理过程。本例使用控件的默认过程。
Zipped Event: 压缩过程结束事件，用户可以在此设置提示压缩完成信息。本例使用控件的默认过程。
Zipping Event: 压缩过程正在进行时的事件，用户可以在此设置提示正在压缩的信息。本例使用控件的默认过程。
Update: 更新压缩数据包。和Zip 方法的作用基本相同，但只压缩已经发生变化的数据。
Version: 返回压缩控件的版本号。
4. 添加一个解压缩控件
---- 通常要设置的属性如下：
Abort: 中断解压缩过程的过程。
Appearance: 解压缩控件的外观设置，0 是平面方式，1 是3D 方式。本例采用默认值。
ArchiveName: 要还原的压缩文件名，默认值为空。本例设为test.zip。
ExtractTo: 将数据恢复到哪个目录下，默认值为空。本例设为c:\。
Exclude: 不恢复的文件，默认值是空。本例使用默认值。
Include: 要恢复文件的类型。默认值是*.*(恢复压缩包中的所有文件)。本例使用默认值。
name: 控件名称。本例设置为oUnZip。
Overwrite: 是否覆盖同名的文件。10 是逐一询问，11 是覆盖所有的同名文件，12 是不覆盖。本例使用默认值。
Password: 压缩包的保护口令。如果压缩包受口令保护，则必须填写相应的口令方可解压缩。本例不填写。
QueryDiskChange: 释放分盘压缩的数据包需要更换磁盘时的事件方法。本例使用控件的默认过程。
QueryOverwrite: 提示是否覆盖时的事件方法。本例使用控件的默认过程。
RestoreStructure: 是否按照数据的目录结构进行恢复。默认值是.F.，本例设置为.T.。
style: 解压缩进度显示风格。0 是标准风格，1 是分段风格，2 是色彩过渡风格，默认值是0。本例设置为2。
segments: 解压缩进度条分段数目。默认值是10。本例采用默认值。
Test: 检测压缩文件是否正常。正常则返回.T.，否则返回.F.。
Unzip: 解压缩数据的方法。
UnzipError Event: 解压缩过程中发生的错误事件，可以在此设置自己的错误处理过程。本例使用控件的默认过程。
UnzipWarning Event: 解压缩过程中发生的警告性事件，可以在此设置对警告事件的处理过程。本例使用控件的默认过程。
Unzipped Event: 解压缩过程结束事件，可以在此设置提示解压缩完成信息。本例使用控件的默认过程。
Unzipping Event: 解压缩过程正在进行时的事件，可以在此设置提示正在解压缩的信息。本例使用控件的默认过程。
Update: 更新被释放的数据。和Unzip 方法的作用基本相同，但只释放已经发生变化的数据。
Version: 返回解压缩控件的版本号。
5. 将这两个控件的外观都调整为进度条样式。
6. 添加按钮，调整属性如下：
caption: 压缩
name: cmdZip
---- 为它的Click Event 方法添加如下代码：
THISFORM.oZip.update && 开始压缩当前目录下所有的数据=MESSAGEBOX(' 压 缩 完 毕 ！')
7. 添加按钮，调整属性如下：
caption: 解压缩
name: cmdUnzip
---- 为它的Click Event 方法添加如下代码：
THISFORM.oUnZip.ExtractTo = "c:\tmp" && 将数据恢复到c 盘的Tmp 目录下。如果想原样恢复到D 盘上，只需将该属性改为"d:\ " 即可。
THISFORM.oUnZip.RestoreStructure = .T. && 按照原来的目录层次恢复数据
THISFORM.oUnzip.update && 开始恢复指定的压缩包数据到当前目录下
=MESSAGEBOX(' 恢 复 完 毕 ！')
8. 运行表单a
---- 通过单击压缩按钮和解压缩按钮，可以看到压缩和解压缩的进度动态显示直到最终完成，并且用资源管理器可以看到test.zip 文件的生成，以及在c:\tmp 目录下恢复出现的当前数据(如果有子目录的话，同样会按原样恢复)。而且，用其他解压缩软件如pkunzip 及zipmagic 等也可以正确地释放test.zip 文件。
邦迪代驾 2005-08-02
- 打赏
- 举报
啊，终于拉到底了！！！
